(git:8dea62c)
Loading...
Searching...
No Matches
message_passing.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \brief Interface to the message passing library MPI
10!> \par History
11!> JGH (02-Jan-2001): New error handling
12!> Performance tools
13!> JGH (14-Jan-2001): New routines mp_comm_compare, mp_cart_coords,
14!> mp_rank_compare, mp_alltoall
15!> JGH (06-Feb-2001): New routines mp_comm_free
16!> JGH (22-Mar-2001): New routines mp_comm_dup
17!> fawzi (04-NOV-2004): storable performance info (for f77 interface)
18!> Wrapper routine for mpi_gatherv added (22.12.2005,MK)
19!> JGH (13-Feb-2006): Flexible precision
20!> JGH (15-Feb-2006): single precision mp_alltoall
21!> \author JGH
22! **************************************************************************************************
23MODULE message_passing
24 USE iso_c_binding, ONLY: c_f_pointer, c_ptr
25 USE kinds, ONLY: &
26 dp, int_4, int_4_size, int_8, int_8_size, real_4, real_4_size, real_8, &
27 real_8_size, default_string_length
28 USE machine, ONLY: m_abort
29 USE mp_perf_env, ONLY: add_perf, add_mp_perf_env, rm_mp_perf_env
30#if defined(__MIMIC)
31 USE mcl, ONLY: mcl_initialize, mcl_is_initialized, mcl_abort
32#endif
33
34#include "../base/base_uses.f90"
35
36! To simplify the transition between the old MPI module and the F08-style module, we introduce these constants to switch between the required handle types
37! Unfortunately, Fortran does not offer something like typedef in C++
38#if defined(__parallel) && defined(__MPI_F08)
39#define MPI_DATA_TYPE TYPE(MPI_Datatype)
40#define MPI_COMM_TYPE TYPE(MPI_Comm)
41#define MPI_REQUEST_TYPE TYPE(MPI_Request)
42#define MPI_WIN_TYPE TYPE(MPI_Win)
43#define MPI_FILE_TYPE TYPE(MPI_File)
44#define MPI_INFO_TYPE TYPE(MPI_Info)
45#define MPI_STATUS_TYPE TYPE(MPI_Status)
46#define MPI_GROUP_TYPE TYPE(MPI_Group)
47#define MPI_STATUS_EXTRACT(X) %X
48#define MPI_GET_COMP %mpi_val
49#else
50#define MPI_DATA_TYPE INTEGER
51#define MPI_COMM_TYPE INTEGER
52#define MPI_REQUEST_TYPE INTEGER
53#define MPI_WIN_TYPE INTEGER
54#define MPI_FILE_TYPE INTEGER
55#define MPI_INFO_TYPE INTEGER
56#define MPI_STATUS_TYPE INTEGER, DIMENSION(MPI_STATUS_SIZE)
57#define MPI_GROUP_TYPE INTEGER
58#define MPI_STATUS_EXTRACT(X) (X)
59#define MPI_GET_COMP
60#endif
61
62#if defined(__parallel)
63! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines (problems with types and ranks explosion),
64! we do not quite know what is in the module, so we can not include any....
65! to nevertheless get checking for what is included, we use the mpi module without use clause, getting all there is
66#if defined(__MPI_F08)
67 USE mpi_f08
68#else
69 USE mpi
70#endif
71#endif
72 IMPLICIT NONE
73 PRIVATE
74
75 ! parameters that might be needed
76#if defined(__parallel)
77 LOGICAL, PARAMETER :: cp2k_is_parallel = .true.
78 INTEGER, PARAMETER, PUBLIC :: mp_any_tag = mpi_any_tag
79 INTEGER, PARAMETER, PUBLIC :: mp_any_source = mpi_any_source
80 mpi_comm_type, PARAMETER :: mp_comm_null_handle = mpi_comm_null
81 mpi_comm_type, PARAMETER :: mp_comm_self_handle = mpi_comm_self
82 mpi_comm_type, PARAMETER :: mp_comm_world_handle = mpi_comm_world
83 mpi_request_type, PARAMETER :: mp_request_null_handle = mpi_request_null
84 mpi_win_type, PARAMETER :: mp_win_null_handle = mpi_win_null
85 mpi_file_type, PARAMETER :: mp_file_null_handle = mpi_file_null
86 mpi_info_type, PARAMETER :: mp_info_null_handle = mpi_info_null
87 mpi_data_type, PARAMETER :: mp_datatype_null_handle = mpi_datatype_null
88 INTEGER, PARAMETER, PUBLIC :: mp_status_size = mpi_status_size
89 INTEGER, PARAMETER, PUBLIC :: mp_proc_null = mpi_proc_null
90 ! Set max allocatable memory by MPI to 2 GiByte
91 INTEGER(KIND=MPI_ADDRESS_KIND), PARAMETER, PRIVATE :: mp_max_memory_size = huge(int(1, kind=int_4))
92
93 INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = mpi_max_library_version_string
94
95 INTEGER, PARAMETER, PUBLIC :: file_offset = mpi_offset_kind
96 INTEGER, PARAMETER, PUBLIC :: address_kind = mpi_address_kind
97 INTEGER, PARAMETER, PUBLIC :: file_amode_create = mpi_mode_create
98 INTEGER, PARAMETER, PUBLIC :: file_amode_rdonly = mpi_mode_rdonly
99 INTEGER, PARAMETER, PUBLIC :: file_amode_wronly = mpi_mode_wronly
100 INTEGER, PARAMETER, PUBLIC :: file_amode_rdwr = mpi_mode_rdwr
101 INTEGER, PARAMETER, PUBLIC :: file_amode_excl = mpi_mode_excl
102 INTEGER, PARAMETER, PUBLIC :: file_amode_append = mpi_mode_append
103#else
104 LOGICAL, PARAMETER :: cp2k_is_parallel = .false.
105 INTEGER, PARAMETER, PUBLIC :: mp_any_tag = -1
106 INTEGER, PARAMETER, PUBLIC :: mp_any_source = -2
107 mpi_comm_type, PARAMETER :: mp_comm_null_handle = -3
108 mpi_comm_type, PARAMETER :: mp_comm_self_handle = -11
109 mpi_comm_type, PARAMETER :: mp_comm_world_handle = -12
110 mpi_request_type, PARAMETER :: mp_request_null_handle = -4
111 mpi_win_type, PARAMETER :: mp_win_null_handle = -5
112 mpi_file_type, PARAMETER :: mp_file_null_handle = -6
113 mpi_info_type, PARAMETER :: mp_info_null_handle = -7
114 mpi_data_type, PARAMETER :: mp_datatype_null_handle = -8
115 INTEGER, PARAMETER, PUBLIC :: mp_status_size = -9
116 INTEGER, PARAMETER, PUBLIC :: mp_proc_null = -10
117 INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = 1
118
119 INTEGER, PARAMETER, PUBLIC :: file_offset = int_8
120 INTEGER, PARAMETER, PUBLIC :: address_kind = int_8
121 INTEGER, PARAMETER, PUBLIC :: file_amode_create = 1
122 INTEGER, PARAMETER, PUBLIC :: file_amode_rdonly = 2
123 INTEGER, PARAMETER, PUBLIC :: file_amode_wronly = 4
124 INTEGER, PARAMETER, PUBLIC :: file_amode_rdwr = 8
125 INTEGER, PARAMETER, PUBLIC :: file_amode_excl = 64
126 INTEGER, PARAMETER, PUBLIC :: file_amode_append = 128
127#endif
128
129 ! we need to fix this to a given number (crossing fingers)
130 ! so that the serial code using Fortran stream IO and the MPI have the same sizes.
131 INTEGER, PARAMETER, PUBLIC :: mpi_character_size = 1
132 INTEGER, PARAMETER, PUBLIC :: mpi_integer_size = 4
133
134 CHARACTER(LEN=*), PARAMETER, PRIVATE :: modulen = 'message_passing'
135
136 ! internal reference counter used to debug communicator leaks
137 INTEGER, PRIVATE, SAVE :: debug_comm_count
138
139 PUBLIC :: mp_comm_type
140 PUBLIC :: mp_request_type
141 PUBLIC :: mp_win_type
142 PUBLIC :: mp_file_type
143 PUBLIC :: mp_info_type
144 PUBLIC :: mp_cart_type
145
146 PUBLIC :: mp_para_env_type, mp_para_env_p_type, mp_para_cart_type
147 PUBLIC :: mp_para_env_create, mp_para_env_release, &
148 mp_para_cart_create, mp_para_cart_release
149
150#if defined(__MIMIC)
151 ! Stores the split world communicator to finalize a MiMiC run
152 mpi_comm_type, PRIVATE, SAVE :: mimic_comm_world
153#endif
154
155 TYPE mp_comm_type
156 PRIVATE
157 mpi_comm_type :: handle = mp_comm_null_handle
158 ! Number of dimensions within a Cartesian topology (useful with mp_cart_type)
159 INTEGER :: ndims = 1
160 ! Meta data to the communicator
161 INTEGER, PUBLIC :: mepos = -1, source = -1, num_pe = -1
162 CONTAINS
163 ! Setters/Getters
164 PROCEDURE, pass, non_overridable :: set_handle => mp_comm_type_set_handle
165 PROCEDURE, pass, non_overridable :: get_handle => mp_comm_type_get_handle
166 ! Comparisons
167 PROCEDURE, PRIVATE, pass, non_overridable :: mp_comm_op_eq
168 PROCEDURE, PRIVATE, pass, non_overridable :: mp_comm_op_neq
169 generic, PUBLIC :: operator(==) => mp_comm_op_eq
170 generic, PUBLIC :: operator(/=) => mp_comm_op_neq
171 ! Communication routines
172 PROCEDURE, PRIVATE, pass(comm), non_overridable :: &
173 mp_sendrecv_i, mp_sendrecv_l, mp_sendrecv_r, mp_sendrecv_d, &
174 mp_sendrecv_c, mp_sendrecv_z, &
175 mp_sendrecv_iv, mp_sendrecv_im2, mp_sendrecv_im3, mp_sendrecv_im4, &
176 mp_sendrecv_lv, mp_sendrecv_lm2, mp_sendrecv_lm3, mp_sendrecv_lm4, &
177 mp_sendrecv_rv, mp_sendrecv_rm2, mp_sendrecv_rm3, mp_sendrecv_rm4, &
178 mp_sendrecv_dv, mp_sendrecv_dm2, mp_sendrecv_dm3, mp_sendrecv_dm4, &
179 mp_sendrecv_cv, mp_sendrecv_cm2, mp_sendrecv_cm3, mp_sendrecv_cm4, &
180 mp_sendrecv_zv, mp_sendrecv_zm2, mp_sendrecv_zm3, mp_sendrecv_zm4
181 generic, PUBLIC :: sendrecv => mp_sendrecv_i, mp_sendrecv_l, &
182 mp_sendrecv_r, mp_sendrecv_d, mp_sendrecv_c, mp_sendrecv_z, &
183 mp_sendrecv_iv, mp_sendrecv_im2, mp_sendrecv_im3, mp_sendrecv_im4, &
184 mp_sendrecv_lv, mp_sendrecv_lm2, mp_sendrecv_lm3, mp_sendrecv_lm4, &
185 mp_sendrecv_rv, mp_sendrecv_rm2, mp_sendrecv_rm3, mp_sendrecv_rm4, &
186 mp_sendrecv_dv, mp_sendrecv_dm2, mp_sendrecv_dm3, mp_sendrecv_dm4, &
187 mp_sendrecv_cv, mp_sendrecv_cm2, mp_sendrecv_cm3, mp_sendrecv_cm4, &
188 mp_sendrecv_zv, mp_sendrecv_zm2, mp_sendrecv_zm3, mp_sendrecv_zm4
189
190 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_minloc_iv, &
191 mp_minloc_lv, mp_minloc_rv, mp_minloc_dv
192 generic, PUBLIC :: minloc => mp_minloc_iv, &
193 mp_minloc_lv, mp_minloc_rv, mp_minloc_dv
194
195 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_maxloc_iv, &
196 mp_maxloc_lv, mp_maxloc_rv, mp_maxloc_dv
197 generic, PUBLIC :: maxloc => mp_maxloc_iv, &
198 mp_maxloc_lv, mp_maxloc_rv, mp_maxloc_dv
199
200 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_shift_im, mp_shift_i, &
201 mp_shift_lm, mp_shift_l, mp_shift_rm, mp_shift_r, &
202 mp_shift_dm, mp_shift_d, mp_shift_cm, mp_shift_c, &
203 mp_shift_zm, mp_shift_z
204 generic, PUBLIC :: shift => mp_shift_im, mp_shift_i, &
205 mp_shift_lm, mp_shift_l, mp_shift_rm, mp_shift_r, &
206 mp_shift_dm, mp_shift_d, mp_shift_cm, mp_shift_c, &
207 mp_shift_zm, mp_shift_z
208
209 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_bcast_i, mp_bcast_iv, mp_bcast_im, mp_bcast_i3, &
210 mp_bcast_l, mp_bcast_lv, mp_bcast_lm, mp_bcast_l3, &
211 mp_bcast_r, mp_bcast_rv, mp_bcast_rm, mp_bcast_r3, &
212 mp_bcast_d, mp_bcast_dv, mp_bcast_dm, mp_bcast_d3, &
213 mp_bcast_c, mp_bcast_cv, mp_bcast_cm, mp_bcast_c3, &
214 mp_bcast_z, mp_bcast_zv, mp_bcast_zm, mp_bcast_z3, &
215 mp_bcast_b, mp_bcast_bv, mp_bcast_av, mp_bcast_am, &
216 mp_bcast_i_src, mp_bcast_iv_src, mp_bcast_im_src, mp_bcast_i3_src, &
217 mp_bcast_l_src, mp_bcast_lv_src, mp_bcast_lm_src, mp_bcast_l3_src, &
218 mp_bcast_r_src, mp_bcast_rv_src, mp_bcast_rm_src, mp_bcast_r3_src, &
219 mp_bcast_d_src, mp_bcast_dv_src, mp_bcast_dm_src, mp_bcast_d3_src, &
220 mp_bcast_c_src, mp_bcast_cv_src, mp_bcast_cm_src, mp_bcast_c3_src, &
221 mp_bcast_z_src, mp_bcast_zv_src, mp_bcast_zm_src, mp_bcast_z3_src, &
222 mp_bcast_b_src, mp_bcast_bv_src, mp_bcast_av_src, mp_bcast_am_src
223 generic, PUBLIC :: bcast => mp_bcast_i, mp_bcast_iv, mp_bcast_im, mp_bcast_i3, &
224 mp_bcast_l, mp_bcast_lv, mp_bcast_lm, mp_bcast_l3, &
225 mp_bcast_r, mp_bcast_rv, mp_bcast_rm, mp_bcast_r3, &
226 mp_bcast_d, mp_bcast_dv, mp_bcast_dm, mp_bcast_d3, &
227 mp_bcast_c, mp_bcast_cv, mp_bcast_cm, mp_bcast_c3, &
228 mp_bcast_z, mp_bcast_zv, mp_bcast_zm, mp_bcast_z3, &
229 mp_bcast_b, mp_bcast_bv, mp_bcast_av, mp_bcast_am, &
230 mp_bcast_i_src, mp_bcast_iv_src, mp_bcast_im_src, mp_bcast_i3_src, &
231 mp_bcast_l_src, mp_bcast_lv_src, mp_bcast_lm_src, mp_bcast_l3_src, &
232 mp_bcast_r_src, mp_bcast_rv_src, mp_bcast_rm_src, mp_bcast_r3_src, &
233 mp_bcast_d_src, mp_bcast_dv_src, mp_bcast_dm_src, mp_bcast_d3_src, &
234 mp_bcast_c_src, mp_bcast_cv_src, mp_bcast_cm_src, mp_bcast_c3_src, &
235 mp_bcast_z_src, mp_bcast_zv_src, mp_bcast_zm_src, mp_bcast_z3_src, &
236 mp_bcast_b_src, mp_bcast_bv_src, mp_bcast_av_src, mp_bcast_am_src
237
238 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_ibcast_i, mp_ibcast_iv, &
239 mp_ibcast_l, mp_ibcast_lv, mp_ibcast_r, mp_ibcast_rv, &
240 mp_ibcast_d, mp_ibcast_dv, mp_ibcast_c, mp_ibcast_cv, &
241 mp_ibcast_z, mp_ibcast_zv
242 generic, PUBLIC :: ibcast => mp_ibcast_i, mp_ibcast_iv, &
243 mp_ibcast_l, mp_ibcast_lv, mp_ibcast_r, mp_ibcast_rv, &
244 mp_ibcast_d, mp_ibcast_dv, mp_ibcast_c, mp_ibcast_cv, &
245 mp_ibcast_z, mp_ibcast_zv
246
247 PROCEDURE, PRIVATE, pass(comm), non_overridable :: &
248 mp_sum_i, mp_sum_iv, mp_sum_im, mp_sum_im3, mp_sum_im4, &
249 mp_sum_l, mp_sum_lv, mp_sum_lm, mp_sum_lm3, mp_sum_lm4, &
250 mp_sum_r, mp_sum_rv, mp_sum_rm, mp_sum_rm3, mp_sum_rm4, &
251 mp_sum_d, mp_sum_dv, mp_sum_dm, mp_sum_dm3, mp_sum_dm4, &
252 mp_sum_c, mp_sum_cv, mp_sum_cm, mp_sum_cm3, mp_sum_cm4, &
253 mp_sum_z, mp_sum_zv, mp_sum_zm, mp_sum_zm3, mp_sum_zm4, &
254 mp_sum_root_iv, mp_sum_root_im, mp_sum_root_lv, mp_sum_root_lm, &
255 mp_sum_root_rv, mp_sum_root_rm, mp_sum_root_dv, mp_sum_root_dm, &
256 mp_sum_root_cv, mp_sum_root_cm, mp_sum_root_zv, mp_sum_root_zm, &
257 mp_sum_b, mp_sum_bv
258 generic, PUBLIC :: sum => mp_sum_i, mp_sum_iv, mp_sum_im, mp_sum_im3, mp_sum_im4, &
259 mp_sum_l, mp_sum_lv, mp_sum_lm, mp_sum_lm3, mp_sum_lm4, &
260 mp_sum_r, mp_sum_rv, mp_sum_rm, mp_sum_rm3, mp_sum_rm4, &
261 mp_sum_d, mp_sum_dv, mp_sum_dm, mp_sum_dm3, mp_sum_dm4, &
262 mp_sum_c, mp_sum_cv, mp_sum_cm, mp_sum_cm3, mp_sum_cm4, &
263 mp_sum_z, mp_sum_zv, mp_sum_zm, mp_sum_zm3, mp_sum_zm4, &
264 mp_sum_root_iv, mp_sum_root_im, mp_sum_root_lv, mp_sum_root_lm, &
265 mp_sum_root_rv, mp_sum_root_rm, mp_sum_root_dv, mp_sum_root_dm, &
266 mp_sum_root_cv, mp_sum_root_cm, mp_sum_root_zv, mp_sum_root_zm, &
267 mp_sum_b, mp_sum_bv
268
269 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_isum_iv, &
270 mp_isum_lv, mp_isum_rv, mp_isum_dv, mp_isum_cv, &
271 mp_isum_zv, mp_isum_bv
272 generic, PUBLIC :: isum => mp_isum_iv, &
273 mp_isum_lv, mp_isum_rv, mp_isum_dv, mp_isum_cv, &
274 mp_isum_zv, mp_isum_bv
275
276 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_sum_partial_im, &
277 mp_sum_partial_lm, mp_sum_partial_rm, mp_sum_partial_dm, &
278 mp_sum_partial_cm, mp_sum_partial_zm
279 generic, PUBLIC :: sum_partial => mp_sum_partial_im, &
280 mp_sum_partial_lm, mp_sum_partial_rm, mp_sum_partial_dm, &
281 mp_sum_partial_cm, mp_sum_partial_zm
282
283 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_max_i, mp_max_iv, &
284 mp_max_im, &
285 mp_max_l, mp_max_lv, mp_max_lm, &
286 mp_max_r, mp_max_rv, mp_max_rm, &
287 mp_max_d, mp_max_dv, mp_max_dm, &
288 mp_max_c, mp_max_cv, mp_max_cm, &
289 mp_max_z, mp_max_zv, mp_max_zm, &
290 mp_max_root_i, mp_max_root_l, &
291 mp_max_root_r, mp_max_root_d, mp_max_root_c, mp_max_root_z, &
292 mp_max_root_im, mp_max_root_lm, mp_max_root_rm, mp_max_root_dm, &
293 mp_max_root_cm, mp_max_root_zm
294 generic, PUBLIC :: max => mp_max_i, mp_max_iv, &
295 mp_max_im, &
296 mp_max_l, mp_max_lv, mp_max_lm, &
297 mp_max_r, mp_max_rv, mp_max_rm, &
298 mp_max_d, mp_max_dv, mp_max_dm, &
299 mp_max_c, mp_max_cv, mp_max_cm, &
300 mp_max_z, mp_max_zv, mp_max_zm, &
301 mp_max_root_i, mp_max_root_l, &
302 mp_max_root_r, mp_max_root_d, mp_max_root_c, mp_max_root_z, &
303 mp_max_root_im, mp_max_root_lm, mp_max_root_rm, mp_max_root_dm, &
304 mp_max_root_cm, mp_max_root_zm
305
306 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_min_i, mp_min_iv, &
307 mp_min_im, &
308 mp_min_l, mp_min_lv, mp_min_lm, &
309 mp_min_r, mp_min_rv, mp_min_rm, &
310 mp_min_d, mp_min_dv, mp_min_dm, &
311 mp_min_c, mp_min_cv, mp_min_cm, &
312 mp_min_z, mp_min_zv, mp_min_zm
313 generic, PUBLIC :: min => mp_min_i, mp_min_iv, &
314 mp_min_im, &
315 mp_min_l, mp_min_lv, mp_min_lm, &
316 mp_min_r, mp_min_rv, mp_min_rm, &
317 mp_min_d, mp_min_dv, mp_min_dm, &
318 mp_min_c, mp_min_cv, mp_min_cm, &
319 mp_min_z, mp_min_zv, mp_min_zm
320
321 PROCEDURE, PUBLIC, pass(comm), non_overridable :: &
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 generic, PUBLIC :: sum_scatter => &
325 mp_sum_scatter_iv, mp_sum_scatter_lv, mp_sum_scatter_rv, &
326 mp_sum_scatter_dv, mp_sum_scatter_cv, mp_sum_scatter_zv
327
328 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
329 generic, PUBLIC :: prod => mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
330
331 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_gather_i, mp_gather_iv, mp_gather_im, &
332 mp_gather_l, mp_gather_lv, mp_gather_lm, &
333 mp_gather_r, mp_gather_rv, mp_gather_rm, &
334 mp_gather_d, mp_gather_dv, mp_gather_dm, &
335 mp_gather_c, mp_gather_cv, mp_gather_cm, &
336 mp_gather_z, mp_gather_zv, mp_gather_zm, &
337 mp_gather_i_src, mp_gather_iv_src, mp_gather_im_src, &
338 mp_gather_l_src, mp_gather_lv_src, mp_gather_lm_src, &
339 mp_gather_r_src, mp_gather_rv_src, mp_gather_rm_src, &
340 mp_gather_d_src, mp_gather_dv_src, mp_gather_dm_src, &
341 mp_gather_c_src, mp_gather_cv_src, mp_gather_cm_src, &
342 mp_gather_z_src, mp_gather_zv_src, mp_gather_zm_src
343 generic, PUBLIC :: gather => mp_gather_i, mp_gather_iv, mp_gather_im, &
344 mp_gather_l, mp_gather_lv, mp_gather_lm, &
345 mp_gather_r, mp_gather_rv, mp_gather_rm, &
346 mp_gather_d, mp_gather_dv, mp_gather_dm, &
347 mp_gather_c, mp_gather_cv, mp_gather_cm, &
348 mp_gather_z, mp_gather_zv, mp_gather_zm, &
349 mp_gather_i_src, mp_gather_iv_src, mp_gather_im_src, &
350 mp_gather_l_src, mp_gather_lv_src, mp_gather_lm_src, &
351 mp_gather_r_src, mp_gather_rv_src, mp_gather_rm_src, &
352 mp_gather_d_src, mp_gather_dv_src, mp_gather_dm_src, &
353 mp_gather_c_src, mp_gather_cv_src, mp_gather_cm_src, &
354 mp_gather_z_src, mp_gather_zv_src, mp_gather_zm_src
355
356 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_gatherv_iv, &
357 mp_gatherv_lv, mp_gatherv_rv, mp_gatherv_dv, &
358 mp_gatherv_cv, mp_gatherv_zv, mp_gatherv_lm2, mp_gatherv_rm2, &
359 mp_gatherv_dm2, mp_gatherv_cm2, mp_gatherv_zm2, mp_gatherv_iv_src, &
360 mp_gatherv_lv_src, mp_gatherv_rv_src, mp_gatherv_dv_src, &
361 mp_gatherv_cv_src, mp_gatherv_zv_src, mp_gatherv_lm2_src, mp_gatherv_rm2_src, &
362 mp_gatherv_dm2_src, mp_gatherv_cm2_src, mp_gatherv_zm2_src
363 generic, PUBLIC :: gatherv => mp_gatherv_iv, &
364 mp_gatherv_lv, mp_gatherv_rv, mp_gatherv_dv, &
365 mp_gatherv_cv, mp_gatherv_zv, mp_gatherv_lm2, mp_gatherv_rm2, &
366 mp_gatherv_dm2, mp_gatherv_cm2, mp_gatherv_zm2, mp_gatherv_iv_src, &
367 mp_gatherv_lv_src, mp_gatherv_rv_src, mp_gatherv_dv_src, &
368 mp_gatherv_cv_src, mp_gatherv_zv_src, mp_gatherv_lm2_src, mp_gatherv_rm2_src, &
369 mp_gatherv_dm2_src, mp_gatherv_cm2_src, mp_gatherv_zm2_src
370
371 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_igatherv_iv, &
372 mp_igatherv_lv, mp_igatherv_rv, mp_igatherv_dv, &
373 mp_igatherv_cv, mp_igatherv_zv
374 generic, PUBLIC :: igatherv => mp_igatherv_iv, &
375 mp_igatherv_lv, mp_igatherv_rv, mp_igatherv_dv, &
376 mp_igatherv_cv, mp_igatherv_zv
377
378 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_allgather_i, mp_allgather_i2, &
379 mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
380 mp_allgather_i22, mp_allgather_l, mp_allgather_l2, &
381 mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
382 mp_allgather_l22, mp_allgather_r, mp_allgather_r2, &
383 mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
384 mp_allgather_r22, mp_allgather_d, mp_allgather_d2, &
385 mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
386 mp_allgather_d22, mp_allgather_c, mp_allgather_c2, &
387 mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
388 mp_allgather_c22, mp_allgather_z, mp_allgather_z2, &
389 mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
390 mp_allgather_z22
391 generic, PUBLIC :: allgather => mp_allgather_i, mp_allgather_i2, &
392 mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
393 mp_allgather_i22, mp_allgather_l, mp_allgather_l2, &
394 mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
395 mp_allgather_l22, mp_allgather_r, mp_allgather_r2, &
396 mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
397 mp_allgather_r22, mp_allgather_d, mp_allgather_d2, &
398 mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
399 mp_allgather_d22, mp_allgather_c, mp_allgather_c2, &
400 mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
401 mp_allgather_c22, mp_allgather_z, mp_allgather_z2, &
402 mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
403 mp_allgather_z22
404
405 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_allgatherv_iv, mp_allgatherv_lv, &
406 mp_allgatherv_rv, mp_allgatherv_dv, mp_allgatherv_cv, mp_allgatherv_zv, &
407 mp_allgatherv_im2, mp_allgatherv_lm2, mp_allgatherv_rm2, &
408 mp_allgatherv_dm2, mp_allgatherv_cm2, mp_allgatherv_zm2
409 generic, PUBLIC :: allgatherv => mp_allgatherv_iv, mp_allgatherv_lv, &
410 mp_allgatherv_rv, mp_allgatherv_dv, mp_allgatherv_cv, mp_allgatherv_zv, &
411 mp_allgatherv_im2, mp_allgatherv_lm2, mp_allgatherv_rm2, &
412 mp_allgatherv_dm2, mp_allgatherv_cm2, mp_allgatherv_zm2
413
414 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iallgather_i, mp_iallgather_l, &
415 mp_iallgather_r, mp_iallgather_d, mp_iallgather_c, mp_iallgather_z, &
416 mp_iallgather_i11, mp_iallgather_l11, mp_iallgather_r11, mp_iallgather_d11, &
417 mp_iallgather_c11, mp_iallgather_z11, mp_iallgather_i13, mp_iallgather_l13, &
418 mp_iallgather_r13, mp_iallgather_d13, mp_iallgather_c13, mp_iallgather_z13, &
419 mp_iallgather_i22, mp_iallgather_l22, mp_iallgather_r22, mp_iallgather_d22, &
420 mp_iallgather_c22, mp_iallgather_z22, mp_iallgather_i24, mp_iallgather_l24, &
421 mp_iallgather_r24, mp_iallgather_d24, mp_iallgather_c24, mp_iallgather_z24, &
422 mp_iallgather_i33, mp_iallgather_l33, mp_iallgather_r33, mp_iallgather_d33, &
423 mp_iallgather_c33, mp_iallgather_z33
424 generic, PUBLIC :: iallgather => mp_iallgather_i, mp_iallgather_l, &
425 mp_iallgather_r, mp_iallgather_d, mp_iallgather_c, mp_iallgather_z, &
426 mp_iallgather_i11, mp_iallgather_l11, mp_iallgather_r11, mp_iallgather_d11, &
427 mp_iallgather_c11, mp_iallgather_z11, mp_iallgather_i13, mp_iallgather_l13, &
428 mp_iallgather_r13, mp_iallgather_d13, mp_iallgather_c13, mp_iallgather_z13, &
429 mp_iallgather_i22, mp_iallgather_l22, mp_iallgather_r22, mp_iallgather_d22, &
430 mp_iallgather_c22, mp_iallgather_z22, mp_iallgather_i24, mp_iallgather_l24, &
431 mp_iallgather_r24, mp_iallgather_d24, mp_iallgather_c24, mp_iallgather_z24, &
432 mp_iallgather_i33, mp_iallgather_l33, mp_iallgather_r33, mp_iallgather_d33, &
433 mp_iallgather_c33, mp_iallgather_z33
434
435 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iallgatherv_iv, mp_iallgatherv_iv2, &
436 mp_iallgatherv_lv, mp_iallgatherv_lv2, mp_iallgatherv_rv, mp_iallgatherv_rv2, &
437 mp_iallgatherv_dv, mp_iallgatherv_dv2, mp_iallgatherv_cv, mp_iallgatherv_cv2, &
438 mp_iallgatherv_zv, mp_iallgatherv_zv2
439 generic, PUBLIC :: iallgatherv => mp_iallgatherv_iv, mp_iallgatherv_iv2, &
440 mp_iallgatherv_lv, mp_iallgatherv_lv2, mp_iallgatherv_rv, mp_iallgatherv_rv2, &
441 mp_iallgatherv_dv, mp_iallgatherv_dv2, mp_iallgatherv_cv, mp_iallgatherv_cv2, &
442 mp_iallgatherv_zv, mp_iallgatherv_zv2
443
444 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_scatter_iv, mp_scatter_lv, &
445 mp_scatter_rv, mp_scatter_dv, mp_scatter_cv, mp_scatter_zv
446 generic, PUBLIC :: scatter => mp_scatter_iv, mp_scatter_lv, &
447 mp_scatter_rv, mp_scatter_dv, mp_scatter_cv, mp_scatter_zv
448
449 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iscatter_i, mp_iscatter_l, &
450 mp_iscatter_r, mp_iscatter_d, mp_iscatter_c, mp_iscatter_z, &
451 mp_iscatter_iv2, mp_iscatter_lv2, mp_iscatter_rv2, mp_iscatter_dv2, &
452 mp_iscatter_cv2, mp_iscatter_zv2
453 generic, PUBLIC :: iscatter => mp_iscatter_i, mp_iscatter_l, &
454 mp_iscatter_r, mp_iscatter_d, mp_iscatter_c, mp_iscatter_z, &
455 mp_iscatter_iv2, mp_iscatter_lv2, mp_iscatter_rv2, mp_iscatter_dv2, &
456 mp_iscatter_cv2, mp_iscatter_zv2
457
458 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iscatterv_iv, mp_iscatterv_lv, &
459 mp_iscatterv_rv, mp_iscatterv_dv, mp_iscatterv_cv, mp_iscatterv_zv
460 generic, PUBLIC :: iscatterv => mp_iscatterv_iv, mp_iscatterv_lv, &
461 mp_iscatterv_rv, mp_iscatterv_dv, mp_iscatterv_cv, mp_iscatterv_zv
462
463 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
464 mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
465 mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
466 mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
467 mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
468 mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
469 mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
470 mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
471 mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
472 mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
473 mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
474 mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
475 mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
476 mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
477 mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
478 mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
479 mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
480 mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
481 generic, PUBLIC :: alltoall => mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
482 mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
483 mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
484 mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
485 mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
486 mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
487 mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
488 mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
489 mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
490 mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
491 mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
492 mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
493 mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
494 mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
495 mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
496 mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
497 mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
498 mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
499
500 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
501 mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
502 mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
503 mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
504 mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
505 mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
506 generic, PUBLIC :: send => mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
507 mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
508 mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
509 mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
510 mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
511 mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
512
513 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
514 mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
515 mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
516 mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
517 mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
518 mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
519 generic, PUBLIC :: recv => mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
520 mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
521 mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
522 mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
523 mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
524 mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
525
526 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_isendrecv_i, mp_isendrecv_iv, &
527 mp_isendrecv_l, mp_isendrecv_lv, mp_isendrecv_r, mp_isendrecv_rv, &
528 mp_isendrecv_d, mp_isendrecv_dv, mp_isendrecv_c, mp_isendrecv_cv, &
529 mp_isendrecv_z, mp_isendrecv_zv
530 generic, PUBLIC :: isendrecv => mp_isendrecv_i, mp_isendrecv_iv, &
531 mp_isendrecv_l, mp_isendrecv_lv, mp_isendrecv_r, mp_isendrecv_rv, &
532 mp_isendrecv_d, mp_isendrecv_dv, mp_isendrecv_c, mp_isendrecv_cv, &
533 mp_isendrecv_z, mp_isendrecv_zv
534
535 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
536 mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
537 mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
538 mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
539 mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
540 mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4, &
541 mp_isend_bv, mp_isend_bm3, mp_isend_custom
542 generic, PUBLIC :: isend => mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
543 mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
544 mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
545 mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
546 mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
547 mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4, &
548 mp_isend_bv, mp_isend_bm3, mp_isend_custom
549
550 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
551 mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
552 mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
553 mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
554 mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
555 mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4, &
556 mp_irecv_bv, mp_irecv_bm3, mp_irecv_custom
557 generic, PUBLIC :: irecv => mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
558 mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
559 mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
560 mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
561 mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
562 mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4, &
563 mp_irecv_bv, mp_irecv_bm3, mp_irecv_custom
564
565 PROCEDURE, PUBLIC, pass(comm), non_overridable :: probe => mp_probe
566
567 PROCEDURE, PUBLIC, pass(comm), non_overridable :: sync => mp_sync
568 PROCEDURE, PUBLIC, pass(comm), non_overridable :: isync => mp_isync
569
570 PROCEDURE, PUBLIC, pass(comm1), non_overridable :: compare => mp_comm_compare
571 PROCEDURE, PUBLIC, pass(comm1), non_overridable :: rank_compare => mp_rank_compare
572
573 PROCEDURE, PUBLIC, pass(comm2), non_overridable :: from_dup => mp_comm_dup
574 PROCEDURE, PUBLIC, pass(comm), non_overridable :: mp_comm_free
575 generic, PUBLIC :: free => mp_comm_free
576
577 PROCEDURE, PUBLIC, pass(comm), non_overridable :: mp_comm_init
578 generic, PUBLIC :: init => mp_comm_init
579
580 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_size => mp_comm_size
581 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_rank => mp_comm_rank
582 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_ndims => mp_comm_get_ndims
583 PROCEDURE, PUBLIC, pass(comm), non_overridable :: is_source => mp_comm_is_source
584
585 ! Creation routines
586 PROCEDURE, PRIVATE, pass(sub_comm), non_overridable :: mp_comm_split, mp_comm_split_direct
587 generic, PUBLIC :: from_split => mp_comm_split, mp_comm_split_direct
588 PROCEDURE, PUBLIC, pass(mp_new_comm), non_overridable :: from_reordering => mp_reordering
589 PROCEDURE, PUBLIC, pass(comm_new), non_overridable :: mp_comm_assign
590 generic, PUBLIC :: ASSIGNMENT(=) => mp_comm_assign
591
592 ! Other Getters
593 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_tag_ub
594 generic, PUBLIC :: get_tag_ub => mp_comm_get_tag_ub
595 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_host_rank
596 generic, PUBLIC :: get_host_rank => mp_comm_get_host_rank
597 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_io_rank
598 generic, PUBLIC :: get_io_rank => mp_comm_get_io_rank
599 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_wtime_is_global
600 generic, PUBLIC :: get_wtime_is_global => mp_comm_get_wtime_is_global
601 END TYPE
602
603 TYPE mp_request_type
604 PRIVATE
605 mpi_request_type :: handle = mp_request_null_handle
606 CONTAINS
607 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_request_type_set_handle
608 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_request_type_get_handle
609 PROCEDURE, PRIVATE, non_overridable :: mp_request_op_eq
610 PROCEDURE, PRIVATE, non_overridable :: mp_request_op_neq
611 generic, PUBLIC :: OPERATOR(==) => mp_request_op_eq
612 generic, PUBLIC :: OPERATOR(/=) => mp_request_op_neq
613
614 PROCEDURE, PUBLIC, pass(request), non_overridable :: test => mp_test_1
615
616 PROCEDURE, PUBLIC, pass(request), non_overridable :: wait => mp_wait
617 END TYPE
618
619 TYPE mp_win_type
620 PRIVATE
621 mpi_win_type :: handle = mp_win_null_handle
622 CONTAINS
623 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_win_type_set_handle
624 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_win_type_get_handle
625 PROCEDURE, PRIVATE, non_overridable :: mp_win_op_eq
626 PROCEDURE, PRIVATE, non_overridable :: mp_win_op_neq
627 generic, PUBLIC :: OPERATOR(==) => mp_win_op_eq
628 generic, PUBLIC :: OPERATOR(/=) => mp_win_op_neq
629
630 PROCEDURE, PRIVATE, pass(win), non_overridable :: mp_win_create_iv, mp_win_create_lv, &
631 mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv
632 generic, PUBLIC :: create => mp_win_create_iv, mp_win_create_lv, &
633 mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv
634
635 PROCEDURE, PRIVATE, pass(win), non_overridable :: mp_rget_iv, mp_rget_lv, &
636 mp_rget_rv, mp_rget_dv, mp_rget_cv, mp_rget_zv
637 generic, PUBLIC :: rget => mp_rget_iv, mp_rget_lv, &
638 mp_rget_rv, mp_rget_dv, mp_rget_cv, mp_rget_zv
639
640 PROCEDURE, PUBLIC, pass(win), non_overridable :: free => mp_win_free
641 PROCEDURE, PUBLIC, pass(win_new), non_overridable :: mp_win_assign
642 generic, PUBLIC :: ASSIGNMENT(=) => mp_win_assign
643
644 PROCEDURE, PUBLIC, pass(win), non_overridable :: lock_all => mp_win_lock_all
645 PROCEDURE, PUBLIC, pass(win), non_overridable :: unlock_all => mp_win_unlock_all
646 PROCEDURE, PUBLIC, pass(win), non_overridable :: flush_all => mp_win_flush_all
647 END TYPE
648
649 TYPE mp_file_type
650 PRIVATE
651 mpi_file_type :: handle = mp_file_null_handle
652 CONTAINS
653 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_file_type_set_handle
654 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_file_type_get_handle
655 PROCEDURE, PRIVATE, non_overridable :: mp_file_op_eq
656 PROCEDURE, PRIVATE, non_overridable :: mp_file_op_neq
657 generic, PUBLIC :: OPERATOR(==) => mp_file_op_eq
658 generic, PUBLIC :: OPERATOR(/=) => mp_file_op_neq
659
660 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_write_at_ch, mp_file_write_at_chv, &
661 mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, &
662 mp_file_write_at_d, mp_file_write_at_dv, mp_file_write_at_c, mp_file_write_at_cv, &
663 mp_file_write_at_z, mp_file_write_at_zv, mp_file_write_at_l, mp_file_write_at_lv
664 generic, PUBLIC :: write_at => mp_file_write_at_ch, mp_file_write_at_chv, &
665 mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, &
666 mp_file_write_at_d, mp_file_write_at_dv, mp_file_write_at_c, mp_file_write_at_cv, &
667 mp_file_write_at_z, mp_file_write_at_zv, mp_file_write_at_l, mp_file_write_at_lv
668
669 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
670 mp_file_write_at_all_i, mp_file_write_at_all_iv, mp_file_write_at_all_l, mp_file_write_at_all_lv, &
671 mp_file_write_at_all_r, mp_file_write_at_all_rv, mp_file_write_at_all_d, mp_file_write_at_all_dv, &
672 mp_file_write_at_all_c, mp_file_write_at_all_cv, mp_file_write_at_all_z, mp_file_write_at_all_zv
673 generic, PUBLIC :: write_at_all => mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
674 mp_file_write_at_all_i, mp_file_write_at_all_iv, mp_file_write_at_all_l, mp_file_write_at_all_lv, &
675 mp_file_write_at_all_r, mp_file_write_at_all_rv, mp_file_write_at_all_d, mp_file_write_at_all_dv, &
676 mp_file_write_at_all_c, mp_file_write_at_all_cv, mp_file_write_at_all_z, mp_file_write_at_all_zv
677
678 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_read_at_ch, mp_file_read_at_chv, &
679 mp_file_read_at_i, mp_file_read_at_iv, mp_file_read_at_r, mp_file_read_at_rv, &
680 mp_file_read_at_d, mp_file_read_at_dv, mp_file_read_at_c, mp_file_read_at_cv, &
681 mp_file_read_at_z, mp_file_read_at_zv, mp_file_read_at_l, mp_file_read_at_lv
682 generic, PUBLIC :: read_at => mp_file_read_at_ch, mp_file_read_at_chv, &
683 mp_file_read_at_i, mp_file_read_at_iv, mp_file_read_at_r, mp_file_read_at_rv, &
684 mp_file_read_at_d, mp_file_read_at_dv, mp_file_read_at_c, mp_file_read_at_cv, &
685 mp_file_read_at_z, mp_file_read_at_zv, mp_file_read_at_l, mp_file_read_at_lv
686
687 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
688 mp_file_read_at_all_i, mp_file_read_at_all_iv, mp_file_read_at_all_l, mp_file_read_at_all_lv, &
689 mp_file_read_at_all_r, mp_file_read_at_all_rv, mp_file_read_at_all_d, mp_file_read_at_all_dv, &
690 mp_file_read_at_all_c, mp_file_read_at_all_cv, mp_file_read_at_all_z, mp_file_read_at_all_zv
691 generic, PUBLIC :: read_at_all => mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
692 mp_file_read_at_all_i, mp_file_read_at_all_iv, mp_file_read_at_all_l, mp_file_read_at_all_lv, &
693 mp_file_read_at_all_r, mp_file_read_at_all_rv, mp_file_read_at_all_d, mp_file_read_at_all_dv, &
694 mp_file_read_at_all_c, mp_file_read_at_all_cv, mp_file_read_at_all_z, mp_file_read_at_all_zv
695
696 PROCEDURE, PUBLIC, pass(fh), non_overridable :: open => mp_file_open
697 PROCEDURE, PUBLIC, pass(fh), non_overridable :: close => mp_file_close
698 PROCEDURE, PRIVATE, pass(fh_new), non_overridable :: mp_file_assign
699 generic, PUBLIC :: ASSIGNMENT(=) => mp_file_assign
700
701 PROCEDURE, PUBLIC, pass(fh), non_overridable :: get_size => mp_file_get_size
702 PROCEDURE, PUBLIC, pass(fh), non_overridable :: get_position => mp_file_get_position
703
704 PROCEDURE, PUBLIC, pass(fh), non_overridable :: read_all => mp_file_read_all_chv
705 PROCEDURE, PUBLIC, pass(fh), non_overridable :: write_all => mp_file_write_all_chv
706 END TYPE
707
708 TYPE mp_info_type
709 PRIVATE
710 mpi_info_type :: handle = mp_info_null_handle
711 CONTAINS
712 PROCEDURE, NON_OVERRIDABLE :: set_handle => mp_info_type_set_handle
713 PROCEDURE, non_overridable :: get_handle => mp_info_type_get_handle
714 PROCEDURE, PRIVATE, non_overridable :: mp_info_op_eq
715 PROCEDURE, PRIVATE, non_overridable :: mp_info_op_neq
716 generic, PUBLIC :: OPERATOR(==) => mp_info_op_eq
717 generic, PUBLIC :: OPERATOR(/=) => mp_info_op_neq
718 END TYPE
719
720 TYPE, EXTENDS(mp_comm_type) :: mp_cart_type
721 INTEGER, DIMENSION(:), ALLOCATABLE, PUBLIC :: mepos_cart, num_pe_cart
722 LOGICAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: periodic
723 CONTAINS
724 PROCEDURE, PUBLIC, pass(comm_cart), non_overridable :: create => mp_cart_create
725 PROCEDURE, PUBLIC, pass(sub_comm), non_overridable :: from_sub => mp_cart_sub
726
727 PROCEDURE, PRIVATE, pass(comm), non_overridable :: get_info_cart => mp_cart_get
728
729 PROCEDURE, PUBLIC, pass(comm), non_overridable :: coords => mp_cart_coords
730 PROCEDURE, PUBLIC, pass(comm), non_overridable :: rank_cart => mp_cart_rank
731 END TYPE
732
733! **************************************************************************************************
734!> \brief stores all the informations relevant to an mpi environment
735!> \param owns_group if it owns the group (and thus should free it when
736!> this object is deallocated)
737!> \param ref_count the reference count, when it is zero this object gets
738!> deallocated
739!> \par History
740!> 08.2002 created [fawzi]
741!> \author Fawzi Mohamed
742! **************************************************************************************************
743 TYPE, EXTENDS(mp_comm_type) :: mp_para_env_type
744 PRIVATE
745 ! We set it to true to have less initialization steps in case we create a new communicator
746 LOGICAL :: owns_group = .true.
747 INTEGER :: ref_count = -1
748 CONTAINS
749 PROCEDURE, PUBLIC, pass(para_env), non_overridable :: retain => mp_para_env_retain
750 PROCEDURE, PUBLIC, pass(para_env), non_overridable :: is_valid => mp_para_env_is_valid
751 END TYPE mp_para_env_type
752
753! **************************************************************************************************
754!> \brief represent a pointer to a para env (to build arrays)
755!> \param para_env the pointer to the para_env
756!> \par History
757!> 07.2003 created [fawzi]
758!> \author Fawzi Mohamed
759! **************************************************************************************************
760 TYPE mp_para_env_p_type
761 TYPE(mp_para_env_type), POINTER :: para_env => null()
762 END TYPE mp_para_env_p_type
763
764! **************************************************************************************************
765!> \brief represent a multidimensional parallel environment
766!> \param mepos_cart the position of the actual processor
767!> \param num_pe_cart number of processors in the group in each dimension
768!> \param source_cart id of a special processor (for example the one for i-o,
769!> or the master
770!> \param owns_group if it owns the group (and thus should free it when
771!> this object is deallocated)
772!> \param ref_count the reference count, when it is zero this object gets
773!> deallocated
774!> \note
775!> not yet implemented for mpi
776!> \par History
777!> 08.2002 created [fawzi]
778!> \author Fawzi Mohamed
779! **************************************************************************************************
780 TYPE, EXTENDS(mp_cart_type) :: mp_para_cart_type
781 PRIVATE
782 ! We set it to true to have less initialization steps in case we create a new communicator
783 LOGICAL :: owns_group = .true.
784 INTEGER :: ref_count = -1
785 CONTAINS
786 PROCEDURE, PUBLIC, pass(cart), non_overridable :: retain => mp_para_cart_retain
787 PROCEDURE, PUBLIC, pass(cart), non_overridable :: is_valid => mp_para_cart_is_valid
788 END TYPE mp_para_cart_type
789
790 ! Create the constants from the corresponding handles
791 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_null = mp_comm_type(mp_comm_null_handle)
792 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_self = mp_comm_type(mp_comm_self_handle)
793 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_world = mp_comm_type(mp_comm_world_handle)
794 TYPE(mp_request_type), PARAMETER, PUBLIC :: mp_request_null = mp_request_type(mp_request_null_handle)
795 TYPE(mp_win_type), PARAMETER, PUBLIC :: mp_win_null = mp_win_type(mp_win_null_handle)
796 TYPE(mp_file_type), PARAMETER, PUBLIC :: mp_file_null = mp_file_type(mp_file_null_handle)
797 TYPE(mp_info_type), PARAMETER, PUBLIC :: mp_info_null = mp_info_type(mp_info_null_handle)
798
799#if !defined(__parallel)
800 ! This communicator is to be used in serial mode to emulate a valid communicator which is not a compiler constant
801 INTEGER, PARAMETER, PRIVATE :: mp_comm_default_handle = 1
802 TYPE(mp_comm_type), PARAMETER, PRIVATE :: mp_comm_default = mp_comm_type(mp_comm_default_handle)
803#endif
804
805 ! Constants to compare communicators
806 INTEGER, PARAMETER, PUBLIC :: mp_comm_ident = 0
807 INTEGER, PARAMETER, PUBLIC :: mp_comm_congruent = 1
808 INTEGER, PARAMETER, PUBLIC :: mp_comm_similar = 2
809 INTEGER, PARAMETER, PUBLIC :: mp_comm_unequal = 3
810 INTEGER, PARAMETER, PUBLIC :: mp_comm_compare_default = -1
811
812 ! init and error
813 PUBLIC :: mp_world_init, mp_world_finalize
814 PUBLIC :: mp_abort
815
816 ! informational / generation of sub comms
817 PUBLIC :: mp_dims_create
818 PUBLIC :: cp2k_is_parallel
819
820 ! message passing
821 PUBLIC :: mp_waitall, mp_waitany
822 PUBLIC :: mp_testall, mp_testany
823
824 ! Memory management
825 PUBLIC :: mp_allocate, mp_deallocate
826
827 ! I/O
828 PUBLIC :: mp_file_delete
829 PUBLIC :: mp_file_get_amode
830
831 ! some 'advanced types' currently only used for dbcsr
832 PUBLIC :: mp_type_descriptor_type
833 PUBLIC :: mp_type_make
834 PUBLIC :: mp_type_size
835
836 ! vector types
837 PUBLIC :: mp_type_indexed_make_r, mp_type_indexed_make_d, &
838 mp_type_indexed_make_c, mp_type_indexed_make_z
839
840 ! More I/O types and routines: variable spaced data using bytes for spacings
841 PUBLIC :: mp_file_descriptor_type
842 PUBLIC :: mp_file_type_free
843 PUBLIC :: mp_file_type_hindexed_make_chv
844 PUBLIC :: mp_file_type_set_view_chv
845
846 PUBLIC :: mp_get_library_version
847
848 ! assumed to be private
849
850 INTERFACE mp_waitall
851 MODULE PROCEDURE mp_waitall_1, mp_waitall_2
852 END INTERFACE
853
854 INTERFACE mp_testall
855 MODULE PROCEDURE mp_testall_tv
856 END INTERFACE
857
858 INTERFACE mp_testany
859 MODULE PROCEDURE mp_testany_1, mp_testany_2
860 END INTERFACE
861
862 INTERFACE mp_type_free
863 MODULE PROCEDURE mp_type_free_m, mp_type_free_v
864 END INTERFACE
865
866 !
867 ! interfaces to deal easily with scalars / vectors / matrices / ...
868 ! of the different types (integers, doubles, logicals, characters)
869 !
870 INTERFACE mp_allocate
871 MODULE PROCEDURE mp_allocate_i, &
872 mp_allocate_l, &
873 mp_allocate_r, &
874 mp_allocate_d, &
875 mp_allocate_c, &
876 mp_allocate_z
877 END INTERFACE
878
879 INTERFACE mp_deallocate
880 MODULE PROCEDURE mp_deallocate_i, &
881 mp_deallocate_l, &
882 mp_deallocate_r, &
883 mp_deallocate_d, &
884 mp_deallocate_c, &
885 mp_deallocate_z
886 END INTERFACE
887
888 INTERFACE mp_type_make
889 MODULE PROCEDURE mp_type_make_struct
890 MODULE PROCEDURE mp_type_make_i, mp_type_make_l, &
891 mp_type_make_r, mp_type_make_d, &
892 mp_type_make_c, mp_type_make_z
893 END INTERFACE
894
895 INTERFACE mp_alloc_mem
896 MODULE PROCEDURE mp_alloc_mem_i, mp_alloc_mem_l, &
897 mp_alloc_mem_d, mp_alloc_mem_z, &
898 mp_alloc_mem_r, mp_alloc_mem_c
899 END INTERFACE
900
901 INTERFACE mp_free_mem
902 MODULE PROCEDURE mp_free_mem_i, mp_free_mem_l, &
903 mp_free_mem_d, mp_free_mem_z, &
904 mp_free_mem_r, mp_free_mem_c
905 END INTERFACE
906
907! Type declarations
908 TYPE mp_indexing_meta_type
909 INTEGER, DIMENSION(:), POINTER :: index => null(), chunks => null()
910 END TYPE mp_indexing_meta_type
911
912 TYPE mp_type_descriptor_type
913 mpi_data_type :: type_handle = mp_datatype_null_handle
914 INTEGER :: length = -1
915#if defined(__parallel)
916 INTEGER(kind=mpi_address_kind) :: base = -1
917#endif
918 INTEGER(kind=int_4), DIMENSION(:), POINTER :: data_i => null()
919 INTEGER(kind=int_8), DIMENSION(:), POINTER :: data_l => null()
920 REAL(kind=real_4), DIMENSION(:), POINTER :: data_r => null()
921 REAL(kind=real_8), DIMENSION(:), POINTER :: data_d => null()
922 COMPLEX(kind=real_4), DIMENSION(:), POINTER :: data_c => null()
923 COMPLEX(kind=real_8), DIMENSION(:), POINTER :: data_z => null()
924 TYPE(mp_type_descriptor_type), DIMENSION(:), POINTER :: subtype => null()
925 INTEGER :: vector_descriptor(2) = -1
926 LOGICAL :: has_indexing = .false.
927 TYPE(mp_indexing_meta_type) :: index_descriptor = mp_indexing_meta_type()
928 END TYPE mp_type_descriptor_type
929
930 TYPE mp_file_indexing_meta_type
931 INTEGER, DIMENSION(:), POINTER :: index => null()
932 INTEGER(kind=file_offset), &
933 DIMENSION(:), POINTER :: chunks => null()
934 END TYPE mp_file_indexing_meta_type
935
936 TYPE mp_file_descriptor_type
937 mpi_data_type :: type_handle = mp_datatype_null_handle
938 INTEGER :: length = -1
939 LOGICAL :: has_indexing = .false.
940 TYPE(mp_file_indexing_meta_type) :: index_descriptor = mp_file_indexing_meta_type()
941 END TYPE
942
943 ! we make some assumptions on the length of INTEGERS, REALS and LOGICALS
944 INTEGER, PARAMETER :: intlen = bit_size(0)/8
945 INTEGER, PARAMETER :: reallen = 8
946 INTEGER, PARAMETER :: loglen = bit_size(0)/8
947 INTEGER, PARAMETER :: charlen = 1
948
949 LOGICAL, PUBLIC, SAVE :: mp_collect_timings = .false.
950
951CONTAINS
952
953 LOGICAL FUNCTION mp_comm_op_eq(comm1, comm2)
954 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
955#if defined(__parallel) && defined(__MPI_F08)
956 mp_comm_op_eq = (comm1%handle%mpi_val == comm2%handle%mpi_val)
957#else
958 mp_comm_op_eq = (comm1%handle == comm2%handle)
959#endif
960 END FUNCTION mp_comm_op_eq
961
962 LOGICAL FUNCTION mp_comm_op_neq(comm1, comm2)
963 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
964#if defined(__parallel) && defined(__MPI_F08)
965 mp_comm_op_neq = (comm1%handle%mpi_val /= comm2%handle%mpi_val)
966#else
967 mp_comm_op_neq = (comm1%handle /= comm2%handle)
968#endif
969 END FUNCTION mp_comm_op_neq
970
971 ELEMENTAL IMPURE SUBROUTINE mp_comm_type_set_handle(this, handle , ndims)
972 CLASS(mp_comm_type), INTENT(INOUT) :: this
973 INTEGER, INTENT(IN) :: handle
974 INTEGER, INTENT(IN), OPTIONAL :: ndims
975
976#if defined(__parallel) && defined(__MPI_F08)
977 this%handle%mpi_val = handle
978#else
979 this%handle = handle
980#endif
981
982 SELECT TYPE (this)
983 CLASS IS (mp_cart_type)
984 IF (.NOT. PRESENT(ndims)) &
985 CALL cp_abort(__location__, &
986 "Setup of a cartesian communicator requires information on the number of dimensions!")
987 END SELECT
988 IF (PRESENT(ndims)) this%ndims = ndims
989 CALL this%init()
990
991 END SUBROUTINE mp_comm_type_set_handle
992
993 ELEMENTAL FUNCTION mp_comm_type_get_handle(this) RESULT(handle)
994 CLASS(mp_comm_type), INTENT(IN) :: this
995 INTEGER :: handle
996
997#if defined(__parallel) && defined(__MPI_F08)
998 handle = this%handle%mpi_val
999#else
1000 handle = this%handle
1001#endif
1002 END FUNCTION mp_comm_type_get_handle
1003 LOGICAL FUNCTION mp_request_op_eq(request1, request2)
1004 CLASS(mp_request_type), INTENT(IN) :: request1, request2
1005#if defined(__parallel) && defined(__MPI_F08)
1006 mp_request_op_eq = (request1%handle%mpi_val == request2%handle%mpi_val)
1007#else
1008 mp_request_op_eq = (request1%handle == request2%handle)
1009#endif
1010 END FUNCTION mp_request_op_eq
1011
1012 LOGICAL FUNCTION mp_request_op_neq(request1, request2)
1013 CLASS(mp_request_type), INTENT(IN) :: request1, request2
1014#if defined(__parallel) && defined(__MPI_F08)
1015 mp_request_op_neq = (request1%handle%mpi_val /= request2%handle%mpi_val)
1016#else
1017 mp_request_op_neq = (request1%handle /= request2%handle)
1018#endif
1019 END FUNCTION mp_request_op_neq
1020
1021 ELEMENTAL SUBROUTINE mp_request_type_set_handle(this, handle )
1022 CLASS(mp_request_type), INTENT(INOUT) :: this
1023 INTEGER, INTENT(IN) :: handle
1024
1025#if defined(__parallel) && defined(__MPI_F08)
1026 this%handle%mpi_val = handle
1027#else
1028 this%handle = handle
1029#endif
1030
1031
1032 END SUBROUTINE mp_request_type_set_handle
1033
1034 ELEMENTAL FUNCTION mp_request_type_get_handle(this) RESULT(handle)
1035 CLASS(mp_request_type), INTENT(IN) :: this
1036 INTEGER :: handle
1037
1038#if defined(__parallel) && defined(__MPI_F08)
1039 handle = this%handle%mpi_val
1040#else
1041 handle = this%handle
1042#endif
1043 END FUNCTION mp_request_type_get_handle
1044 LOGICAL FUNCTION mp_win_op_eq(win1, win2)
1045 CLASS(mp_win_type), INTENT(IN) :: win1, win2
1046#if defined(__parallel) && defined(__MPI_F08)
1047 mp_win_op_eq = (win1%handle%mpi_val == win2%handle%mpi_val)
1048#else
1049 mp_win_op_eq = (win1%handle == win2%handle)
1050#endif
1051 END FUNCTION mp_win_op_eq
1052
1053 LOGICAL FUNCTION mp_win_op_neq(win1, win2)
1054 CLASS(mp_win_type), INTENT(IN) :: win1, win2
1055#if defined(__parallel) && defined(__MPI_F08)
1056 mp_win_op_neq = (win1%handle%mpi_val /= win2%handle%mpi_val)
1057#else
1058 mp_win_op_neq = (win1%handle /= win2%handle)
1059#endif
1060 END FUNCTION mp_win_op_neq
1061
1062 ELEMENTAL SUBROUTINE mp_win_type_set_handle(this, handle )
1063 CLASS(mp_win_type), INTENT(INOUT) :: this
1064 INTEGER, INTENT(IN) :: handle
1065
1066#if defined(__parallel) && defined(__MPI_F08)
1067 this%handle%mpi_val = handle
1068#else
1069 this%handle = handle
1070#endif
1071
1072
1073 END SUBROUTINE mp_win_type_set_handle
1074
1075 ELEMENTAL FUNCTION mp_win_type_get_handle(this) RESULT(handle)
1076 CLASS(mp_win_type), INTENT(IN) :: this
1077 INTEGER :: handle
1078
1079#if defined(__parallel) && defined(__MPI_F08)
1080 handle = this%handle%mpi_val
1081#else
1082 handle = this%handle
1083#endif
1084 END FUNCTION mp_win_type_get_handle
1085 LOGICAL FUNCTION mp_file_op_eq(file1, file2)
1086 CLASS(mp_file_type), INTENT(IN) :: file1, file2
1087#if defined(__parallel) && defined(__MPI_F08)
1088 mp_file_op_eq = (file1%handle%mpi_val == file2%handle%mpi_val)
1089#else
1090 mp_file_op_eq = (file1%handle == file2%handle)
1091#endif
1092 END FUNCTION mp_file_op_eq
1093
1094 LOGICAL FUNCTION mp_file_op_neq(file1, file2)
1095 CLASS(mp_file_type), INTENT(IN) :: file1, file2
1096#if defined(__parallel) && defined(__MPI_F08)
1097 mp_file_op_neq = (file1%handle%mpi_val /= file2%handle%mpi_val)
1098#else
1099 mp_file_op_neq = (file1%handle /= file2%handle)
1100#endif
1101 END FUNCTION mp_file_op_neq
1102
1103 ELEMENTAL SUBROUTINE mp_file_type_set_handle(this, handle )
1104 CLASS(mp_file_type), INTENT(INOUT) :: this
1105 INTEGER, INTENT(IN) :: handle
1106
1107#if defined(__parallel) && defined(__MPI_F08)
1108 this%handle%mpi_val = handle
1109#else
1110 this%handle = handle
1111#endif
1112
1113
1114 END SUBROUTINE mp_file_type_set_handle
1115
1116 ELEMENTAL FUNCTION mp_file_type_get_handle(this) RESULT(handle)
1117 CLASS(mp_file_type), INTENT(IN) :: this
1118 INTEGER :: handle
1119
1120#if defined(__parallel) && defined(__MPI_F08)
1121 handle = this%handle%mpi_val
1122#else
1123 handle = this%handle
1124#endif
1125 END FUNCTION mp_file_type_get_handle
1126 LOGICAL FUNCTION mp_info_op_eq(info1, info2)
1127 CLASS(mp_info_type), INTENT(IN) :: info1, info2
1128#if defined(__parallel) && defined(__MPI_F08)
1129 mp_info_op_eq = (info1%handle%mpi_val == info2%handle%mpi_val)
1130#else
1131 mp_info_op_eq = (info1%handle == info2%handle)
1132#endif
1133 END FUNCTION mp_info_op_eq
1134
1135 LOGICAL FUNCTION mp_info_op_neq(info1, info2)
1136 CLASS(mp_info_type), INTENT(IN) :: info1, info2
1137#if defined(__parallel) && defined(__MPI_F08)
1138 mp_info_op_neq = (info1%handle%mpi_val /= info2%handle%mpi_val)
1139#else
1140 mp_info_op_neq = (info1%handle /= info2%handle)
1141#endif
1142 END FUNCTION mp_info_op_neq
1143
1144 ELEMENTAL SUBROUTINE mp_info_type_set_handle(this, handle )
1145 CLASS(mp_info_type), INTENT(INOUT) :: this
1146 INTEGER, INTENT(IN) :: handle
1147
1148#if defined(__parallel) && defined(__MPI_F08)
1149 this%handle%mpi_val = handle
1150#else
1151 this%handle = handle
1152#endif
1153
1154
1155 END SUBROUTINE mp_info_type_set_handle
1156
1157 ELEMENTAL FUNCTION mp_info_type_get_handle(this) RESULT(handle)
1158 CLASS(mp_info_type), INTENT(IN) :: this
1159 INTEGER :: handle
1160
1161#if defined(__parallel) && defined(__MPI_F08)
1162 handle = this%handle%mpi_val
1163#else
1164 handle = this%handle
1165#endif
1166 END FUNCTION mp_info_type_get_handle
1167
1168 FUNCTION mp_comm_get_tag_ub(comm) RESULT(tag_ub)
1169 CLASS(mp_comm_type), INTENT(IN) :: comm
1170 INTEGER :: tag_ub
1171
1172#if defined(__parallel)
1173 INTEGER :: ierr
1174 LOGICAL :: flag
1175 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1176
1177 CALL mpi_comm_get_attr(comm%handle, mpi_tag_ub, attrval, flag, ierr)
1178 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_tag_ub")
1179 IF (.NOT. flag) THEN
1180 CALL cp_warn(__location__, "Upper bound of tags not available! "// &
1181 "Only the guaranteed minimum of 32767 is used.")
1182 tag_ub = 32767
1183 ELSE
1184 tag_ub = int(attrval, kind=kind(tag_ub))
1185 END IF
1186#else
1187 mark_used(comm)
1188 tag_ub = huge(1)
1189#endif
1190 END FUNCTION mp_comm_get_tag_ub
1191
1192 FUNCTION mp_comm_get_host_rank(comm) RESULT(host_rank)
1193 CLASS(mp_comm_type), INTENT(IN) :: comm
1194 INTEGER :: host_rank
1195
1196#if defined(__parallel)
1197 INTEGER :: ierr
1198 LOGICAL :: flag
1199 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1200
1201 CALL mpi_comm_get_attr(comm%handle, mpi_host, attrval, flag, ierr)
1202 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_host_rank")
1203 IF (.NOT. flag) cpabort("Host process rank not available!")
1204 host_rank = int(attrval, kind=kind(host_rank))
1205#else
1206 mark_used(comm)
1207 host_rank = 0
1208#endif
1209 END FUNCTION mp_comm_get_host_rank
1210
1211 FUNCTION mp_comm_get_io_rank(comm) RESULT(io_rank)
1212 CLASS(mp_comm_type), INTENT(IN) :: comm
1213 INTEGER :: io_rank
1214
1215#if defined(__parallel)
1216 INTEGER :: ierr
1217 LOGICAL :: flag
1218 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1219
1220 CALL mpi_comm_get_attr(comm%handle, mpi_io, attrval, flag, ierr)
1221 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_io_rank")
1222 IF (.NOT. flag) cpabort("IO rank not available!")
1223 io_rank = int(attrval, kind=kind(io_rank))
1224#else
1225 mark_used(comm)
1226 io_rank = 0
1227#endif
1228 END FUNCTION mp_comm_get_io_rank
1229
1230 FUNCTION mp_comm_get_wtime_is_global(comm) RESULT(wtime_is_global)
1231 CLASS(mp_comm_type), INTENT(IN) :: comm
1232 LOGICAL :: wtime_is_global
1233
1234#if defined(__parallel)
1235 INTEGER :: ierr
1236 LOGICAL :: flag
1237 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1238
1239 CALL mpi_comm_get_attr(comm%handle, mpi_tag_ub, attrval, flag, ierr)
1240 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_wtime_is_global")
1241 IF (.NOT. flag) cpabort("Synchronization state of WTIME not available!")
1242 wtime_is_global = (attrval == 1_mpi_address_kind)
1243#else
1244 mark_used(comm)
1245 wtime_is_global = .true.
1246#endif
1247 END FUNCTION mp_comm_get_wtime_is_global
1248
1249! **************************************************************************************************
1250!> \brief initializes the system default communicator
1251!> \param mp_comm [output] : handle of the default communicator
1252!> \par History
1253!> 2.2004 created [Joost VandeVondele ]
1254!> \note
1255!> should only be called once
1256! **************************************************************************************************
1257 SUBROUTINE mp_world_init(mp_comm)
1258 CLASS(mp_comm_type), INTENT(OUT) :: mp_comm
1259#if defined(__parallel)
1260 INTEGER :: ierr, provided_tsl
1261#if defined(__MIMIC)
1262 INTEGER :: mimic_handle
1263#endif
1264
1265!$OMP MASTER
1266#if defined(__DLAF) || defined(__OPENPMD)
1267 ! Both DLA-Future and (some IO backends of) the openPMD-api require
1268 ! that the MPI library supports THREAD_MULTIPLE mode
1269 CALL mpi_init_thread(mpi_thread_multiple, provided_tsl, ierr)
1270 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
1271 IF (provided_tsl < mpi_thread_multiple) THEN
1272 CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_MULTIPLE),"// &
1273 " required by DLA-Future/openPMD-api. Build CP2K without DLA-Future and openPMD-api.")
1274 END IF
1275#else
1276 CALL mpi_init_thread(mpi_thread_serialized, provided_tsl, ierr)
1277 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
1278 IF (provided_tsl < mpi_thread_serialized) THEN
1279 CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_SERIALIZED).")
1280 END IF
1281#endif
1282!$OMP END MASTER
1283 CALL mpi_comm_set_errhandler(mpi_comm_world, mpi_errors_return, ierr)
1284 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_set_errhandler @ mp_world_init")
1285#endif
1286 debug_comm_count = 1
1287 mp_comm = mp_comm_world
1288#if defined(__MIMIC)
1289 mimic_handle = mp_comm%get_handle()
1290 CALL mcl_initialize(mimic_handle)
1291 CALL mp_comm%set_handle(mimic_handle)
1292#if defined(__MPI_F08)
1293 mimic_comm_world%mpi_val = mimic_handle
1294#else
1295 mimic_comm_world = mimic_handle
1296#endif
1297#endif
1298 CALL mp_comm%init()
1299 CALL add_mp_perf_env()
1300 END SUBROUTINE mp_world_init
1301
1302! **************************************************************************************************
1303!> \brief re-create the system default communicator with a different MPI
1304!> rank order
1305!> \param mp_comm [output] : handle of the default communicator
1306!> \param mp_new_comm ...
1307!> \param ranks_order ...
1308!> \par History
1309!> 1.2012 created [ Christiane Pousa ]
1310!> \note
1311!> should only be called once, at very beginning of CP2K run
1312! **************************************************************************************************
1313 SUBROUTINE mp_reordering(mp_comm, mp_new_comm, ranks_order)
1314 CLASS(mp_comm_type), INTENT(IN) :: mp_comm
1315 CLASS(mp_comm_type), INTENT(out) :: mp_new_comm
1316 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: ranks_order
1317
1318 CHARACTER(len=*), PARAMETER :: routinen = 'mp_reordering'
1319
1320 INTEGER :: handle, ierr
1321#if defined(__parallel)
1322 mpi_group_type :: newgroup, oldgroup
1323#endif
1324
1325 CALL mp_timeset(routinen, handle)
1326 ierr = 0
1327#if defined(__parallel)
1328
1329 CALL mpi_comm_group(mp_comm%handle, oldgroup, ierr)
1330 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_reordering")
1331 CALL mpi_group_incl(oldgroup, SIZE(ranks_order), ranks_order, newgroup, ierr)
1332 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_incl @ mp_reordering")
1333
1334 CALL mpi_comm_create(mp_comm%handle, newgroup, mp_new_comm%handle, ierr)
1335 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_create @ mp_reordering")
1336
1337 CALL mpi_group_free(oldgroup, ierr)
1338 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1339 CALL mpi_group_free(newgroup, ierr)
1340 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1341
1342 CALL add_perf(perf_id=1, count=1)
1343#else
1344 mark_used(mp_comm)
1345 mark_used(ranks_order)
1346 mp_new_comm%handle = mp_comm_default_handle
1347#endif
1348 debug_comm_count = debug_comm_count + 1
1349 CALL mp_new_comm%init()
1350 CALL mp_timestop(handle)
1351 END SUBROUTINE mp_reordering
1352
1353! **************************************************************************************************
1354!> \brief finalizes the system default communicator
1355!> \par History
1356!> 2.2004 created [Joost VandeVondele]
1357! **************************************************************************************************
1358 SUBROUTINE mp_world_finalize()
1359
1360 CHARACTER(LEN=default_string_length) :: debug_comm_count_char
1361#if defined(__parallel)
1362 INTEGER :: ierr
1363#if defined(__MIMIC)
1364 CALL mpi_barrier(mimic_comm_world, ierr)
1365#else
1366 CALL mpi_barrier(mpi_comm_world, ierr) ! call mpi directly to avoid 0 stack pointer
1367#endif
1368#endif
1369 CALL rm_mp_perf_env()
1370
1371 debug_comm_count = debug_comm_count - 1
1372#if defined(__parallel)
1373 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_world_finalize")
1374#endif
1375 IF (debug_comm_count /= 0) THEN
1376 ! A bug, we're leaking or double-freeing communicators. Needs to be fixed where the leak happens.
1377 ! Memory leak checking might be helpful to locate the culprit
1378 WRITE (unit=debug_comm_count_char, fmt='(I2)') debug_comm_count
1379 CALL cp_abort(__location__, "mp_world_finalize: assert failed:"// &
1380 " leaking communicators "//adjustl(trim(debug_comm_count_char)))
1381 END IF
1382#if defined(__parallel)
1383 CALL mpi_finalize(ierr)
1384 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_finalize @ mp_world_finalize")
1385#endif
1386
1387 END SUBROUTINE mp_world_finalize
1388
1389! all the following routines should work for a given communicator, not MPI_WORLD
1390
1391! **************************************************************************************************
1392!> \brief globally stops all tasks
1393!> this is intended to be low level, most of CP2K should call cp_abort()
1394! **************************************************************************************************
1395 SUBROUTINE mp_abort()
1396 INTEGER :: ierr
1397#if defined(__MIMIC)
1398 LOGICAL :: mcl_initialized
1399#endif
1400
1401 ierr = 0
1402
1403#if !defined(__NO_ABORT)
1404#if defined(__parallel)
1405#if defined(__MIMIC)
1406 CALL mcl_is_initialized(mcl_initialized)
1407 IF (mcl_initialized) CALL mcl_abort(1, ierr)
1408#endif
1409 CALL mpi_abort(mpi_comm_world, 1, ierr)
1410#else
1411 CALL m_abort()
1412#endif
1413#endif
1414 ! this routine never returns and levels with non-zero exit code
1415 stop 1
1416 END SUBROUTINE mp_abort
1417
1418! **************************************************************************************************
1419!> \brief stops *after an mpi error* translating the error code
1420!> \param ierr an error code * returned by an mpi call *
1421!> \param prg_code ...
1422!> \note
1423!> this function is private to message_passing.F
1424! **************************************************************************************************
1425 SUBROUTINE mp_stop(ierr, prg_code)
1426 INTEGER, INTENT(IN) :: ierr
1427 CHARACTER(LEN=*), INTENT(IN) :: prg_code
1428
1429#if defined(__parallel)
1430 INTEGER :: istat, len
1431 CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: error_string
1432 CHARACTER(LEN=MPI_MAX_ERROR_STRING + 512) :: full_error
1433#else
1434 CHARACTER(LEN=512) :: full_error
1435#endif
1436
1437#if defined(__parallel)
1438 CALL mpi_error_string(ierr, error_string, len, istat)
1439 WRITE (full_error, '(A,I0,A)') ' MPI error ', ierr, ' in '//trim(prg_code)//' : '//error_string(1:len)
1440#else
1441 WRITE (full_error, '(A,I0,A)') ' MPI error (!?) ', ierr, ' in '//trim(prg_code)
1442#endif
1443
1444 cpabort(full_error)
1445
1446 END SUBROUTINE mp_stop
1447
1448! **************************************************************************************************
1449!> \brief synchronizes with a barrier a given group of mpi tasks
1450!> \param group mpi communicator
1451! **************************************************************************************************
1452 SUBROUTINE mp_sync(comm)
1453 CLASS(mp_comm_type), INTENT(IN) :: comm
1454
1455 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sync'
1456
1457 INTEGER :: handle, ierr
1458
1459 ierr = 0
1460 CALL mp_timeset(routinen, handle)
1461
1462#if defined(__parallel)
1463 CALL mpi_barrier(comm%handle, ierr)
1464 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_sync")
1465 CALL add_perf(perf_id=5, count=1)
1466#else
1467 mark_used(comm)
1468#endif
1469 CALL mp_timestop(handle)
1470
1471 END SUBROUTINE mp_sync
1472
1473! **************************************************************************************************
1474!> \brief synchronizes with a barrier a given group of mpi tasks
1475!> \param comm mpi communicator
1476!> \param request ...
1477! **************************************************************************************************
1478 SUBROUTINE mp_isync(comm, request)
1479 CLASS(mp_comm_type), INTENT(IN) :: comm
1480 TYPE(mp_request_type), INTENT(OUT) :: request
1481
1482 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isync'
1483
1484 INTEGER :: handle, ierr
1485
1486 ierr = 0
1487 CALL mp_timeset(routinen, handle)
1488
1489#if defined(__parallel)
1490 CALL mpi_ibarrier(comm%handle, request%handle, ierr)
1491 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibarrier @ mp_isync")
1492 CALL add_perf(perf_id=26, count=1)
1493#else
1494 mark_used(comm)
1495 request = mp_request_null
1496#endif
1497 CALL mp_timestop(handle)
1498
1499 END SUBROUTINE mp_isync
1500
1501! **************************************************************************************************
1502!> \brief returns task id for a given mpi communicator
1503!> \param taskid The ID of the communicator
1504!> \param comm mpi communicator
1505! **************************************************************************************************
1506 SUBROUTINE mp_comm_rank(taskid, comm)
1507
1508 INTEGER, INTENT(OUT) :: taskid
1509 CLASS(mp_comm_type), INTENT(IN) :: comm
1510
1511 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_rank'
1512
1513 INTEGER :: handle
1514#if defined(__parallel)
1515 INTEGER :: ierr
1516#endif
1517
1518 CALL mp_timeset(routinen, handle)
1519
1520#if defined(__parallel)
1521 CALL mpi_comm_rank(comm%handle, taskid, ierr)
1522 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_rank")
1523#else
1524 mark_used(comm)
1525 taskid = 0
1526#endif
1527 CALL mp_timestop(handle)
1528
1529 END SUBROUTINE mp_comm_rank
1530
1531! **************************************************************************************************
1532!> \brief returns number of tasks for a given mpi communicator
1533!> \param numtask ...
1534!> \param comm mpi communicator
1535! **************************************************************************************************
1536 SUBROUTINE mp_comm_size(numtask, comm)
1537
1538 INTEGER, INTENT(OUT) :: numtask
1539 CLASS(mp_comm_type), INTENT(IN) :: comm
1540
1541 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_size'
1542
1543 INTEGER :: handle
1544#if defined(__parallel)
1545 INTEGER :: ierr
1546#endif
1547
1548 CALL mp_timeset(routinen, handle)
1549
1550#if defined(__parallel)
1551 CALL mpi_comm_size(comm%handle, numtask, ierr)
1552 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_size")
1553#else
1554 mark_used(comm)
1555 numtask = 1
1556#endif
1557 CALL mp_timestop(handle)
1558
1559 END SUBROUTINE mp_comm_size
1560
1561! **************************************************************************************************
1562!> \brief returns info for a given Cartesian MPI communicator
1563!> \param comm ...
1564!> \param ndims ...
1565!> \param dims ...
1566!> \param task_coor ...
1567!> \param periods ...
1568! **************************************************************************************************
1569 SUBROUTINE mp_cart_get(comm, dims, task_coor, periods)
1570
1571 CLASS(mp_cart_type), INTENT(IN) :: comm
1572 INTEGER, INTENT(OUT), OPTIONAL :: dims(comm%ndims), task_coor(comm%ndims)
1573 LOGICAL, INTENT(out), OPTIONAL :: periods(comm%ndims)
1574
1575 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_get'
1576
1577 INTEGER :: handle
1578#if defined(__parallel)
1579 INTEGER :: ierr
1580 INTEGER :: my_dims(comm%ndims), my_task_coor(comm%ndims)
1581 LOGICAL :: my_periods(comm%ndims)
1582#endif
1583
1584 CALL mp_timeset(routinen, handle)
1585
1586#if defined(__parallel)
1587 CALL mpi_cart_get(comm%handle, comm%ndims, my_dims, my_periods, my_task_coor, ierr)
1588 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_cart_get")
1589 IF (PRESENT(dims)) dims = my_dims
1590 IF (PRESENT(task_coor)) task_coor = my_task_coor
1591 IF (PRESENT(periods)) periods = my_periods
1592#else
1593 mark_used(comm)
1594 IF (PRESENT(task_coor)) task_coor = 0
1595 IF (PRESENT(dims)) dims = 1
1596 IF (PRESENT(periods)) periods = .false.
1597#endif
1598 CALL mp_timestop(handle)
1599
1600 END SUBROUTINE mp_cart_get
1601
1602 INTEGER ELEMENTAL function mp_comm_get_ndims(comm)
1603 CLASS(mp_comm_type), INTENT(IN) :: comm
1604
1605 mp_comm_get_ndims = comm%ndims
1606
1607 END FUNCTION
1608
1609! **************************************************************************************************
1610!> \brief creates a cartesian communicator from any communicator
1611!> \param comm_old ...
1612!> \param ndims ...
1613!> \param dims ...
1614!> \param pos ...
1615!> \param comm_cart ...
1616! **************************************************************************************************
1617 SUBROUTINE mp_cart_create(comm_old, ndims, dims, comm_cart)
1618
1619 CLASS(mp_comm_type), INTENT(IN) :: comm_old
1620 INTEGER, INTENT(IN) :: ndims
1621 INTEGER, INTENT(INOUT) :: dims(ndims)
1622 CLASS(mp_cart_type), INTENT(OUT) :: comm_cart
1623
1624 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_create'
1625
1626 INTEGER :: handle, ierr
1627#if defined(__parallel)
1628 LOGICAL, DIMENSION(1:ndims) :: period
1629 LOGICAL :: reorder
1630#endif
1631
1632 ierr = 0
1633 CALL mp_timeset(routinen, handle)
1634
1635 comm_cart%handle = comm_old%handle
1636#if defined(__parallel)
1637
1638 IF (any(dims == 0)) CALL mpi_dims_create(comm_old%num_pe, ndims, dims, ierr)
1639 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_cart_create")
1640
1641 ! FIX ME. Quick hack to avoid problems with realspace grids for compilers
1642 ! like IBM that actually reorder the processors when creating the new
1643 ! communicator
1644 reorder = .false.
1645 period = .true.
1646 CALL mpi_cart_create(comm_old%handle, ndims, dims, period, reorder, comm_cart%handle, &
1647 ierr)
1648 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_create @ mp_cart_create")
1649 CALL add_perf(perf_id=1, count=1)
1650#else
1651 dims = 1
1652 comm_cart%handle = mp_comm_default_handle
1653#endif
1654 comm_cart%ndims = ndims
1655 debug_comm_count = debug_comm_count + 1
1656 CALL comm_cart%init()
1657 CALL mp_timestop(handle)
1658
1659 END SUBROUTINE mp_cart_create
1660
1661! **************************************************************************************************
1662!> \brief wrapper to MPI_Cart_coords
1663!> \param comm ...
1664!> \param rank ...
1665!> \param coords ...
1666! **************************************************************************************************
1667 SUBROUTINE mp_cart_coords(comm, rank, coords)
1668
1669 CLASS(mp_cart_type), INTENT(IN) :: comm
1670 INTEGER, INTENT(IN) :: rank
1671 INTEGER, DIMENSION(:), INTENT(OUT) :: coords
1672
1673 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_coords'
1674
1675 INTEGER :: handle, ierr, m
1676
1677 ierr = 0
1678 CALL mp_timeset(routinen, handle)
1679
1680 m = SIZE(coords)
1681#if defined(__parallel)
1682 CALL mpi_cart_coords(comm%handle, rank, m, coords, ierr)
1683 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_coords @ mp_cart_coords")
1684#else
1685 coords = 0
1686 mark_used(rank)
1687 mark_used(comm)
1688#endif
1689 CALL mp_timestop(handle)
1690
1691 END SUBROUTINE mp_cart_coords
1692
1693! **************************************************************************************************
1694!> \brief wrapper to MPI_Comm_compare
1695!> \param comm1 ...
1696!> \param comm2 ...
1697!> \param res ...
1698! **************************************************************************************************
1699 FUNCTION mp_comm_compare(comm1, comm2) RESULT(res)
1700
1701 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
1702 INTEGER :: res
1703
1704 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_compare'
1705
1706 INTEGER :: handle
1707#if defined(__parallel)
1708 INTEGER :: ierr, iout
1709#endif
1710
1711 CALL mp_timeset(routinen, handle)
1712
1713 res = 0
1714#if defined(__parallel)
1715 CALL mpi_comm_compare(comm1%handle, comm2%handle, iout, ierr)
1716 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_compare @ mp_comm_compare")
1717 SELECT CASE (iout)
1718 CASE (mpi_ident)
1719 res = mp_comm_ident
1720 CASE (mpi_congruent)
1721 res = mp_comm_congruent
1722 CASE (mpi_similar)
1723 res = mp_comm_similar
1724 CASE (mpi_unequal)
1725 res = mp_comm_unequal
1726 CASE default
1727 cpabort("Unknown comparison state of the communicators!")
1728 END SELECT
1729#else
1730 mark_used(comm1)
1731 mark_used(comm2)
1732#endif
1733 CALL mp_timestop(handle)
1734
1735 END FUNCTION mp_comm_compare
1736
1737! **************************************************************************************************
1738!> \brief wrapper to MPI_Cart_sub
1739!> \param comm ...
1740!> \param rdim ...
1741!> \param sub_comm ...
1742! **************************************************************************************************
1743 SUBROUTINE mp_cart_sub(comm, rdim, sub_comm)
1744
1745 CLASS(mp_cart_type), INTENT(IN) :: comm
1746 LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: rdim
1747 CLASS(mp_cart_type), INTENT(OUT) :: sub_comm
1748
1749 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_sub'
1750
1751 INTEGER :: handle
1752#if defined(__parallel)
1753 INTEGER :: ierr
1754#endif
1755
1756 CALL mp_timeset(routinen, handle)
1757
1758#if defined(__parallel)
1759 CALL mpi_cart_sub(comm%handle, rdim, sub_comm%handle, ierr)
1760 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_sub @ mp_cart_sub")
1761#else
1762 mark_used(comm)
1763 mark_used(rdim)
1764 sub_comm%handle = mp_comm_default_handle
1765#endif
1766 sub_comm%ndims = count(rdim)
1767 debug_comm_count = debug_comm_count + 1
1768 CALL sub_comm%init()
1769 CALL mp_timestop(handle)
1770
1771 END SUBROUTINE mp_cart_sub
1772
1773! **************************************************************************************************
1774!> \brief wrapper to MPI_Comm_free
1775!> \param comm ...
1776! **************************************************************************************************
1777 SUBROUTINE mp_comm_free(comm)
1778
1779 CLASS(mp_comm_type), INTENT(INOUT) :: comm
1780
1781 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_free'
1782
1783 INTEGER :: handle
1784 LOGICAL :: free_comm
1785#if defined(__parallel)
1786 INTEGER :: ierr
1787#endif
1788
1789 free_comm = .true.
1790 SELECT TYPE (comm)
1791 CLASS IS (mp_para_env_type)
1792 free_comm = .false.
1793 IF (comm%ref_count <= 0) &
1794 cpabort("para_env%ref_count <= 0")
1795 comm%ref_count = comm%ref_count - 1
1796 IF (comm%ref_count <= 0) THEN
1797 free_comm = comm%owns_group
1798 END IF
1799 CLASS IS (mp_para_cart_type)
1800 free_comm = .false.
1801 IF (comm%ref_count <= 0) &
1802 cpabort("para_cart%ref_count <= 0")
1803 comm%ref_count = comm%ref_count - 1
1804 IF (comm%ref_count <= 0) THEN
1805 free_comm = comm%owns_group
1806 END IF
1807 END SELECT
1808
1809 CALL mp_timeset(routinen, handle)
1810
1811 IF (free_comm) THEN
1812#if defined(__parallel)
1813 CALL mpi_comm_free(comm%handle, ierr)
1814 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_free @ mp_comm_free")
1815#else
1816 comm%handle = mp_comm_null_handle
1817#endif
1818 debug_comm_count = debug_comm_count - 1
1819 END IF
1820
1821 SELECT TYPE (comm)
1822 CLASS IS (mp_cart_type)
1823 DEALLOCATE (comm%periodic, comm%mepos_cart, comm%num_pe_cart)
1824 END SELECT
1825
1826 CALL mp_timestop(handle)
1827
1828 END SUBROUTINE mp_comm_free
1829
1830! **************************************************************************************************
1831!> \brief check whether the environment exists
1832!> \param para_env ...
1833!> \return ...
1834! **************************************************************************************************
1835 ELEMENTAL LOGICAL FUNCTION mp_para_env_is_valid(para_env)
1836 CLASS(mp_para_env_type), INTENT(IN) :: para_env
1837
1838 mp_para_env_is_valid = para_env%ref_count > 0
1839
1840 END FUNCTION mp_para_env_is_valid
1841
1842! **************************************************************************************************
1843!> \brief increase the reference counter but ensure that you free it later
1844!> \param para_env ...
1845! **************************************************************************************************
1846 ELEMENTAL SUBROUTINE mp_para_env_retain(para_env)
1847 CLASS(mp_para_env_type), INTENT(INOUT) :: para_env
1848
1849 para_env%ref_count = para_env%ref_count + 1
1850
1851 END SUBROUTINE mp_para_env_retain
1852
1853! **************************************************************************************************
1854!> \brief check whether the given environment is valid, i.e. existent
1855!> \param cart ...
1856!> \return ...
1857! **************************************************************************************************
1858 ELEMENTAL LOGICAL FUNCTION mp_para_cart_is_valid(cart)
1859 CLASS(mp_para_cart_type), INTENT(IN) :: cart
1860
1861 mp_para_cart_is_valid = cart%ref_count > 0
1862
1863 END FUNCTION mp_para_cart_is_valid
1864
1865! **************************************************************************************************
1866!> \brief increase the reference counter, don't forget to free it later
1867!> \param cart ...
1868! **************************************************************************************************
1869 ELEMENTAL SUBROUTINE mp_para_cart_retain(cart)
1870 CLASS(mp_para_cart_type), INTENT(INOUT) :: cart
1871
1872 cart%ref_count = cart%ref_count + 1
1873
1874 END SUBROUTINE mp_para_cart_retain
1875
1876! **************************************************************************************************
1877!> \brief wrapper to MPI_Comm_dup
1878!> \param comm1 ...
1879!> \param comm2 ...
1880! **************************************************************************************************
1881 SUBROUTINE mp_comm_dup(comm1, comm2)
1882
1883 CLASS(mp_comm_type), INTENT(IN) :: comm1
1884 CLASS(mp_comm_type), INTENT(OUT) :: comm2
1885
1886 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_dup'
1887
1888 INTEGER :: handle
1889#if defined(__parallel)
1890 INTEGER :: ierr
1891#endif
1892
1893 CALL mp_timeset(routinen, handle)
1894
1895#if defined(__parallel)
1896 CALL mpi_comm_dup(comm1%handle, comm2%handle, ierr)
1897 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_dup @ mp_comm_dup")
1898#else
1899 mark_used(comm1)
1900 comm2%handle = mp_comm_default_handle
1901#endif
1902 comm2%ndims = comm1%ndims
1903 debug_comm_count = debug_comm_count + 1
1904 CALL comm2%init()
1905 CALL mp_timestop(handle)
1906
1907 END SUBROUTINE mp_comm_dup
1908
1909! **************************************************************************************************
1910!> \brief Implements a simple assignment function to overload the assignment operator
1911!> \param comm_new communicator on the r.h.s. of the assignment operator
1912!> \param comm_old communicator on the l.h.s. of the assignment operator
1913! **************************************************************************************************
1914 ELEMENTAL IMPURE SUBROUTINE mp_comm_assign(comm_new, comm_old)
1915 CLASS(mp_comm_type), INTENT(IN) :: comm_old
1916 CLASS(mp_comm_type), INTENT(OUT) :: comm_new
1917
1918 comm_new%handle = comm_old%handle
1919 comm_new%ndims = comm_old%ndims
1920 CALL comm_new%init(.false.)
1921 END SUBROUTINE
1922
1923! **************************************************************************************************
1924!> \brief check whether the local process is the source process
1925!> \param para_env ...
1926!> \return ...
1927! **************************************************************************************************
1928 ELEMENTAL LOGICAL FUNCTION mp_comm_is_source(comm)
1929 CLASS(mp_comm_type), INTENT(IN) :: comm
1930
1931 mp_comm_is_source = comm%source == comm%mepos
1932
1933 END FUNCTION mp_comm_is_source
1934
1935! **************************************************************************************************
1936!> \brief Initializes the communicator (mostly relevant for its derived classes)
1937!> \param comm ...
1938! **************************************************************************************************
1939 ELEMENTAL IMPURE SUBROUTINE mp_comm_init(comm, owns_group)
1940 CLASS(mp_comm_type), INTENT(INOUT) :: comm
1941 LOGICAL, INTENT(IN), OPTIONAL :: owns_group
1942
1943 IF (comm%handle mpi_get_comp /= mp_comm_null_handle mpi_get_comp) THEN
1944 comm%source = 0
1945 CALL comm%get_size(comm%num_pe)
1946 CALL comm%get_rank(comm%mepos)
1947 END IF
1948
1949 SELECT TYPE (comm)
1950 CLASS IS (mp_cart_type)
1951 IF (ALLOCATED(comm%periodic)) DEALLOCATE (comm%periodic)
1952 IF (ALLOCATED(comm%mepos_cart)) DEALLOCATE (comm%mepos_cart)
1953 IF (ALLOCATED(comm%num_pe_cart)) DEALLOCATE (comm%num_pe_cart)
1954
1955 associate(ndims => comm%ndims)
1956
1957 ALLOCATE (comm%periodic(ndims), comm%mepos_cart(ndims), &
1958 comm%num_pe_cart(ndims))
1959 END associate
1960
1961 comm%mepos_cart = 0
1962 comm%periodic = .false.
1963 IF (comm%handle mpi_get_comp /= mp_comm_null_handle mpi_get_comp) THEN
1964 CALL comm%get_info_cart(comm%num_pe_cart, comm%mepos_cart, &
1965 comm%periodic)
1966 END IF
1967 END SELECT
1968
1969 SELECT TYPE (comm)
1970 CLASS IS (mp_para_env_type)
1971 IF (PRESENT(owns_group)) comm%owns_group = owns_group
1972 comm%ref_count = 1
1973 CLASS IS (mp_para_cart_type)
1974 IF (PRESENT(owns_group)) comm%owns_group = owns_group
1975 comm%ref_count = 1
1976 END SELECT
1977
1978 END SUBROUTINE
1979
1980! **************************************************************************************************
1981!> \brief creates a new para environment
1982!> \param para_env the new parallel environment
1983!> \param group the id of the actual mpi_group
1984!> \par History
1985!> 08.2002 created [fawzi]
1986!> \author Fawzi Mohamed
1987! **************************************************************************************************
1988 SUBROUTINE mp_para_env_create(para_env, group)
1989 TYPE(mp_para_env_type), POINTER :: para_env
1990 CLASS(mp_comm_type), INTENT(in) :: group
1991
1992 IF (ASSOCIATED(para_env)) &
1993 cpabort("The passed para_env must not be associated!")
1994 ALLOCATE (para_env)
1995 para_env%mp_comm_type = group
1996 CALL para_env%init()
1997 END SUBROUTINE mp_para_env_create
1998
1999! **************************************************************************************************
2000!> \brief releases the para object (to be called when you don't want anymore
2001!> the shared copy of this object)
2002!> \param para_env the new group
2003!> \par History
2004!> 08.2002 created [fawzi]
2005!> \author Fawzi Mohamed
2006!> \note
2007!> to avoid circular dependencies cp_log_handling has a private copy
2008!> of this method (see cp_log_handling:my_mp_para_env_release)!
2009! **************************************************************************************************
2010 SUBROUTINE mp_para_env_release(para_env)
2011 TYPE(mp_para_env_type), POINTER :: para_env
2012
2013 IF (ASSOCIATED(para_env)) THEN
2014 CALL para_env%free()
2015 IF (.NOT. para_env%is_valid()) DEALLOCATE (para_env)
2016 END IF
2017 NULLIFY (para_env)
2018 END SUBROUTINE mp_para_env_release
2019
2020! **************************************************************************************************
2021!> \brief creates a cart (multidimensional parallel environment)
2022!> \param cart the cart environment to create
2023!> \param group the mpi communicator
2024!> \author fawzi
2025! **************************************************************************************************
2026 SUBROUTINE mp_para_cart_create(cart, group)
2027 TYPE(mp_para_cart_type), POINTER, INTENT(OUT) :: cart
2028 CLASS(mp_comm_type), INTENT(in) :: group
2029
2030 IF (ASSOCIATED(cart)) &
2031 cpabort("The passed para_cart must not be associated!")
2032 ALLOCATE (cart)
2033 cart%mp_cart_type = group
2034 CALL cart%init()
2035
2036 END SUBROUTINE mp_para_cart_create
2037
2038! **************************************************************************************************
2039!> \brief releases the given cart
2040!> \param cart the cart to release
2041!> \author fawzi
2042! **************************************************************************************************
2043 SUBROUTINE mp_para_cart_release(cart)
2044 TYPE(mp_para_cart_type), POINTER :: cart
2045
2046 IF (ASSOCIATED(cart)) THEN
2047 CALL cart%free()
2048 IF (.NOT. cart%is_valid()) DEALLOCATE (cart)
2049 END IF
2050 NULLIFY (cart)
2051 END SUBROUTINE mp_para_cart_release
2052
2053! **************************************************************************************************
2054!> \brief wrapper to MPI_Group_translate_ranks
2055!> \param comm1 ...
2056!> \param comm2 ...
2057!> \param rank ...
2058! **************************************************************************************************
2059 SUBROUTINE mp_rank_compare(comm1, comm2, rank)
2060
2061 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
2062 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rank
2063
2064 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rank_compare'
2065
2066 INTEGER :: handle
2067#if defined(__parallel)
2068 INTEGER :: i, ierr, n, n1, n2
2069 INTEGER, ALLOCATABLE, DIMENSION(:) :: rin
2070 mpi_group_type :: g1, g2
2071#endif
2072
2073 CALL mp_timeset(routinen, handle)
2074
2075 rank = 0
2076#if defined(__parallel)
2077 CALL mpi_comm_size(comm1%handle, n1, ierr)
2078 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
2079 CALL mpi_comm_size(comm2%handle, n2, ierr)
2080 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
2081 n = max(n1, n2)
2082 CALL mpi_comm_group(comm1%handle, g1, ierr)
2083 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
2084 CALL mpi_comm_group(comm2%handle, g2, ierr)
2085 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
2086 ALLOCATE (rin(0:n - 1), stat=ierr)
2087 IF (ierr /= 0) &
2088 cpabort("allocate @ mp_rank_compare")
2089 DO i = 0, n - 1
2090 rin(i) = i
2091 END DO
2092 CALL mpi_group_translate_ranks(g1, n, rin, g2, rank, ierr)
2093 IF (ierr /= 0) CALL mp_stop(ierr, &
2094 "mpi_group_translate_rank @ mp_rank_compare")
2095 CALL mpi_group_free(g1, ierr)
2096 IF (ierr /= 0) &
2097 cpabort("group_free @ mp_rank_compare")
2098 CALL mpi_group_free(g2, ierr)
2099 IF (ierr /= 0) &
2100 cpabort("group_free @ mp_rank_compare")
2101 DEALLOCATE (rin)
2102#else
2103 mark_used(comm1)
2104 mark_used(comm2)
2105#endif
2106 CALL mp_timestop(handle)
2107
2108 END SUBROUTINE mp_rank_compare
2109
2110! **************************************************************************************************
2111!> \brief wrapper to MPI_Dims_create
2112!> \param nodes ...
2113!> \param dims ...
2114! **************************************************************************************************
2115 SUBROUTINE mp_dims_create(nodes, dims)
2116
2117 INTEGER, INTENT(IN) :: nodes
2118 INTEGER, DIMENSION(:), INTENT(INOUT) :: dims
2119
2120 CHARACTER(len=*), PARAMETER :: routinen = 'mp_dims_create'
2121
2122 INTEGER :: handle, ndim
2123#if defined(__parallel)
2124 INTEGER :: ierr
2125#endif
2126
2127 CALL mp_timeset(routinen, handle)
2128
2129 ndim = SIZE(dims)
2130#if defined(__parallel)
2131 IF (any(dims == 0)) CALL mpi_dims_create(nodes, ndim, dims, ierr)
2132 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_dims_create")
2133#else
2134 dims = 1
2135 mark_used(nodes)
2136#endif
2137 CALL mp_timestop(handle)
2138
2139 END SUBROUTINE mp_dims_create
2140
2141! **************************************************************************************************
2142!> \brief wrapper to MPI_Cart_rank
2143!> \param comm ...
2144!> \param pos ...
2145!> \param rank ...
2146! **************************************************************************************************
2147 SUBROUTINE mp_cart_rank(comm, pos, rank)
2148 CLASS(mp_cart_type), INTENT(IN) :: comm
2149 INTEGER, DIMENSION(:), INTENT(IN) :: pos
2150 INTEGER, INTENT(OUT) :: rank
2151
2152 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_rank'
2153
2154 INTEGER :: handle
2155#if defined(__parallel)
2156 INTEGER :: ierr
2157#endif
2158
2159 CALL mp_timeset(routinen, handle)
2160
2161#if defined(__parallel)
2162 CALL mpi_cart_rank(comm%handle, pos, rank, ierr)
2163 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_rank @ mp_cart_rank")
2164#else
2165 rank = 0
2166 mark_used(comm)
2167 mark_used(pos)
2168#endif
2169 CALL mp_timestop(handle)
2170
2171 END SUBROUTINE mp_cart_rank
2172
2173! **************************************************************************************************
2174!> \brief waits for completion of the given request
2175!> \param request ...
2176!> \par History
2177!> 08.2003 created [f&j]
2178!> \author joost & fawzi
2179!> \note
2180!> see isendrecv
2181! **************************************************************************************************
2182 SUBROUTINE mp_wait(request)
2183 CLASS(mp_request_type), INTENT(inout) :: request
2184
2185 CHARACTER(len=*), PARAMETER :: routinen = 'mp_wait'
2186
2187 INTEGER :: handle
2188#if defined(__parallel)
2189 INTEGER :: ierr
2190#endif
2191
2192 CALL mp_timeset(routinen, handle)
2193
2194#if defined(__parallel)
2195
2196 CALL mpi_wait(request%handle, mpi_status_ignore, ierr)
2197 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_wait @ mp_wait")
2198
2199 CALL add_perf(perf_id=9, count=1)
2200#else
2201 request%handle = mp_request_null_handle
2202#endif
2203 CALL mp_timestop(handle)
2204 END SUBROUTINE mp_wait
2205
2206! **************************************************************************************************
2207!> \brief waits for completion of the given requests
2208!> \param requests ...
2209!> \par History
2210!> 08.2003 created [f&j]
2211!> \author joost & fawzi
2212!> \note
2213!> see isendrecv
2214! **************************************************************************************************
2215 SUBROUTINE mp_waitall_1(requests)
2216 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2217
2218 CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_1'
2219
2220 INTEGER :: handle
2221#if defined(__parallel)
2222 INTEGER :: count, ierr
2223#endif
2224
2225 CALL mp_timeset(routinen, handle)
2226#if defined(__parallel)
2227 count = SIZE(requests)
2228 CALL mpi_waitall_internal(count, requests, ierr)
2229 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_1")
2230 CALL add_perf(perf_id=9, count=1)
2231#else
2232 requests = mp_request_null
2233#endif
2234 CALL mp_timestop(handle)
2235 END SUBROUTINE mp_waitall_1
2236
2237! **************************************************************************************************
2238!> \brief waits for completion of the given requests
2239!> \param requests ...
2240!> \par History
2241!> 08.2003 created [f&j]
2242!> \author joost & fawzi
2243! **************************************************************************************************
2244 SUBROUTINE mp_waitall_2(requests)
2245 TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2246
2247 CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_2'
2248
2249 INTEGER :: handle
2250#if defined(__parallel)
2251 INTEGER :: count, ierr
2252#endif
2253
2254 CALL mp_timeset(routinen, handle)
2255#if defined(__parallel)
2256 count = SIZE(requests)
2257 CALL mpi_waitall_internal(count, requests, ierr)
2258 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_2")
2259 CALL add_perf(perf_id=9, count=1)
2260#else
2261 requests = mp_request_null
2262#endif
2263 CALL mp_timestop(handle)
2264 END SUBROUTINE mp_waitall_2
2265
2266! **************************************************************************************************
2267!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2268!> the issue is with the rank or requests
2269!> \param count ...
2270!> \param array_of_requests ...
2271!> \param ierr ...
2272!> \author Joost VandeVondele
2273! **************************************************************************************************
2274#if defined(__parallel)
2275 SUBROUTINE mpi_waitall_internal(count, array_of_requests, ierr)
2276 INTEGER, INTENT(in) :: count
2277 TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2278 INTEGER, INTENT(out) :: ierr
2279
2280 mpi_request_type, ALLOCATABLE, DIMENSION(:), TARGET :: request_handles
2281
2282 ALLOCATE (request_handles(count), source=array_of_requests(1:count)%handle)
2283 CALL mpi_waitall(count, request_handles, mpi_statuses_ignore, ierr)
2284 array_of_requests(1:count)%handle = request_handles(:)
2285 DEALLOCATE (request_handles)
2286
2287 END SUBROUTINE mpi_waitall_internal
2288#endif
2289
2290! **************************************************************************************************
2291!> \brief waits for completion of any of the given requests
2292!> \param requests ...
2293!> \param completed ...
2294!> \par History
2295!> 09.2008 created
2296!> \author Iain Bethune (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
2297! **************************************************************************************************
2298 SUBROUTINE mp_waitany(requests, completed)
2299 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2300 INTEGER, INTENT(out) :: completed
2301
2302 CHARACTER(len=*), PARAMETER :: routinen = 'mp_waitany'
2303
2304 INTEGER :: handle
2305#if defined(__parallel)
2306 INTEGER :: count, ierr
2307 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2308#endif
2309
2310 CALL mp_timeset(routinen, handle)
2311
2312#if defined(__parallel)
2313 count = SIZE(requests)
2314 ! Convert CP2K's request_handles to the plain handle for the library
2315 ALLOCATE (request_handles(count), source=requests(1:count)%handle)
2316
2317 CALL mpi_waitany(count, request_handles, completed, mpi_status_ignore, ierr)
2318 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitany @ mp_waitany")
2319
2320 ! Convert the plain handles to CP2K handles
2321 requests(1:count)%handle = request_handles(:)
2322 DEALLOCATE (request_handles)
2323 CALL add_perf(perf_id=9, count=1)
2324#else
2325 requests = mp_request_null
2326 completed = 1
2327#endif
2328 CALL mp_timestop(handle)
2329 END SUBROUTINE mp_waitany
2330
2331! **************************************************************************************************
2332!> \brief Tests for completion of the given requests.
2333!> \brief We use mpi_test so that we can use a single status.
2334!> \param requests the list of requests to test
2335!> \return logical which determines if requests are complete
2336!> \par History
2337!> 3.2016 adapted to any shape [Nico Holmberg]
2338!> \author Alfio Lazzaro
2339! **************************************************************************************************
2340 FUNCTION mp_testall_tv(requests) RESULT(flag)
2341 TYPE(mp_request_type), DIMENSION(:), INTENT(INOUT) :: requests
2342 LOGICAL :: flag
2343
2344#if defined(__parallel)
2345 INTEGER :: i, ierr
2346 LOGICAL, DIMENSION(:), POINTER :: flags
2347#endif
2348
2349 flag = .true.
2350
2351#if defined(__parallel)
2352 ALLOCATE (flags(SIZE(requests)))
2353 DO i = 1, SIZE(requests)
2354 CALL mpi_test(requests(i)%handle, flags(i), mpi_status_ignore, ierr)
2355 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testall @ mp_testall_tv")
2356 flag = flag .AND. flags(i)
2357 END DO
2358 DEALLOCATE (flags)
2359#else
2360 requests = mp_request_null
2361#endif
2362 END FUNCTION mp_testall_tv
2363
2364! **************************************************************************************************
2365!> \brief Tests for completion of the given request.
2366!> \param request the request
2367!> \param flag logical which determines if the request is completed
2368!> \par History
2369!> 3.2016 created
2370!> \author Nico Holmberg
2371! **************************************************************************************************
2372 FUNCTION mp_test_1(request) RESULT(flag)
2373 CLASS(mp_request_type), INTENT(inout) :: request
2374 LOGICAL :: flag
2375
2376#if defined(__parallel)
2377 INTEGER :: ierr
2378
2379 CALL mpi_test(request%handle, flag, mpi_status_ignore, ierr)
2380 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_test @ mp_test_1")
2381#else
2382 mark_used(request)
2383 flag = .true.
2384#endif
2385 END FUNCTION mp_test_1
2386
2387! **************************************************************************************************
2388!> \brief tests for completion of the given requests
2389!> \param requests ...
2390!> \param completed ...
2391!> \param flag ...
2392!> \par History
2393!> 08.2011 created
2394!> \author Iain Bethune
2395! **************************************************************************************************
2396 SUBROUTINE mp_testany_1(requests, completed, flag)
2397 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2398 INTEGER, INTENT(out), OPTIONAL :: completed
2399 LOGICAL, INTENT(out), OPTIONAL :: flag
2400
2401#if defined(__parallel)
2402 INTEGER :: completed_l, count, ierr
2403 LOGICAL :: flag_l
2404
2405 count = SIZE(requests)
2406
2407 CALL mpi_testany_internal(count, requests, completed_l, flag_l, mpi_status_ignore, ierr)
2408 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_1 @ mp_testany")
2409
2410 IF (PRESENT(completed)) completed = completed_l
2411 IF (PRESENT(flag)) flag = flag_l
2412#else
2413 mark_used(requests)
2414 IF (PRESENT(completed)) completed = 1
2415 IF (PRESENT(flag)) flag = .true.
2416#endif
2417 END SUBROUTINE mp_testany_1
2418
2419! **************************************************************************************************
2420!> \brief tests for completion of the given requests
2421!> \param requests ...
2422!> \param completed ...
2423!> \param flag ...
2424!> \par History
2425!> 08.2011 created
2426!> \author Iain Bethune
2427! **************************************************************************************************
2428 SUBROUTINE mp_testany_2(requests, completed, flag)
2429 TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2430 INTEGER, INTENT(out), OPTIONAL :: completed
2431 LOGICAL, INTENT(out), OPTIONAL :: flag
2432
2433#if defined(__parallel)
2434 INTEGER :: completed_l, count, ierr
2435 LOGICAL :: flag_l
2436
2437 count = SIZE(requests)
2438
2439 CALL mpi_testany_internal(count, requests, completed_l, flag_l, mpi_status_ignore, ierr)
2440 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_2 @ mp_testany")
2441
2442 IF (PRESENT(completed)) completed = completed_l
2443 IF (PRESENT(flag)) flag = flag_l
2444#else
2445 mark_used(requests)
2446 IF (PRESENT(completed)) completed = 1
2447 IF (PRESENT(flag)) flag = .true.
2448#endif
2449 END SUBROUTINE mp_testany_2
2450
2451! **************************************************************************************************
2452!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2453!> the issue is with the rank or requests
2454!> \param count ...
2455!> \param array_of_requests ...
2456!> \param index ...
2457!> \param flag ...
2458!> \param status ...
2459!> \param ierr ...
2460!> \author Joost VandeVondele
2461! **************************************************************************************************
2462#if defined(__parallel)
2463 SUBROUTINE mpi_testany_internal(count, array_of_requests, index, flag, status, ierr)
2464 INTEGER, INTENT(in) :: count
2465 TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2466 INTEGER, INTENT(out) :: index
2467 LOGICAL, INTENT(out) :: flag
2468 mpi_status_type, INTENT(out) :: status
2469 INTEGER, INTENT(out) :: ierr
2470
2471 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2472
2473 ALLOCATE (request_handles(count), source=array_of_requests(1:count)%handle)
2474 CALL mpi_testany(count, request_handles, index, flag, status, ierr)
2475 array_of_requests(1:count)%handle = request_handles(:)
2476 DEALLOCATE (request_handles)
2477
2478 END SUBROUTINE mpi_testany_internal
2479#endif
2480
2481! **************************************************************************************************
2482!> \brief the direct way to split a communicator each color is a sub_comm,
2483!> the rank order is according to the order in the orig comm
2484!> \param comm ...
2485!> \param sub_comm ...
2486!> \param color ...
2487!> \param key ...
2488!> \author Joost VandeVondele
2489! **************************************************************************************************
2490 SUBROUTINE mp_comm_split_direct(comm, sub_comm, color, key)
2491 CLASS(mp_comm_type), INTENT(in) :: comm
2492 CLASS(mp_comm_type), INTENT(OUT) :: sub_comm
2493 INTEGER, INTENT(in) :: color
2494 INTEGER, INTENT(in), OPTIONAL :: key
2495
2496 CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_split_direct'
2497
2498 INTEGER :: handle
2499#if defined(__parallel)
2500 INTEGER :: ierr, my_key
2501#endif
2502
2503 CALL mp_timeset(routinen, handle)
2504
2505#if defined(__parallel)
2506 my_key = 0
2507 IF (PRESENT(key)) my_key = key
2508 CALL mpi_comm_split(comm%handle, color, my_key, sub_comm%handle, ierr)
2509 IF (ierr /= mpi_success) CALL mp_stop(ierr, routinen)
2510 CALL add_perf(perf_id=10, count=1)
2511#else
2512 sub_comm%handle = mp_comm_default_handle
2513 mark_used(comm)
2514 mark_used(color)
2515 mark_used(key)
2516#endif
2517 debug_comm_count = debug_comm_count + 1
2518 CALL sub_comm%init()
2519 CALL mp_timestop(handle)
2520
2521 END SUBROUTINE mp_comm_split_direct
2522! **************************************************************************************************
2523!> \brief splits the given communicator in group in subgroups trying to organize
2524!> them in a way that the communication within each subgroup is
2525!> efficient (but not necessarily the communication between subgroups)
2526!> \param comm the mpi communicator that you want to split
2527!> \param sub_comm the communicator for the subgroup (created, needs to be freed later)
2528!> \param ngroups actual number of groups
2529!> \param group_distribution input : allocated with array with the nprocs entries (0 .. nprocs-1)
2530!> \param subgroup_min_size the minimum size of the subgroup
2531!> \param n_subgroups the number of subgroups wanted
2532!> \param group_partition n_subgroups sized array containing the number of cpus wanted per group.
2533!> should match the total number of cpus (only used if present and associated) (0..ngroups-1)
2534!> \param stride create groups using a stride (default=1) through the ranks of the comm to be split.
2535!> \par History
2536!> 10.2003 created [fawzi]
2537!> 02.2004 modified [Joost VandeVondele]
2538!> \author Fawzi Mohamed
2539!> \note
2540!> at least one of subgroup_min_size and n_subgroups is needed,
2541!> the other default to the value needed to use most processors.
2542!> if less cpus are present than needed for subgroup min size, n_subgroups,
2543!> just one comm is created that contains all cpus
2544! **************************************************************************************************
2545 SUBROUTINE mp_comm_split(comm, sub_comm, ngroups, group_distribution, &
2546 subgroup_min_size, n_subgroups, group_partition, stride)
2547 CLASS(mp_comm_type), INTENT(in) :: comm
2548 CLASS(mp_comm_type), INTENT(out) :: sub_comm
2549 INTEGER, INTENT(out) :: ngroups
2550 INTEGER, DIMENSION(0:), INTENT(INOUT) :: group_distribution
2551 INTEGER, INTENT(in), OPTIONAL :: subgroup_min_size, &
2552 n_subgroups
2553 INTEGER, DIMENSION(0:), INTENT(IN), OPTIONAL :: group_partition
2554 INTEGER, OPTIONAL, INTENT(IN) :: stride
2555
2556 CHARACTER(LEN=*), PARAMETER :: routineN = 'mp_comm_split', &
2557 routinep = modulen//':'//routinen
2558
2559 INTEGER :: handle, mepos, nnodes
2560#if defined(__parallel)
2561 INTEGER :: color, i, ierr, j, k, &
2562 my_subgroup_min_size, &
2563 istride, local_stride, irank
2564 INTEGER, DIMENSION(:), ALLOCATABLE :: rank_permutation
2565#endif
2566
2567 CALL mp_timeset(routinen, handle)
2568
2569 ! actual number of groups
2570
2571 IF (.NOT. PRESENT(subgroup_min_size) .AND. .NOT. PRESENT(n_subgroups)) THEN
2572 cpabort(routinep//" missing arguments")
2573 END IF
2574 IF (PRESENT(subgroup_min_size) .AND. PRESENT(n_subgroups)) THEN
2575 cpabort(routinep//" too many arguments")
2576 END IF
2577
2578 CALL comm%get_size(nnodes)
2579 CALL comm%get_rank(mepos)
2580
2581 IF (ubound(group_distribution, 1) /= nnodes - 1) THEN
2582 cpabort(routinep//" group_distribution wrong bounds")
2583 END IF
2584
2585#if defined(__parallel)
2586 IF (PRESENT(subgroup_min_size)) THEN
2587 IF (subgroup_min_size < 0 .OR. subgroup_min_size > nnodes) THEN
2588 cpabort(routinep//" subgroup_min_size too small or too large")
2589 END IF
2590 ngroups = nnodes/subgroup_min_size
2591 my_subgroup_min_size = subgroup_min_size
2592 ELSE ! n_subgroups
2593 IF (n_subgroups <= 0) THEN
2594 cpabort(routinep//" n_subgroups too small")
2595 END IF
2596 IF (nnodes/n_subgroups > 0) THEN ! we have a least one cpu per group
2597 ngroups = n_subgroups
2598 ELSE ! well, only one group then
2599 ngroups = 1
2600 END IF
2601 my_subgroup_min_size = nnodes/ngroups
2602 END IF
2603
2604 ! rank_permutation: is a permutation of ranks, so that groups are not necessarily continuous in rank of the master group
2605 ! 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
2606 ! (by setting stride equal to the number of mpi ranks per node), or by sharing a node between two groups (stride 2).
2607 ALLOCATE (rank_permutation(0:nnodes - 1))
2608 local_stride = 1
2609 IF (PRESENT(stride)) local_stride = stride
2610 k = 0
2611 DO istride = 1, local_stride
2612 DO irank = istride - 1, nnodes - 1, local_stride
2613 rank_permutation(k) = irank
2614 k = k + 1
2615 END DO
2616 END DO
2617
2618 DO i = 0, nnodes - 1
2619 group_distribution(rank_permutation(i)) = min(i/my_subgroup_min_size, ngroups - 1)
2620 END DO
2621 ! even the user gave a partition, see if we can use it to overwrite this choice
2622 IF (PRESENT(group_partition)) THEN
2623 IF (all(group_partition > 0) .AND. (sum(group_partition) == nnodes) .AND. (ngroups == SIZE(group_partition))) THEN
2624 k = 0
2625 DO i = 0, SIZE(group_partition) - 1
2626 DO j = 1, group_partition(i)
2627 group_distribution(rank_permutation(k)) = i
2628 k = k + 1
2629 END DO
2630 END DO
2631 ELSE
2632 ! just ignore silently as we have reasonable defaults. Probably a warning would not be to bad
2633 END IF
2634 END IF
2635 DEALLOCATE (rank_permutation)
2636 color = group_distribution(mepos)
2637 CALL mpi_comm_split(comm%handle, color, 0, sub_comm%handle, ierr)
2638 IF (ierr /= mpi_success) CALL mp_stop(ierr, "in "//routinep//" split")
2639
2640 CALL add_perf(perf_id=10, count=1)
2641#else
2642 sub_comm%handle = mp_comm_default_handle
2643 group_distribution(0) = 0
2644 ngroups = 1
2645 mark_used(comm)
2646 mark_used(stride)
2647 mark_used(group_partition)
2648#endif
2649 debug_comm_count = debug_comm_count + 1
2650 CALL sub_comm%init()
2651 CALL mp_timestop(handle)
2652
2653 END SUBROUTINE mp_comm_split
2654
2655! **************************************************************************************************
2656!> \brief probes for an incoming message with any tag
2657!> \param[inout] source the source of the possible incoming message,
2658!> if MP_ANY_SOURCE it is a blocking one and return value is the source
2659!> of the next incoming message
2660!> if source is a different value it is a non-blocking probe returning
2661!> MP_ANY_SOURCE if there is no incoming message
2662!> \param[in] comm the communicator
2663!> \param[out] tag the tag of the incoming message
2664!> \author Mandes
2665! **************************************************************************************************
2666 SUBROUTINE mp_probe(source, comm, tag)
2667 INTEGER, INTENT(INOUT) :: source
2668 CLASS(mp_comm_type), INTENT(IN) :: comm
2669 INTEGER, INTENT(OUT) :: tag
2670
2671 CHARACTER(len=*), PARAMETER :: routineN = 'mp_probe'
2672
2673 INTEGER :: handle
2674#if defined(__parallel)
2675 INTEGER :: ierr
2676 mpi_status_type :: status_single
2677 LOGICAL :: flag
2678#endif
2679
2680! ---------------------------------------------------------------------------
2681
2682 CALL mp_timeset(routinen, handle)
2683
2684#if defined(__parallel)
2685 IF (source == mp_any_source) THEN
2686 CALL mpi_probe(mp_any_source, mp_any_tag, comm%handle, status_single, ierr)
2687 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_probe @ mp_probe")
2688 source = status_single mpi_status_extract(mpi_source)
2689 tag = status_single mpi_status_extract(mpi_tag)
2690 ELSE
2691 flag = .false.
2692 CALL mpi_iprobe(source, mp_any_tag, comm%handle, flag, status_single, ierr)
2693 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iprobe @ mp_probe")
2694 IF (flag .EQV. .false.) THEN
2695 source = mp_any_source
2696 tag = -1 !status_single(MPI_TAG) ! in case of flag==false status is undefined
2697 ELSE
2698 tag = status_single mpi_status_extract(mpi_tag)
2699 END IF
2700 END IF
2701#else
2702 tag = -1
2703 mark_used(comm)
2704 mark_used(source)
2705#endif
2706 CALL mp_timestop(handle)
2707 END SUBROUTINE mp_probe
2708
2709! **************************************************************************************************
2710! Here come the data routines with none of the standard data types.
2711! **************************************************************************************************
2712
2713! **************************************************************************************************
2714!> \brief ...
2715!> \param msg ...
2716!> \param source ...
2717!> \param comm ...
2718! **************************************************************************************************
2719 SUBROUTINE mp_bcast_b(msg, source, comm)
2720 LOGICAL, INTENT(INOUT) :: msg
2721 INTEGER, INTENT(IN) :: source
2722 CLASS(mp_comm_type), INTENT(IN) :: comm
2723
2724 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b'
2725
2726 INTEGER :: handle
2727#if defined(__parallel)
2728 INTEGER :: ierr, msglen
2729#endif
2730
2731 CALL mp_timeset(routinen, handle)
2732
2733#if defined(__parallel)
2734 msglen = 1
2735 CALL mpi_bcast(msg, msglen, mpi_logical, source, comm%handle, ierr)
2736 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2737 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2738#else
2739 mark_used(msg)
2740 mark_used(source)
2741 mark_used(comm)
2742#endif
2743 CALL mp_timestop(handle)
2744 END SUBROUTINE mp_bcast_b
2745
2746! **************************************************************************************************
2747!> \brief ...
2748!> \param msg ...
2749!> \param source ...
2750!> \param comm ...
2751! **************************************************************************************************
2752 SUBROUTINE mp_bcast_b_src(msg, comm)
2753 LOGICAL, INTENT(INOUT) :: msg
2754 CLASS(mp_comm_type), INTENT(IN) :: comm
2755
2756 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b_src'
2757
2758 INTEGER :: handle
2759#if defined(__parallel)
2760 INTEGER :: ierr, msglen
2761#endif
2762
2763 CALL mp_timeset(routinen, handle)
2764
2765#if defined(__parallel)
2766 msglen = 1
2767 CALL mpi_bcast(msg, msglen, mpi_logical, comm%source, comm%handle, ierr)
2768 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2769 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2770#else
2771 mark_used(msg)
2772 mark_used(comm)
2773#endif
2774 CALL mp_timestop(handle)
2775 END SUBROUTINE mp_bcast_b_src
2776
2777! **************************************************************************************************
2778!> \brief ...
2779!> \param msg ...
2780!> \param source ...
2781!> \param comm ...
2782! **************************************************************************************************
2783 SUBROUTINE mp_bcast_bv(msg, source, comm)
2784 LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2785 INTEGER, INTENT(IN) :: source
2786 CLASS(mp_comm_type), INTENT(IN) :: comm
2787
2788 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv'
2789
2790 INTEGER :: handle
2791#if defined(__parallel)
2792 INTEGER :: ierr, msglen
2793#endif
2794
2795 CALL mp_timeset(routinen, handle)
2796
2797#if defined(__parallel)
2798 msglen = SIZE(msg)
2799 CALL mpi_bcast(msg, msglen, mpi_logical, source, comm%handle, ierr)
2800 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2801 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2802#else
2803 mark_used(msg)
2804 mark_used(source)
2805 mark_used(comm)
2806#endif
2807 CALL mp_timestop(handle)
2808 END SUBROUTINE mp_bcast_bv
2809
2810! **************************************************************************************************
2811!> \brief ...
2812!> \param msg ...
2813!> \param comm ...
2814! **************************************************************************************************
2815 SUBROUTINE mp_bcast_bv_src(msg, comm)
2816 LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2817 CLASS(mp_comm_type), INTENT(IN) :: comm
2818
2819 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv_src'
2820
2821 INTEGER :: handle
2822#if defined(__parallel)
2823 INTEGER :: ierr, msglen
2824#endif
2825
2826 CALL mp_timeset(routinen, handle)
2827
2828#if defined(__parallel)
2829 msglen = SIZE(msg)
2830 CALL mpi_bcast(msg, msglen, mpi_logical, comm%source, comm%handle, ierr)
2831 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2832 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2833#else
2834 mark_used(msg)
2835 mark_used(comm)
2836#endif
2837 CALL mp_timestop(handle)
2838 END SUBROUTINE mp_bcast_bv_src
2839
2840! **************************************************************************************************
2841!> \brief Non-blocking send of logical vector data
2842!> \param msgin the input message
2843!> \param dest the destination processor
2844!> \param comm the communicator object
2845!> \param request communication request index
2846!> \param tag message tag
2847!> \par History
2848!> 3.2016 added _bv subroutine [Nico Holmberg]
2849!> \author fawzi
2850!> \note see mp_irecv_iv
2851!> \note
2852!> arrays can be pointers or assumed shape, but they must be contiguous!
2853! **************************************************************************************************
2854 SUBROUTINE mp_isend_bv(msgin, dest, comm, request, tag)
2855 LOGICAL, DIMENSION(:), INTENT(IN) :: msgin
2856 INTEGER, INTENT(IN) :: dest
2857 CLASS(mp_comm_type), INTENT(IN) :: comm
2858 TYPE(mp_request_type), INTENT(out) :: request
2859 INTEGER, INTENT(in), OPTIONAL :: tag
2860
2861 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bv'
2862
2863 INTEGER :: handle
2864#if defined(__parallel)
2865 INTEGER :: ierr, msglen, my_tag
2866 LOGICAL :: foo(1)
2867#endif
2868
2869 CALL mp_timeset(routinen, handle)
2870
2871#if defined(__parallel)
2872#if !defined(__GNUC__) || __GNUC__ >= 9
2873 cpassert(is_contiguous(msgin) .OR. product(shape(msgin)) == 0)
2874#endif
2875
2876 my_tag = 0
2877 IF (PRESENT(tag)) my_tag = tag
2878
2879 msglen = SIZE(msgin, 1)
2880 IF (msglen > 0) THEN
2881 CALL mpi_isend(msgin(1), msglen, mpi_logical, dest, my_tag, &
2882 comm%handle, request%handle, ierr)
2883 ELSE
2884 CALL mpi_isend(foo, msglen, mpi_logical, dest, my_tag, &
2885 comm%handle, request%handle, ierr)
2886 END IF
2887 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
2888
2889 CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2890#else
2891 cpabort("mp_isend called in non parallel case")
2892 mark_used(msgin)
2893 mark_used(dest)
2894 mark_used(comm)
2895 mark_used(tag)
2896 request = mp_request_null
2897#endif
2898 CALL mp_timestop(handle)
2899 END SUBROUTINE mp_isend_bv
2900
2901! **************************************************************************************************
2902!> \brief Non-blocking receive of logical vector data
2903!> \param msgout the received message
2904!> \param source the source processor
2905!> \param comm the communicator object
2906!> \param request communication request index
2907!> \param tag message tag
2908!> \par History
2909!> 3.2016 added _bv subroutine [Nico Holmberg]
2910!> \author fawzi
2911!> \note see mp_irecv_iv
2912!> \note
2913!> arrays can be pointers or assumed shape, but they must be contiguous!
2914! **************************************************************************************************
2915 SUBROUTINE mp_irecv_bv(msgout, source, comm, request, tag)
2916 LOGICAL, DIMENSION(:), INTENT(INOUT) :: msgout
2917 INTEGER, INTENT(IN) :: source
2918 CLASS(mp_comm_type), INTENT(IN) :: comm
2919 TYPE(mp_request_type), INTENT(out) :: request
2920 INTEGER, INTENT(in), OPTIONAL :: tag
2921
2922 CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bv'
2923
2924 INTEGER :: handle
2925#if defined(__parallel)
2926 INTEGER :: ierr, msglen, my_tag
2927 LOGICAL :: foo(1)
2928#endif
2929
2930 CALL mp_timeset(routinen, handle)
2931
2932#if defined(__parallel)
2933#if !defined(__GNUC__) || __GNUC__ >= 9
2934 cpassert(is_contiguous(msgout) .OR. product(shape(msgout)) == 0)
2935#endif
2936
2937 my_tag = 0
2938 IF (PRESENT(tag)) my_tag = tag
2939
2940 msglen = SIZE(msgout, 1)
2941 IF (msglen > 0) THEN
2942 CALL mpi_irecv(msgout(1), msglen, mpi_logical, source, my_tag, &
2943 comm%handle, request%handle, ierr)
2944 ELSE
2945 CALL mpi_irecv(foo, msglen, mpi_logical, source, my_tag, &
2946 comm%handle, request%handle, ierr)
2947 END IF
2948 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
2949
2950 CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
2951#else
2952 cpabort("mp_irecv called in non parallel case")
2953 mark_used(msgout)
2954 mark_used(source)
2955 mark_used(comm)
2956 mark_used(tag)
2957 request = mp_request_null
2958#endif
2959 CALL mp_timestop(handle)
2960 END SUBROUTINE mp_irecv_bv
2961
2962! **************************************************************************************************
2963!> \brief Non-blocking send of rank-3 logical data
2964!> \param msgin the input message
2965!> \param dest the destination processor
2966!> \param comm the communicator object
2967!> \param request communication request index
2968!> \param tag message tag
2969!> \par History
2970!> 2.2016 added _bm3 subroutine [Nico Holmberg]
2971!> \author fawzi
2972!> \note see mp_irecv_iv
2973!> \note
2974!> arrays can be pointers or assumed shape, but they must be contiguous!
2975! **************************************************************************************************
2976 SUBROUTINE mp_isend_bm3(msgin, dest, comm, request, tag)
2977 LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgin
2978 INTEGER, INTENT(IN) :: dest
2979 CLASS(mp_comm_type), INTENT(IN) :: comm
2980 TYPE(mp_request_type), INTENT(out) :: request
2981 INTEGER, INTENT(in), OPTIONAL :: tag
2982
2983 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bm3'
2984
2985 INTEGER :: handle
2986#if defined(__parallel)
2987 INTEGER :: ierr, msglen, my_tag
2988 LOGICAL :: foo(1)
2989#endif
2990
2991 CALL mp_timeset(routinen, handle)
2992
2993#if defined(__parallel)
2994#if !defined(__GNUC__) || __GNUC__ >= 9
2995 cpassert(is_contiguous(msgin) .OR. product(shape(msgin)) == 0)
2996#endif
2997
2998 my_tag = 0
2999 IF (PRESENT(tag)) my_tag = tag
3000
3001 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
3002 IF (msglen > 0) THEN
3003 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_logical, dest, my_tag, &
3004 comm%handle, request%handle, ierr)
3005 ELSE
3006 CALL mpi_isend(foo, msglen, mpi_logical, dest, my_tag, &
3007 comm%handle, request%handle, ierr)
3008 END IF
3009 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
3010
3011 CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
3012#else
3013 cpabort("mp_isend called in non parallel case")
3014 mark_used(msgin)
3015 mark_used(dest)
3016 mark_used(comm)
3017 mark_used(tag)
3018 request = mp_request_null
3019#endif
3020 CALL mp_timestop(handle)
3021 END SUBROUTINE mp_isend_bm3
3022
3023! **************************************************************************************************
3024!> \brief Non-blocking receive of rank-3 logical data
3025!> \param msgout the received message
3026!> \param source the source processor
3027!> \param comm the communicator object
3028!> \param request communication request index
3029!> \param tag message tag
3030!> \par History
3031!> 2.2016 added _bm3 subroutine [Nico Holmberg]
3032!> \author fawzi
3033!> \note see mp_irecv_iv
3034!> \note
3035!> arrays can be pointers or assumed shape, but they must be contiguous!
3036! **************************************************************************************************
3037 SUBROUTINE mp_irecv_bm3(msgout, source, comm, request, tag)
3038 LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgout
3039 INTEGER, INTENT(IN) :: source
3040 CLASS(mp_comm_type), INTENT(IN) :: comm
3041 TYPE(mp_request_type), INTENT(out) :: request
3042 INTEGER, INTENT(in), OPTIONAL :: tag
3043
3044 CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bm3'
3045
3046 INTEGER :: handle
3047#if defined(__parallel)
3048 INTEGER :: ierr, msglen, my_tag
3049 LOGICAL :: foo(1)
3050#endif
3051
3052 CALL mp_timeset(routinen, handle)
3053
3054#if defined(__parallel)
3055#if !defined(__GNUC__) || __GNUC__ >= 9
3056 cpassert(is_contiguous(msgout) .OR. product(shape(msgout)) == 0)
3057#endif
3058
3059 my_tag = 0
3060 IF (PRESENT(tag)) my_tag = tag
3061
3062 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
3063 IF (msglen > 0) THEN
3064 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_logical, source, my_tag, &
3065 comm%handle, request%handle, ierr)
3066 ELSE
3067 CALL mpi_irecv(foo, msglen, mpi_logical, source, my_tag, &
3068 comm%handle, request%handle, ierr)
3069 END IF
3070 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
3071
3072 CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
3073#else
3074 cpabort("mp_irecv called in non parallel case")
3075 mark_used(msgout)
3076 mark_used(source)
3077 mark_used(comm)
3078 mark_used(request)
3079 mark_used(tag)
3080 request = mp_request_null
3081#endif
3082 CALL mp_timestop(handle)
3083 END SUBROUTINE mp_irecv_bm3
3084
3085! **************************************************************************************************
3086!> \brief Broadcasts a string.
3087!> \param msg ...
3088!> \param source ...
3089!> \param comm ...
3090! **************************************************************************************************
3091 SUBROUTINE mp_bcast_av(msg, source, comm)
3092 CHARACTER(LEN=*), INTENT(INOUT) :: msg
3093 INTEGER, INTENT(IN) :: source
3094 CLASS(mp_comm_type), INTENT(IN) :: comm
3095
3096 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av'
3097
3098 INTEGER :: handle
3099#if defined(__parallel)
3100 INTEGER :: ierr, msglen
3101#endif
3102
3103 CALL mp_timeset(routinen, handle)
3104
3105#if defined(__parallel)
3106 msglen = len(msg)*charlen
3107 IF (comm%mepos /= source) msg = "" ! need to clear msg
3108 CALL mpi_bcast(msg, msglen, mpi_character, source, comm%handle, ierr)
3109 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3110 CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3111#else
3112 mark_used(msg)
3113 mark_used(source)
3114 mark_used(comm)
3115#endif
3116 CALL mp_timestop(handle)
3117 END SUBROUTINE mp_bcast_av
3118
3119! **************************************************************************************************
3120!> \brief Broadcasts a string.
3121!> \param msg ...
3122!> \param comm ...
3123! **************************************************************************************************
3124 SUBROUTINE mp_bcast_av_src(msg, comm)
3125 CHARACTER(LEN=*), INTENT(INOUT) :: msg
3126 CLASS(mp_comm_type), INTENT(IN) :: comm
3127
3128 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av_src'
3129
3130 INTEGER :: handle
3131#if defined(__parallel)
3132 INTEGER :: ierr, msglen
3133#endif
3134
3135 CALL mp_timeset(routinen, handle)
3136
3137#if defined(__parallel)
3138 msglen = len(msg)*charlen
3139 IF (.NOT. comm%is_source()) msg = "" ! need to clear msg
3140 CALL mpi_bcast(msg, msglen, mpi_character, comm%source, comm%handle, ierr)
3141 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3142 CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3143#else
3144 mark_used(msg)
3145 mark_used(comm)
3146#endif
3147 CALL mp_timestop(handle)
3148 END SUBROUTINE mp_bcast_av_src
3149
3150! **************************************************************************************************
3151!> \brief ...
3152!> \param msg ...
3153!> \param source ...
3154!> \param comm ...
3155! **************************************************************************************************
3156 SUBROUTINE mp_bcast_am(msg, source, comm)
3157 CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3158 INTEGER, INTENT(IN) :: source
3159 CLASS(mp_comm_type), INTENT(IN) :: comm
3160
3161 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am'
3162
3163 INTEGER :: handle
3164#if defined(__parallel)
3165 INTEGER :: ierr, msglen
3166#endif
3167
3168 CALL mp_timeset(routinen, handle)
3169
3170#if defined(__parallel)
3171 msglen = SIZE(msg)*len(msg(1))*charlen
3172 IF (comm%mepos /= source) msg = "" ! need to clear msg
3173 CALL mpi_bcast(msg, msglen, mpi_character, source, comm%handle, ierr)
3174 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3175 CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3176#else
3177 mark_used(msg)
3178 mark_used(source)
3179 mark_used(comm)
3180#endif
3181 CALL mp_timestop(handle)
3182 END SUBROUTINE mp_bcast_am
3183
3184 SUBROUTINE mp_bcast_am_src(msg, comm)
3185 CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3186 CLASS(mp_comm_type), INTENT(IN) :: comm
3187
3188 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am_src'
3189
3190 INTEGER :: handle
3191#if defined(__parallel)
3192 INTEGER :: ierr, msglen
3193#endif
3194
3195 CALL mp_timeset(routinen, handle)
3196
3197#if defined(__parallel)
3198 msglen = SIZE(msg)*len(msg(1))*charlen
3199 IF (.NOT. comm%is_source()) msg = "" ! need to clear msg
3200 CALL mpi_bcast(msg, msglen, mpi_character, comm%source, comm%handle, ierr)
3201 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3202 CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3203#else
3204 mark_used(msg)
3205 mark_used(comm)
3206#endif
3207 CALL mp_timestop(handle)
3208 END SUBROUTINE mp_bcast_am_src
3209
3210! **************************************************************************************************
3211!> \brief Finds the location of the minimal element in a vector.
3212!> \param[in,out] msg Find location of minimum element among these
3213!> data (input).
3214!> \param[in] comm Message passing environment identifier
3215!> \par MPI mapping
3216!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3217!> \par Invalid data types
3218!> This routine is invalid for (int_8) data!
3219! **************************************************************************************************
3220 SUBROUTINE mp_minloc_dv(msg, comm)
3221 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3222 CLASS(mp_comm_type), INTENT(IN) :: comm
3223
3224 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_dv'
3225
3226 INTEGER :: handle
3227#if defined(__parallel)
3228 INTEGER :: ierr, msglen
3229 REAL(kind=real_8), ALLOCATABLE :: res(:)
3230#endif
3231
3232 IF ("d" == "l" .AND. real_8 == int_8) THEN
3233 cpabort("Minimal location not available with long integers @ "//routinen)
3234 END IF
3235 CALL mp_timeset(routinen, handle)
3236
3237#if defined(__parallel)
3238 msglen = SIZE(msg)
3239 ALLOCATE (res(1:msglen), stat=ierr)
3240 IF (ierr /= 0) &
3241 cpabort("allocate @ "//routinen)
3242 CALL mpi_allreduce(msg, res, msglen/2, mpi_2double_precision, mpi_minloc, comm%handle, ierr)
3243 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3244 msg = res
3245 DEALLOCATE (res)
3246 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3247#else
3248 mark_used(msg)
3249 mark_used(comm)
3250#endif
3251 CALL mp_timestop(handle)
3252 END SUBROUTINE mp_minloc_dv
3253
3254! **************************************************************************************************
3255!> \brief Finds the location of the minimal element in a vector.
3256!> \param[in,out] msg Find location of minimum element among these
3257!> data (input).
3258!> \param[in] comm Message passing environment identifier
3259!> \par MPI mapping
3260!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3261!> \par Invalid data types
3262!> This routine is invalid for (int_8) data!
3263! **************************************************************************************************
3264 SUBROUTINE mp_minloc_iv(msg, comm)
3265 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3266 CLASS(mp_comm_type), INTENT(IN) :: comm
3267
3268 CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_iv'
3269
3270 INTEGER :: handle
3271#if defined(__parallel)
3272 INTEGER :: ierr, msglen
3273 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3274#endif
3275
3276 IF ("i" == "l" .AND. int_4 == int_8) THEN
3277 cpabort("Minimal location not available with long integers @ "//routinen)
3278 END IF
3279 CALL mp_timeset(routinen, handle)
3280
3281#if defined(__parallel)
3282 msglen = SIZE(msg)
3283 ALLOCATE (res(1:msglen))
3284 CALL mpi_allreduce(msg, res, msglen/2, mpi_2integer, mpi_minloc, comm%handle, ierr)
3285 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3286 msg = res
3287 DEALLOCATE (res)
3288 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3289#else
3290 mark_used(msg)
3291 mark_used(comm)
3292#endif
3293 CALL mp_timestop(handle)
3294 END SUBROUTINE mp_minloc_iv
3295
3296! **************************************************************************************************
3297!> \brief Finds the location of the minimal element in a vector.
3298!> \param[in,out] msg Find location of minimum element among these
3299!> data (input).
3300!> \param[in] comm Message passing environment identifier
3301!> \par MPI mapping
3302!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3303!> \par Invalid data types
3304!> This routine is invalid for (int_8) data!
3305! **************************************************************************************************
3306 SUBROUTINE mp_minloc_lv(msg, comm)
3307 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3308 CLASS(mp_comm_type), INTENT(IN) :: comm
3309
3310 CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_lv'
3311
3312 INTEGER :: handle
3313#if defined(__parallel)
3314 INTEGER :: ierr, msglen
3315 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3316#endif
3317
3318 IF ("l" == "l" .AND. int_8 == int_8) THEN
3319 cpabort("Minimal location not available with long integers @ "//routinen)
3320 END IF
3321 CALL mp_timeset(routinen, handle)
3322
3323#if defined(__parallel)
3324 msglen = SIZE(msg)
3325 ALLOCATE (res(1:msglen))
3326 CALL mpi_allreduce(msg, res, msglen/2, mpi_integer8, mpi_minloc, comm%handle, ierr)
3327 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3328 msg = res
3329 DEALLOCATE (res)
3330 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3331#else
3332 mark_used(msg)
3333 mark_used(comm)
3334#endif
3335 CALL mp_timestop(handle)
3336 END SUBROUTINE mp_minloc_lv
3337
3338! **************************************************************************************************
3339!> \brief Finds the location of the minimal element in a vector.
3340!> \param[in,out] msg Find location of minimum element among these
3341!> data (input).
3342!> \param[in] comm Message passing environment identifier
3343!> \par MPI mapping
3344!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3345!> \par Invalid data types
3346!> This routine is invalid for (int_8) data!
3347! **************************************************************************************************
3348 SUBROUTINE mp_minloc_rv(msg, comm)
3349 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3350 CLASS(mp_comm_type), INTENT(IN) :: comm
3351
3352 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_rv'
3353
3354 INTEGER :: handle
3355#if defined(__parallel)
3356 INTEGER :: ierr, msglen
3357 REAL(kind=real_4), ALLOCATABLE :: res(:)
3358#endif
3359
3360 IF ("r" == "l" .AND. real_4 == int_8) THEN
3361 cpabort("Minimal location not available with long integers @ "//routinen)
3362 END IF
3363 CALL mp_timeset(routinen, handle)
3364
3365#if defined(__parallel)
3366 msglen = SIZE(msg)
3367 ALLOCATE (res(1:msglen))
3368 CALL mpi_allreduce(msg, res, msglen/2, mpi_2real, mpi_minloc, comm%handle, ierr)
3369 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3370 msg = res
3371 DEALLOCATE (res)
3372 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3373#else
3374 mark_used(msg)
3375 mark_used(comm)
3376#endif
3377 CALL mp_timestop(handle)
3378 END SUBROUTINE mp_minloc_rv
3379
3380! **************************************************************************************************
3381!> \brief Finds the location of the maximal element in a vector.
3382!> \param[in,out] msg Find location of maximum element among these
3383!> data (input).
3384!> \param[in] comm Message passing environment identifier
3385!> \par MPI mapping
3386!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3387!> \par Invalid data types
3388!> This routine is invalid for (int_8) data!
3389! **************************************************************************************************
3390 SUBROUTINE mp_maxloc_dv(msg, comm)
3391 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3392 CLASS(mp_comm_type), INTENT(IN) :: comm
3393
3394 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_dv'
3395
3396 INTEGER :: handle
3397#if defined(__parallel)
3398 INTEGER :: ierr, msglen
3399 REAL(kind=real_8), ALLOCATABLE :: res(:)
3400#endif
3401
3402 IF ("d" == "l" .AND. real_8 == int_8) THEN
3403 cpabort("Maximal location not available with long integers @ "//routinen)
3404 END IF
3405 CALL mp_timeset(routinen, handle)
3406
3407#if defined(__parallel)
3408 msglen = SIZE(msg)
3409 ALLOCATE (res(1:msglen))
3410 CALL mpi_allreduce(msg, res, msglen/2, mpi_2double_precision, mpi_maxloc, comm%handle, ierr)
3411 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3412 msg = res
3413 DEALLOCATE (res)
3414 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3415#else
3416 mark_used(msg)
3417 mark_used(comm)
3418#endif
3419 CALL mp_timestop(handle)
3420 END SUBROUTINE mp_maxloc_dv
3421
3422! **************************************************************************************************
3423!> \brief Finds the location of the maximal element in a vector.
3424!> \param[in,out] msg Find location of maximum element among these
3425!> data (input).
3426!> \param[in] comm Message passing environment identifier
3427!> \par MPI mapping
3428!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3429!> \par Invalid data types
3430!> This routine is invalid for (int_8) data!
3431! **************************************************************************************************
3432 SUBROUTINE mp_maxloc_iv(msg, comm)
3433 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3434 CLASS(mp_comm_type), INTENT(IN) :: comm
3435
3436 CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_iv'
3437
3438 INTEGER :: handle
3439#if defined(__parallel)
3440 INTEGER :: ierr, msglen
3441 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3442#endif
3443
3444 IF ("i" == "l" .AND. int_4 == int_8) THEN
3445 cpabort("Maximal location not available with long integers @ "//routinen)
3446 END IF
3447 CALL mp_timeset(routinen, handle)
3448
3449#if defined(__parallel)
3450 msglen = SIZE(msg)
3451 ALLOCATE (res(1:msglen))
3452 CALL mpi_allreduce(msg, res, msglen/2, mpi_2integer, mpi_maxloc, comm%handle, ierr)
3453 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3454 msg = res
3455 DEALLOCATE (res)
3456 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3457#else
3458 mark_used(msg)
3459 mark_used(comm)
3460#endif
3461 CALL mp_timestop(handle)
3462 END SUBROUTINE mp_maxloc_iv
3463
3464! **************************************************************************************************
3465!> \brief Finds the location of the maximal element in a vector.
3466!> \param[in,out] msg Find location of maximum element among these
3467!> data (input).
3468!> \param[in] comm Message passing environment identifier
3469!> \par MPI mapping
3470!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3471!> \par Invalid data types
3472!> This routine is invalid for (int_8) data!
3473! **************************************************************************************************
3474 SUBROUTINE mp_maxloc_lv(msg, comm)
3475 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3476 CLASS(mp_comm_type), INTENT(IN) :: comm
3477
3478 CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_lv'
3479
3480 INTEGER :: handle
3481#if defined(__parallel)
3482 INTEGER :: ierr, msglen
3483 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3484#endif
3485
3486 IF ("l" == "l" .AND. int_8 == int_8) THEN
3487 cpabort("Maximal location not available with long integers @ "//routinen)
3488 END IF
3489 CALL mp_timeset(routinen, handle)
3490
3491#if defined(__parallel)
3492 msglen = SIZE(msg)
3493 ALLOCATE (res(1:msglen))
3494 CALL mpi_allreduce(msg, res, msglen/2, mpi_integer8, mpi_maxloc, comm%handle, ierr)
3495 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3496 msg = res
3497 DEALLOCATE (res)
3498 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3499#else
3500 mark_used(msg)
3501 mark_used(comm)
3502#endif
3503 CALL mp_timestop(handle)
3504 END SUBROUTINE mp_maxloc_lv
3505
3506! **************************************************************************************************
3507!> \brief Finds the location of the maximal element in a vector.
3508!> \param[in,out] msg Find location of maximum element among these
3509!> data (input).
3510!> \param[in] comm Message passing environment identifier
3511!> \par MPI mapping
3512!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3513!> \par Invalid data types
3514!> This routine is invalid for (int_8) data!
3515! **************************************************************************************************
3516 SUBROUTINE mp_maxloc_rv(msg, comm)
3517 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3518 CLASS(mp_comm_type), INTENT(IN) :: comm
3519
3520 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_rv'
3521
3522 INTEGER :: handle
3523#if defined(__parallel)
3524 INTEGER :: ierr, msglen
3525 REAL(kind=real_4), ALLOCATABLE :: res(:)
3526#endif
3527
3528 IF ("r" == "l" .AND. real_4 == int_8) THEN
3529 cpabort("Maximal location not available with long integers @ "//routinen)
3530 END IF
3531 CALL mp_timeset(routinen, handle)
3532
3533#if defined(__parallel)
3534 msglen = SIZE(msg)
3535 ALLOCATE (res(1:msglen))
3536 CALL mpi_allreduce(msg, res, msglen/2, mpi_2real, mpi_maxloc, comm%handle, ierr)
3537 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3538 msg = res
3539 DEALLOCATE (res)
3540 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3541#else
3542 mark_used(msg)
3543 mark_used(comm)
3544#endif
3545 CALL mp_timestop(handle)
3546 END SUBROUTINE mp_maxloc_rv
3547
3548! **************************************************************************************************
3549!> \brief Logical OR reduction
3550!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3551!> and resultant inclusive disjunction (output)
3552!> \param[in] comm Message passing environment identifier
3553!> \par MPI mapping
3554!> mpi_allreduce
3555! **************************************************************************************************
3556 SUBROUTINE mp_sum_b(msg, comm)
3557 LOGICAL, INTENT(INOUT) :: msg
3558 CLASS(mp_comm_type), INTENT(IN) :: comm
3559
3560 CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_b'
3561
3562 INTEGER :: handle
3563#if defined(__parallel)
3564 INTEGER :: ierr, msglen
3565#endif
3566
3567 CALL mp_timeset(routinen, handle)
3568#if defined(__parallel)
3569 msglen = 1
3570 IF (comm%num_pe > 1) THEN
3571 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, ierr)
3572 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3573 END IF
3574#else
3575 mark_used(msg)
3576 mark_used(comm)
3577#endif
3578 CALL mp_timestop(handle)
3579 END SUBROUTINE mp_sum_b
3580
3581! **************************************************************************************************
3582!> \brief Logical OR reduction
3583!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3584!> and resultant inclusive disjunction (output)
3585!> \param[in] comm Message passing environment identifier
3586!> \par MPI mapping
3587!> mpi_allreduce
3588! **************************************************************************************************
3589 SUBROUTINE mp_sum_bv(msg, comm)
3590 LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: msg
3591 CLASS(mp_comm_type), INTENT(IN) :: comm
3592
3593 CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_bv'
3594
3595 INTEGER :: handle
3596#if defined(__parallel)
3597 INTEGER :: ierr, msglen
3598#endif
3599
3600 CALL mp_timeset(routinen, handle)
3601#if defined(__parallel)
3602 msglen = SIZE(msg)
3603 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
3604 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, ierr)
3605 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3606 END IF
3607#else
3608 mark_used(msg)
3609 mark_used(comm)
3610#endif
3611 CALL mp_timestop(handle)
3612 END SUBROUTINE mp_sum_bv
3613
3614! **************************************************************************************************
3615!> \brief Logical OR reduction
3616!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3617!> and resultant inclusive disjunction (output)
3618!> \param[in] comm Message passing environment identifier
3619!> \param request ...
3620!> \par MPI mapping
3621!> mpi_allreduce
3622! **************************************************************************************************
3623 SUBROUTINE mp_isum_bv(msg, comm, request)
3624 LOGICAL, DIMENSION(:), INTENT(INOUT) :: msg
3625 CLASS(mp_comm_type), INTENT(IN) :: comm
3626 TYPE(mp_request_type), INTENT(INOUT) :: request
3627
3628 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isum_bv'
3629
3630 INTEGER :: handle
3631#if defined(__parallel)
3632 INTEGER :: ierr, msglen
3633#endif
3634
3635 CALL mp_timeset(routinen, handle)
3636#if defined(__parallel)
3637 msglen = SIZE(msg)
3638#if !defined(__GNUC__) || __GNUC__ >= 9
3639 cpassert(is_contiguous(msg) .OR. product(shape(msg)) == 0)
3640#endif
3641
3642 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
3643 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, request%handle, ierr)
3644 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3645 ELSE
3646 request = mp_request_null
3647 END IF
3648#else
3649 mark_used(msg)
3650 mark_used(comm)
3651 request = mp_request_null
3652#endif
3653 CALL mp_timestop(handle)
3654 END SUBROUTINE mp_isum_bv
3655
3656! **************************************************************************************************
3657!> \brief Get Version of the MPI Library (MPI 3)
3658!> \param[out] version Version of the library,
3659!> declared as CHARACTER(LEN=mp_max_library_version_string)
3660!> \param[out] resultlen Length (in printable characters) of
3661!> the result returned in version (integer)
3662! **************************************************************************************************
3663 SUBROUTINE mp_get_library_version(version, resultlen)
3664 CHARACTER(len=*), INTENT(OUT) :: version
3665 INTEGER, INTENT(OUT) :: resultlen
3666
3667#if defined(__parallel)
3668 INTEGER :: ierr
3669#endif
3670
3671 version = ''
3672
3673#if defined(__parallel)
3674 ierr = 0
3675 CALL mpi_get_library_version(version, resultlen, ierr)
3676 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_get_library_version @ mp_get_library_version")
3677#else
3678 resultlen = 0
3679#endif
3680 END SUBROUTINE mp_get_library_version
3681
3682! **************************************************************************************************
3683!> \brief Opens a file
3684!> \param[in] groupid message passing environment identifier
3685!> \param[out] fh file handle (file storage unit)
3686!> \param[in] filepath path to the file
3687!> \param amode_status access mode
3688!> \param info ...
3689!> \par MPI-I/O mapping mpi_file_open
3690!> \par STREAM-I/O mapping OPEN
3691!>
3692!> \param[in](optional) info info object
3693!> \par History
3694!> 11.2012 created [Hossein Bani-Hashemian]
3695! **************************************************************************************************
3696 SUBROUTINE mp_file_open(groupid, fh, filepath, amode_status, info)
3697 CLASS(mp_comm_type), INTENT(IN) :: groupid
3698 CLASS(mp_file_type), INTENT(OUT) :: fh
3699 CHARACTER(len=*), INTENT(IN) :: filepath
3700 INTEGER, INTENT(IN) :: amode_status
3701 TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3702
3703#if defined(__parallel)
3704 INTEGER :: ierr
3705 mpi_info_type :: my_info
3706#else
3707 CHARACTER(LEN=10) :: fstatus, fposition
3708 INTEGER :: amode, handle, istat
3709 LOGICAL :: exists, is_open
3710#endif
3711
3712#if defined(__parallel)
3713 ierr = 0
3714 my_info = mpi_info_null
3715 IF (PRESENT(info)) my_info = info%handle
3716 CALL mpi_file_open(groupid%handle, filepath, amode_status, my_info, fh%handle, ierr)
3717 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3718 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open")
3719#else
3720 mark_used(groupid)
3721 mark_used(info)
3722 amode = amode_status
3723 IF (amode > file_amode_append) THEN
3724 fposition = "APPEND"
3725 amode = amode - file_amode_append
3726 ELSE
3727 fposition = "REWIND"
3728 END IF
3729 IF ((amode == file_amode_create) .OR. &
3730 (amode == file_amode_create + file_amode_wronly) .OR. &
3731 (amode == file_amode_create + file_amode_wronly + file_amode_excl)) THEN
3732 fstatus = "UNKNOWN"
3733 ELSE
3734 fstatus = "OLD"
3735 END IF
3736 ! Get a new unit number
3737 DO handle = 1, 999
3738 INQUIRE (unit=handle, exist=exists, opened=is_open, iostat=istat)
3739 IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) EXIT
3740 END DO
3741 OPEN (unit=handle, file=filepath, status=fstatus, access="STREAM", position=fposition)
3742 fh%handle = handle
3743#endif
3744 END SUBROUTINE mp_file_open
3745
3746! **************************************************************************************************
3747!> \brief Deletes a file. Auxiliary routine to emulate 'replace' action for mp_file_open.
3748!> Only the master processor should call this routine.
3749!> \param[in] filepath path to the file
3750!> \param[in](optional) info info object
3751!> \par History
3752!> 11.2017 created [Nico Holmberg]
3753! **************************************************************************************************
3754 SUBROUTINE mp_file_delete(filepath, info)
3755 CHARACTER(len=*), INTENT(IN) :: filepath
3756 TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3757
3758#if defined(__parallel)
3759 INTEGER :: ierr
3760 mpi_info_type :: my_info
3761 LOGICAL :: exists
3762
3763 ierr = 0
3764 my_info = mpi_info_null
3765 IF (PRESENT(info)) my_info = info%handle
3766 INQUIRE (file=filepath, exist=exists)
3767 IF (exists) CALL mpi_file_delete(filepath, my_info, ierr)
3768 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete")
3769#else
3770 mark_used(filepath)
3771 mark_used(info)
3772 ! Explicit file delete not necessary, handled by subsequent call to open_file with action 'replace'
3773#endif
3774
3775 END SUBROUTINE mp_file_delete
3776
3777! **************************************************************************************************
3778!> \brief Closes a file
3779!> \param[in] fh file handle (file storage unit)
3780!> \par MPI-I/O mapping mpi_file_close
3781!> \par STREAM-I/O mapping CLOSE
3782!>
3783!> \par History
3784!> 11.2012 created [Hossein Bani-Hashemian]
3785! **************************************************************************************************
3786 SUBROUTINE mp_file_close(fh)
3787 CLASS(mp_file_type), INTENT(INOUT) :: fh
3788
3789#if defined(__parallel)
3790 INTEGER :: ierr
3791
3792 ierr = 0
3793 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3794 CALL mpi_file_close(fh%handle, ierr)
3795 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close")
3796#else
3797 CLOSE (fh%handle)
3798 fh%handle = mp_file_null_handle
3799#endif
3800 END SUBROUTINE mp_file_close
3801
3802 SUBROUTINE mp_file_assign(fh_new, fh_old)
3803 CLASS(mp_file_type), INTENT(OUT) :: fh_new
3804 CLASS(mp_file_type), INTENT(IN) :: fh_old
3805
3806 fh_new%handle = fh_old%handle
3807
3808 END SUBROUTINE
3809
3810! **************************************************************************************************
3811!> \brief Returns the file size
3812!> \param[in] fh file handle (file storage unit)
3813!> \param[out] file_size the file size
3814!> \par MPI-I/O mapping mpi_file_get_size
3815!> \par STREAM-I/O mapping INQUIRE
3816!>
3817!> \par History
3818!> 12.2012 created [Hossein Bani-Hashemian]
3819! **************************************************************************************************
3820 SUBROUTINE mp_file_get_size(fh, file_size)
3821 CLASS(mp_file_type), INTENT(IN) :: fh
3822 INTEGER(kind=file_offset), INTENT(OUT) :: file_size
3823
3824#if defined(__parallel)
3825 INTEGER :: ierr
3826#endif
3827
3828#if defined(__parallel)
3829 ierr = 0
3830 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3831 CALL mpi_file_get_size(fh%handle, file_size, ierr)
3832 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size")
3833#else
3834 INQUIRE (unit=fh%handle, size=file_size)
3835#endif
3836 END SUBROUTINE mp_file_get_size
3837
3838! **************************************************************************************************
3839!> \brief Returns the file position
3840!> \param[in] fh file handle (file storage unit)
3841!> \param[out] file_size the file position
3842!> \par MPI-I/O mapping mpi_file_get_position
3843!> \par STREAM-I/O mapping INQUIRE
3844!>
3845!> \par History
3846!> 11.2017 created [Nico Holmberg]
3847! **************************************************************************************************
3848 SUBROUTINE mp_file_get_position(fh, pos)
3849 CLASS(mp_file_type), INTENT(IN) :: fh
3850 INTEGER(kind=file_offset), INTENT(OUT) :: pos
3851
3852#if defined(__parallel)
3853 INTEGER :: ierr
3854#endif
3855
3856#if defined(__parallel)
3857 ierr = 0
3858 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3859 CALL mpi_file_get_position(fh%handle, pos, ierr)
3860 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position")
3861#else
3862 INQUIRE (unit=fh%handle, pos=pos)
3863#endif
3864 END SUBROUTINE mp_file_get_position
3865
3866! **************************************************************************************************
3867!> \brief (parallel) Blocking individual file write using explicit offsets
3868!> (serial) Unformatted stream write
3869!> \param[in] fh file handle (file storage unit)
3870!> \param[in] offset file offset (position)
3871!> \param[in] msg data to be written to the file
3872!> \param msglen ...
3873!> \par MPI-I/O mapping mpi_file_write_at
3874!> \par STREAM-I/O mapping WRITE
3875!> \param[in](optional) msglen number of the elements of data
3876! **************************************************************************************************
3877 SUBROUTINE mp_file_write_at_chv(fh, offset, msg, msglen)
3878 CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
3879 CLASS(mp_file_type), INTENT(IN) :: fh
3880 INTEGER, INTENT(IN), OPTIONAL :: msglen
3881 INTEGER(kind=file_offset), INTENT(IN) :: offset
3882
3883#if defined(__parallel)
3884 INTEGER :: ierr, msg_len
3885#endif
3886
3887#if defined(__parallel)
3888 msg_len = SIZE(msg)
3889 IF (PRESENT(msglen)) msg_len = msglen
3890 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
3891 IF (ierr /= 0) &
3892 cpabort("mpi_file_write_at_chv @ mp_file_write_at_chv")
3893#else
3894 mark_used(msglen)
3895 WRITE (unit=fh%handle, pos=offset + 1) msg
3896#endif
3897 END SUBROUTINE mp_file_write_at_chv
3898
3899! **************************************************************************************************
3900!> \brief ...
3901!> \param fh ...
3902!> \param offset ...
3903!> \param msg ...
3904! **************************************************************************************************
3905 SUBROUTINE mp_file_write_at_ch(fh, offset, msg)
3906 CHARACTER(LEN=*), INTENT(IN) :: msg
3907 CLASS(mp_file_type), INTENT(IN) :: fh
3908 INTEGER(kind=file_offset), INTENT(IN) :: offset
3909
3910#if defined(__parallel)
3911 INTEGER :: ierr
3912#endif
3913
3914#if defined(__parallel)
3915 CALL mpi_file_write_at(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
3916 IF (ierr /= 0) &
3917 cpabort("mpi_file_write_at_ch @ mp_file_write_at_ch")
3918#else
3919 WRITE (unit=fh%handle, pos=offset + 1) msg
3920#endif
3921 END SUBROUTINE mp_file_write_at_ch
3922
3923! **************************************************************************************************
3924!> \brief (parallel) Blocking collective file write using explicit offsets
3925!> (serial) Unformatted stream write
3926!> \param fh ...
3927!> \param offset ...
3928!> \param msg ...
3929!> \param msglen ...
3930!> \par MPI-I/O mapping mpi_file_write_at_all
3931!> \par STREAM-I/O mapping WRITE
3932! **************************************************************************************************
3933 SUBROUTINE mp_file_write_at_all_chv(fh, offset, msg, msglen)
3934 CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
3935 CLASS(mp_file_type), INTENT(IN) :: fh
3936 INTEGER, INTENT(IN), OPTIONAL :: msglen
3937 INTEGER(kind=file_offset), INTENT(IN) :: offset
3938
3939#if defined(__parallel)
3940 INTEGER :: ierr, msg_len
3941#endif
3942
3943#if defined(__parallel)
3944 msg_len = SIZE(msg)
3945 IF (PRESENT(msglen)) msg_len = msglen
3946 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
3947 IF (ierr /= 0) &
3948 cpabort("mpi_file_write_at_all_chv @ mp_file_write_at_all_chv")
3949#else
3950 mark_used(msglen)
3951 WRITE (unit=fh%handle, pos=offset + 1) msg
3952#endif
3953 END SUBROUTINE mp_file_write_at_all_chv
3954
3955! **************************************************************************************************
3956!> \brief wrapper to MPI_File_write_at_all
3957!> \param fh ...
3958!> \param offset ...
3959!> \param msg ...
3960! **************************************************************************************************
3961 SUBROUTINE mp_file_write_at_all_ch(fh, offset, msg)
3962 CHARACTER(LEN=*), INTENT(IN) :: msg
3963 CLASS(mp_file_type), INTENT(IN) :: fh
3964 INTEGER(kind=file_offset), INTENT(IN) :: offset
3965
3966#if defined(__parallel)
3967 INTEGER :: ierr
3968#endif
3969
3970#if defined(__parallel)
3971 CALL mpi_file_write_at_all(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
3972 IF (ierr /= 0) &
3973 cpabort("mpi_file_write_at_all_ch @ mp_file_write_at_all_ch")
3974#else
3975 WRITE (unit=fh%handle, pos=offset + 1) msg
3976#endif
3977 END SUBROUTINE mp_file_write_at_all_ch
3978
3979! **************************************************************************************************
3980!> \brief (parallel) Blocking individual file read using explicit offsets
3981!> (serial) Unformatted stream read
3982!> \param[in] fh file handle (file storage unit)
3983!> \param[in] offset file offset (position)
3984!> \param[out] msg data to be read from the file
3985!> \param msglen ...
3986!> \par MPI-I/O mapping mpi_file_read_at
3987!> \par STREAM-I/O mapping READ
3988!> \param[in](optional) msglen number of elements of data
3989! **************************************************************************************************
3990 SUBROUTINE mp_file_read_at_chv(fh, offset, msg, msglen)
3991 CHARACTER, CONTIGUOUS, INTENT(OUT) :: msg(:)
3992 CLASS(mp_file_type), INTENT(IN) :: fh
3993 INTEGER, INTENT(IN), OPTIONAL :: msglen
3994 INTEGER(kind=file_offset), INTENT(IN) :: offset
3995
3996#if defined(__parallel)
3997 INTEGER :: ierr, msg_len
3998#endif
3999
4000#if defined(__parallel)
4001 msg_len = SIZE(msg)
4002 IF (PRESENT(msglen)) msg_len = msglen
4003 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4004 IF (ierr /= 0) &
4005 cpabort("mpi_file_read_at_chv @ mp_file_read_at_chv")
4006#else
4007 mark_used(msglen)
4008 READ (unit=fh%handle, pos=offset + 1) msg
4009#endif
4010 END SUBROUTINE mp_file_read_at_chv
4011
4012! **************************************************************************************************
4013!> \brief wrapper to MPI_File_read_at
4014!> \param fh ...
4015!> \param offset ...
4016!> \param msg ...
4017! **************************************************************************************************
4018 SUBROUTINE mp_file_read_at_ch(fh, offset, msg)
4019 CHARACTER(LEN=*), INTENT(OUT) :: msg
4020 CLASS(mp_file_type), INTENT(IN) :: fh
4021 INTEGER(kind=file_offset), INTENT(IN) :: offset
4022
4023#if defined(__parallel)
4024 INTEGER :: ierr
4025#endif
4026
4027#if defined(__parallel)
4028 CALL mpi_file_read_at(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4029 IF (ierr /= 0) &
4030 cpabort("mpi_file_read_at_ch @ mp_file_read_at_ch")
4031#else
4032 READ (unit=fh%handle, pos=offset + 1) msg
4033#endif
4034 END SUBROUTINE mp_file_read_at_ch
4035
4036! **************************************************************************************************
4037!> \brief (parallel) Blocking collective file read using explicit offsets
4038!> (serial) Unformatted stream read
4039!> \param fh ...
4040!> \param offset ...
4041!> \param msg ...
4042!> \param msglen ...
4043!> \par MPI-I/O mapping mpi_file_read_at_all
4044!> \par STREAM-I/O mapping READ
4045! **************************************************************************************************
4046 SUBROUTINE mp_file_read_at_all_chv(fh, offset, msg, msglen)
4047 CHARACTER, INTENT(OUT) :: msg(:)
4048 CLASS(mp_file_type), INTENT(IN) :: fh
4049 INTEGER, INTENT(IN), OPTIONAL :: msglen
4050 INTEGER(kind=file_offset), INTENT(IN) :: offset
4051
4052#if defined(__parallel)
4053 INTEGER :: ierr, msg_len
4054#endif
4055
4056#if defined(__parallel)
4057 msg_len = SIZE(msg)
4058 IF (PRESENT(msglen)) msg_len = msglen
4059 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4060 IF (ierr /= 0) &
4061 cpabort("mpi_file_read_at_all_chv @ mp_file_read_at_all_chv")
4062#else
4063 mark_used(msglen)
4064 READ (unit=fh%handle, pos=offset + 1) msg
4065#endif
4066 END SUBROUTINE mp_file_read_at_all_chv
4067
4068! **************************************************************************************************
4069!> \brief wrapper to MPI_File_read_at_all
4070!> \param fh ...
4071!> \param offset ...
4072!> \param msg ...
4073! **************************************************************************************************
4074 SUBROUTINE mp_file_read_at_all_ch(fh, offset, msg)
4075 CHARACTER(LEN=*), INTENT(OUT) :: msg
4076 CLASS(mp_file_type), INTENT(IN) :: fh
4077 INTEGER(kind=file_offset), INTENT(IN) :: offset
4078
4079#if defined(__parallel)
4080 INTEGER :: ierr
4081#endif
4082
4083#if defined(__parallel)
4084 CALL mpi_file_read_at_all(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4085 IF (ierr /= 0) &
4086 cpabort("mpi_file_read_at_all_ch @ mp_file_read_at_all_ch")
4087#else
4088 READ (unit=fh%handle, pos=offset + 1) msg
4089#endif
4090 END SUBROUTINE mp_file_read_at_all_ch
4091
4092! **************************************************************************************************
4093!> \brief Returns the size of a data type in bytes
4094!> \param[in] type_descriptor data type
4095!> \param[out] type_size size of the data type
4096!> \par MPI mapping
4097!> mpi_type_size
4098!>
4099! **************************************************************************************************
4100 SUBROUTINE mp_type_size(type_descriptor, type_size)
4101 TYPE(mp_type_descriptor_type), INTENT(IN) :: type_descriptor
4102 INTEGER, INTENT(OUT) :: type_size
4103
4104#if defined(__parallel)
4105 INTEGER :: ierr
4106
4107 ierr = 0
4108 CALL mpi_type_size(type_descriptor%type_handle, type_size, ierr)
4109 IF (ierr /= 0) &
4110 cpabort("mpi_type_size failed @ mp_type_size")
4111#else
4112 SELECT CASE (type_descriptor%type_handle)
4113 CASE (1)
4114 type_size = real_4_size
4115 CASE (3)
4116 type_size = real_8_size
4117 CASE (5)
4118 type_size = 2*real_4_size
4119 CASE (7)
4120 type_size = 2*real_8_size
4121 END SELECT
4122#endif
4123 END SUBROUTINE mp_type_size
4124
4125! **************************************************************************************************
4126!> \brief wrapper to MPI_Type_create_struct
4127!> \param subtypes ...
4128!> \param vector_descriptor ...
4129!> \param index_descriptor ...
4130!> \return ...
4131! **************************************************************************************************
4132 FUNCTION mp_type_make_struct(subtypes, &
4133 vector_descriptor, index_descriptor) &
4134 result(type_descriptor)
4135 TYPE(mp_type_descriptor_type), &
4136 DIMENSION(:), INTENT(IN) :: subtypes
4137 INTEGER, DIMENSION(2), INTENT(IN), &
4138 OPTIONAL :: vector_descriptor
4139 TYPE(mp_indexing_meta_type), &
4140 INTENT(IN), OPTIONAL :: index_descriptor
4141 TYPE(mp_type_descriptor_type) :: type_descriptor
4142
4143 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_struct'
4144
4145 INTEGER :: i, n
4146 INTEGER, ALLOCATABLE, DIMENSION(:) :: lengths
4147#if defined(__parallel)
4148 INTEGER :: ierr
4149 INTEGER(kind=mpi_address_kind), &
4150 ALLOCATABLE, DIMENSION(:) :: displacements
4151#if defined(__MPI_F08)
4152 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
4153 EXTERNAL :: mpi_get_address
4154#endif
4155#endif
4156 mpi_data_type, ALLOCATABLE, DIMENSION(:) :: old_types
4157
4158 n = SIZE(subtypes)
4159 type_descriptor%length = 1
4160#if defined(__parallel)
4161 ierr = 0
4162 CALL mpi_get_address(mpi_bottom, type_descriptor%base, ierr)
4163 IF (ierr /= 0) &
4164 cpabort("MPI_get_address @ "//routinen)
4165 ALLOCATE (displacements(n))
4166#endif
4167 type_descriptor%vector_descriptor(1:2) = 1
4168 type_descriptor%has_indexing = .false.
4169 ALLOCATE (type_descriptor%subtype(n))
4170 type_descriptor%subtype(:) = subtypes(:)
4171 ALLOCATE (lengths(n), old_types(n))
4172 DO i = 1, SIZE(subtypes)
4173#if defined(__parallel)
4174 displacements(i) = subtypes(i)%base
4175#endif
4176 old_types(i) = subtypes(i)%type_handle
4177 lengths(i) = subtypes(i)%length
4178 END DO
4179#if defined(__parallel)
4180 CALL mpi_type_create_struct(n, &
4181 lengths, displacements, old_types, &
4182 type_descriptor%type_handle, ierr)
4183 IF (ierr /= 0) &
4184 cpabort("MPI_Type_create_struct @ "//routinen)
4185 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4186 IF (ierr /= 0) &
4187 cpabort("MPI_Type_commit @ "//routinen)
4188#endif
4189 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
4190 cpabort(routinen//" Vectors and indices NYI")
4191 END IF
4192 END FUNCTION mp_type_make_struct
4193
4194! **************************************************************************************************
4195!> \brief wrapper to MPI_Type_free
4196!> \param type_descriptor ...
4197! **************************************************************************************************
4198 RECURSIVE SUBROUTINE mp_type_free_m(type_descriptor)
4199 TYPE(mp_type_descriptor_type), INTENT(inout) :: type_descriptor
4200
4201 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_free_m'
4202
4203 INTEGER :: handle, i
4204#if defined(__parallel)
4205 INTEGER :: ierr
4206#endif
4207
4208 CALL mp_timeset(routinen, handle)
4209
4210 ! If the subtype is associated, then it's a user-defined data type.
4211
4212 IF (ASSOCIATED(type_descriptor%subtype)) THEN
4213 DO i = 1, SIZE(type_descriptor%subtype)
4214 CALL mp_type_free_m(type_descriptor%subtype(i))
4215 END DO
4216 DEALLOCATE (type_descriptor%subtype)
4217 END IF
4218#if defined(__parallel)
4219 ierr = 0
4220 CALL mpi_type_free(type_descriptor%type_handle, ierr)
4221 IF (ierr /= 0) &
4222 cpabort("MPI_Type_free @ "//routinen)
4223#endif
4224
4225 CALL mp_timestop(handle)
4226
4227 END SUBROUTINE mp_type_free_m
4228
4229! **************************************************************************************************
4230!> \brief ...
4231!> \param type_descriptors ...
4232! **************************************************************************************************
4233 SUBROUTINE mp_type_free_v(type_descriptors)
4234 TYPE(mp_type_descriptor_type), DIMENSION(:), &
4235 INTENT(inout) :: type_descriptors
4236
4237 INTEGER :: i
4238
4239 DO i = 1, SIZE(type_descriptors)
4240 CALL mp_type_free(type_descriptors(i))
4241 END DO
4242
4243 END SUBROUTINE mp_type_free_v
4244
4245! **************************************************************************************************
4246!> \brief Creates an indexed MPI type for arrays of strings using bytes for spacing (hindexed type)
4247!> \param count number of array blocks to read
4248!> \param lengths lengths of each array block
4249!> \param displs byte offsets for array blocks
4250!> \return container holding the created type
4251!> \author Nico Holmberg [05.2017]
4252! **************************************************************************************************
4253 FUNCTION mp_file_type_hindexed_make_chv(count, lengths, displs) &
4254 result(type_descriptor)
4255 INTEGER, INTENT(IN) :: count
4256 INTEGER, DIMENSION(1:count), &
4257 INTENT(IN), TARGET :: lengths
4258 INTEGER(kind=file_offset), &
4259 DIMENSION(1:count), INTENT(in), TARGET :: displs
4260 TYPE(mp_file_descriptor_type) :: type_descriptor
4261
4262 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_hindexed_make_chv'
4263
4264 INTEGER :: ierr, handle
4265
4266 ierr = 0
4267 CALL mp_timeset(routinen, handle)
4268
4269#if defined(__parallel)
4270 CALL mpi_type_create_hindexed(count, lengths, int(displs, kind=address_kind), mpi_character, &
4271 type_descriptor%type_handle, ierr)
4272 IF (ierr /= 0) &
4273 cpabort("MPI_Type_create_hindexed @ "//routinen)
4274 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4275 IF (ierr /= 0) &
4276 cpabort("MPI_Type_commit @ "//routinen)
4277#else
4278 type_descriptor%type_handle = 68
4279#endif
4280 type_descriptor%length = count
4281 type_descriptor%has_indexing = .true.
4282 type_descriptor%index_descriptor%index => lengths
4283 type_descriptor%index_descriptor%chunks => displs
4284
4285 CALL mp_timestop(handle)
4286
4287 END FUNCTION mp_file_type_hindexed_make_chv
4288
4289! **************************************************************************************************
4290!> \brief Uses a previously created indexed MPI character type to tell the MPI processes
4291!> how to partition (set_view) an opened file
4292!> \param fh the file handle associated with the input file
4293!> \param offset global offset determining where the relevant data begins
4294!> \param type_descriptor container for the MPI type
4295!> \author Nico Holmberg [05.2017]
4296! **************************************************************************************************
4297 SUBROUTINE mp_file_type_set_view_chv(fh, offset, type_descriptor)
4298 TYPE(mp_file_type), INTENT(IN) :: fh
4299 INTEGER(kind=file_offset), INTENT(IN) :: offset
4300 TYPE(mp_file_descriptor_type) :: type_descriptor
4301
4302 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_set_view_chv'
4303
4304 INTEGER :: handle
4305#if defined(__parallel)
4306 INTEGER :: ierr
4307#endif
4308
4309 CALL mp_timeset(routinen, handle)
4310
4311#if defined(__parallel)
4312 ierr = 0
4313 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4314 CALL mpi_file_set_view(fh%handle, offset, mpi_character, &
4315 type_descriptor%type_handle, "native", mpi_info_null, ierr)
4316 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view")
4317#else
4318 ! Uses absolute offsets stored in mp_file_descriptor_type
4319 mark_used(fh)
4320 mark_used(offset)
4321 mark_used(type_descriptor)
4322#endif
4323
4324 CALL mp_timestop(handle)
4325
4326 END SUBROUTINE mp_file_type_set_view_chv
4327
4328! **************************************************************************************************
4329!> \brief (parallel) Collective, blocking read of a character array from a file. File access pattern
4330! determined by a previously set file view.
4331!> (serial) Unformatted stream read using explicit offsets
4332!> \param fh the file handle associated with the input file
4333!> \param msglen the message length of an individual vector component
4334!> \param ndims the number of vector components
4335!> \param buffer the buffer where the data is placed
4336!> \param type_descriptor container for the MPI type
4337!> \author Nico Holmberg [05.2017]
4338! **************************************************************************************************
4339 SUBROUTINE mp_file_read_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4340 CLASS(mp_file_type), INTENT(IN) :: fh
4341 INTEGER, INTENT(IN) :: msglen
4342 INTEGER, INTENT(IN) :: ndims
4343 CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(INOUT) :: buffer
4344 TYPE(mp_file_descriptor_type), &
4345 INTENT(IN), OPTIONAL :: type_descriptor
4346
4347 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_read_all_chv'
4348
4349 INTEGER :: handle
4350#if defined(__parallel)
4351 INTEGER:: ierr
4352#else
4353 INTEGER :: i
4354#endif
4355
4356 CALL mp_timeset(routinen, handle)
4357
4358#if defined(__parallel)
4359 ierr = 0
4360 mark_used(type_descriptor)
4361 CALL mpi_file_read_all(fh%handle, buffer, ndims*msglen, mpi_character, mpi_status_ignore, ierr)
4362 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all")
4363 CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4364#else
4365 mark_used(msglen)
4366 mark_used(ndims)
4367 IF (.NOT. PRESENT(type_descriptor)) &
4368 CALL cp_abort(__location__, &
4369 "Container for mp_file_descriptor_type must be present in serial call.")
4370 IF (.NOT. type_descriptor%has_indexing) &
4371 CALL cp_abort(__location__, &
4372 "File view has not been set in mp_file_descriptor_type.")
4373 ! Use explicit offsets
4374 DO i = 1, ndims
4375 READ (fh%handle, pos=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4376 END DO
4377#endif
4378
4379 CALL mp_timestop(handle)
4380
4381 END SUBROUTINE mp_file_read_all_chv
4382
4383! **************************************************************************************************
4384!> \brief (parallel) Collective, blocking write of a character array to a file. File access pattern
4385! determined by a previously set file view.
4386!> (serial) Unformatted stream write using explicit offsets
4387!> \param fh the file handle associated with the output file
4388!> \param msglen the message length of an individual vector component
4389!> \param ndims the number of vector components
4390!> \param buffer the buffer where the data is placed
4391!> \param type_descriptor container for the MPI type
4392!> \author Nico Holmberg [05.2017]
4393! **************************************************************************************************
4394 SUBROUTINE mp_file_write_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4395 CLASS(mp_file_type), INTENT(IN) :: fh
4396 INTEGER, INTENT(IN) :: msglen
4397 INTEGER, INTENT(IN) :: ndims
4398 CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(IN) :: buffer
4399 TYPE(mp_file_descriptor_type), &
4400 INTENT(IN), OPTIONAL :: type_descriptor
4401
4402 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_write_all_chv'
4403
4404 INTEGER :: handle
4405#if defined(__parallel)
4406 INTEGER :: ierr
4407#else
4408 INTEGER :: i
4409#endif
4410
4411 CALL mp_timeset(routinen, handle)
4412
4413#if defined(__parallel)
4414 mark_used(type_descriptor)
4415 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4416 CALL mpi_file_write_all(fh%handle, buffer, ndims*msglen, mpi_character, mpi_status_ignore, ierr)
4417 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all")
4418 CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4419#else
4420 mark_used(msglen)
4421 mark_used(ndims)
4422 IF (.NOT. PRESENT(type_descriptor)) &
4423 CALL cp_abort(__location__, &
4424 "Container for mp_file_descriptor_type must be present in serial call.")
4425 IF (.NOT. type_descriptor%has_indexing) &
4426 CALL cp_abort(__location__, &
4427 "File view has not been set in mp_file_descriptor_type.")
4428 ! Use explicit offsets
4429 DO i = 1, ndims
4430 WRITE (fh%handle, pos=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4431 END DO
4432#endif
4433
4434 CALL mp_timestop(handle)
4435
4436 END SUBROUTINE mp_file_write_all_chv
4437
4438! **************************************************************************************************
4439!> \brief Releases the type used for MPI I/O
4440!> \param type_descriptor the container for the MPI type
4441!> \author Nico Holmberg [05.2017]
4442! **************************************************************************************************
4443 SUBROUTINE mp_file_type_free(type_descriptor)
4444 TYPE(mp_file_descriptor_type) :: type_descriptor
4445
4446 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_type_free'
4447
4448 INTEGER :: handle
4449#if defined(__parallel)
4450 INTEGER :: ierr
4451#endif
4452
4453 CALL mp_timeset(routinen, handle)
4454
4455#if defined(__parallel)
4456 CALL mpi_type_free(type_descriptor%type_handle, ierr)
4457 IF (ierr /= 0) &
4458 cpabort("MPI_Type_free @ "//routinen)
4459#endif
4460#if defined(__parallel) && defined(__MPI_F08)
4461 type_descriptor%type_handle%mpi_val = -1
4462#else
4463 type_descriptor%type_handle = -1
4464#endif
4465 type_descriptor%length = -1
4466 IF (type_descriptor%has_indexing) THEN
4467 NULLIFY (type_descriptor%index_descriptor%index)
4468 NULLIFY (type_descriptor%index_descriptor%chunks)
4469 type_descriptor%has_indexing = .false.
4470 END IF
4471
4472 CALL mp_timestop(handle)
4473
4474 END SUBROUTINE mp_file_type_free
4475
4476! **************************************************************************************************
4477!> \brief (parallel) Utility routine to determine MPI file access mode based on variables
4478! that in the serial case would get passed to the intrinsic OPEN
4479!> (serial) No action
4480!> \param mpi_io flag that determines if MPI I/O will actually be used
4481!> \param replace flag that indicates whether file needs to be deleted prior to opening it
4482!> \param amode the MPI I/O access mode
4483!> \param form formatted or unformatted data?
4484!> \param action the variable that determines what to do with file
4485!> \param status the status flag:
4486!> \param position should the file be appended or rewound
4487!> \author Nico Holmberg [11.2017]
4488! **************************************************************************************************
4489 SUBROUTINE mp_file_get_amode(mpi_io, replace, amode, form, action, status, position)
4490 LOGICAL, INTENT(INOUT) :: mpi_io, replace
4491 INTEGER, INTENT(OUT) :: amode
4492 CHARACTER(len=*), INTENT(IN) :: form, action, status, position
4493
4494 amode = -1
4495#if defined(__parallel)
4496 ! Disable mpi io for unformatted access
4497 SELECT CASE (form)
4498 CASE ("FORMATTED")
4499 ! Do nothing
4500 CASE ("UNFORMATTED")
4501 mpi_io = .false.
4502 CASE DEFAULT
4503 cpabort("Unknown MPI file form requested.")
4504 END SELECT
4505 ! Determine file access mode (limited set of allowed choices)
4506 SELECT CASE (action)
4507 CASE ("WRITE")
4508 amode = file_amode_wronly
4509 SELECT CASE (status)
4510 CASE ("NEW")
4511 ! Try to open new file for writing, crash if file already exists
4512 amode = amode + file_amode_create + file_amode_excl
4513 CASE ("UNKNOWN")
4514 ! Open file for writing and create it if file does not exist
4515 amode = amode + file_amode_create
4516 SELECT CASE (position)
4517 CASE ("APPEND")
4518 ! Append existing file
4519 amode = amode + file_amode_append
4520 CASE ("REWIND", "ASIS")
4521 ! Do nothing
4522 CASE DEFAULT
4523 cpabort("Unknown MPI file position requested.")
4524 END SELECT
4525 CASE ("OLD")
4526 SELECT CASE (position)
4527 CASE ("APPEND")
4528 ! Append existing file
4529 amode = amode + file_amode_append
4530 CASE ("REWIND", "ASIS")
4531 ! Do nothing
4532 CASE DEFAULT
4533 cpabort("Unknown MPI file position requested.")
4534 END SELECT
4535 CASE ("REPLACE")
4536 ! Overwrite existing file. Must delete existing file first
4537 amode = amode + file_amode_create
4538 replace = .true.
4539 CASE ("SCRATCH")
4540 ! Disable
4541 mpi_io = .false.
4542 CASE DEFAULT
4543 cpabort("Unknown MPI file status requested.")
4544 END SELECT
4545 CASE ("READ")
4546 amode = file_amode_rdonly
4547 SELECT CASE (status)
4548 CASE ("NEW")
4549 cpabort("Cannot read from 'NEW' file.")
4550 CASE ("REPLACE")
4551 cpabort("Illegal status 'REPLACE' for read.")
4552 CASE ("UNKNOWN", "OLD")
4553 ! Do nothing
4554 CASE ("SCRATCH")
4555 ! Disable
4556 mpi_io = .false.
4557 CASE DEFAULT
4558 cpabort("Unknown MPI file status requested.")
4559 END SELECT
4560 CASE ("READWRITE")
4561 amode = file_amode_rdwr
4562 SELECT CASE (status)
4563 CASE ("NEW")
4564 ! Try to open new file, crash if file already exists
4565 amode = amode + file_amode_create + file_amode_excl
4566 CASE ("UNKNOWN")
4567 ! Open file and create it if file does not exist
4568 amode = amode + file_amode_create
4569 SELECT CASE (position)
4570 CASE ("APPEND")
4571 ! Append existing file
4572 amode = amode + file_amode_append
4573 CASE ("REWIND", "ASIS")
4574 ! Do nothing
4575 CASE DEFAULT
4576 cpabort("Unknown MPI file position requested.")
4577 END SELECT
4578 CASE ("OLD")
4579 SELECT CASE (position)
4580 CASE ("APPEND")
4581 ! Append existing file
4582 amode = amode + file_amode_append
4583 CASE ("REWIND", "ASIS")
4584 ! Do nothing
4585 CASE DEFAULT
4586 cpabort("Unknown MPI file position requested.")
4587 END SELECT
4588 CASE ("REPLACE")
4589 ! Overwrite existing file. Must delete existing file first
4590 amode = amode + file_amode_create
4591 replace = .true.
4592 CASE ("SCRATCH")
4593 ! Disable
4594 mpi_io = .false.
4595 CASE DEFAULT
4596 cpabort("Unknown MPI file status requested.")
4597 END SELECT
4598 CASE DEFAULT
4599 cpabort("Unknown MPI file action requested.")
4600 END SELECT
4601#else
4602 mark_used(replace)
4603 mark_used(form)
4604 mark_used(position)
4605 mark_used(status)
4606 mark_used(action)
4607 mpi_io = .false.
4608#endif
4609
4610 END SUBROUTINE mp_file_get_amode
4611
4612! **************************************************************************************************
4613!> \brief Non-blocking send of custom type
4614!> \param msgin ...
4615!> \param dest ...
4616!> \param comm ...
4617!> \param request ...
4618!> \param tag ...
4619! **************************************************************************************************
4620 SUBROUTINE mp_isend_custom(msgin, dest, comm, request, tag)
4621 TYPE(mp_type_descriptor_type), INTENT(IN) :: msgin
4622 INTEGER, INTENT(IN) :: dest
4623 CLASS(mp_comm_type), INTENT(IN) :: comm
4624 TYPE(mp_request_type), INTENT(out) :: request
4625 INTEGER, INTENT(in), OPTIONAL :: tag
4626
4627 INTEGER :: ierr, my_tag
4628
4629 ierr = 0
4630 my_tag = 0
4631
4632#if defined(__parallel)
4633 IF (PRESENT(tag)) my_tag = tag
4634
4635 CALL mpi_isend(mpi_bottom, 1, msgin%type_handle, dest, my_tag, &
4636 comm%handle, request%handle, ierr)
4637 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ mp_isend_custom")
4638#else
4639 mark_used(msgin)
4640 mark_used(dest)
4641 mark_used(comm)
4642 mark_used(tag)
4643 ierr = 1
4644 request = mp_request_null
4645 CALL mp_stop(ierr, "mp_isend called in non parallel case")
4646#endif
4647 END SUBROUTINE mp_isend_custom
4648
4649! **************************************************************************************************
4650!> \brief Non-blocking receive of vector data
4651!> \param msgout ...
4652!> \param source ...
4653!> \param comm ...
4654!> \param request ...
4655!> \param tag ...
4656! **************************************************************************************************
4657 SUBROUTINE mp_irecv_custom(msgout, source, comm, request, tag)
4658 TYPE(mp_type_descriptor_type), INTENT(INOUT) :: msgout
4659 INTEGER, INTENT(IN) :: source
4660 CLASS(mp_comm_type), INTENT(IN) :: comm
4661 TYPE(mp_request_type), INTENT(out) :: request
4662 INTEGER, INTENT(in), OPTIONAL :: tag
4663
4664 INTEGER :: ierr, my_tag
4665
4666 ierr = 0
4667 my_tag = 0
4668
4669#if defined(__parallel)
4670 IF (PRESENT(tag)) my_tag = tag
4671
4672 CALL mpi_irecv(mpi_bottom, 1, msgout%type_handle, source, my_tag, &
4673 comm%handle, request%handle, ierr)
4674 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ mp_irecv_custom")
4675#else
4676 mark_used(msgout)
4677 mark_used(source)
4678 mark_used(comm)
4679 mark_used(tag)
4680 ierr = 1
4681 request = mp_request_null
4682 cpabort("mp_irecv called in non parallel case")
4683#endif
4684 END SUBROUTINE mp_irecv_custom
4685
4686! **************************************************************************************************
4687!> \brief Window free
4688!> \param win ...
4689! **************************************************************************************************
4690 SUBROUTINE mp_win_free(win)
4691 CLASS(mp_win_type), INTENT(INOUT) :: win
4692
4693 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_free'
4694
4695 INTEGER :: handle
4696#if defined(__parallel)
4697 INTEGER :: ierr
4698#endif
4699
4700 CALL mp_timeset(routinen, handle)
4701
4702#if defined(__parallel)
4703 ierr = 0
4704 CALL mpi_win_free(win%handle, ierr)
4705 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_free @ "//routinen)
4706
4707 CALL add_perf(perf_id=21, count=1)
4708#else
4709 win%handle = mp_win_null_handle
4710#endif
4711 CALL mp_timestop(handle)
4712 END SUBROUTINE mp_win_free
4713
4714 SUBROUTINE mp_win_assign(win_new, win_old)
4715 CLASS(mp_win_type), INTENT(OUT) :: win_new
4716 CLASS(mp_win_type), INTENT(IN) :: win_old
4717
4718 win_new%handle = win_old%handle
4719
4720 END SUBROUTINE mp_win_assign
4721
4722! **************************************************************************************************
4723!> \brief Window flush
4724!> \param win ...
4725! **************************************************************************************************
4726 SUBROUTINE mp_win_flush_all(win)
4727 CLASS(mp_win_type), INTENT(IN) :: win
4728
4729 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_flush_all'
4730
4731 INTEGER :: handle, ierr
4732
4733 ierr = 0
4734 CALL mp_timeset(routinen, handle)
4735
4736#if defined(__parallel)
4737 CALL mpi_win_flush_all(win%handle, ierr)
4738 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_flush_all @ "//routinen)
4739#else
4740 mark_used(win)
4741#endif
4742 CALL mp_timestop(handle)
4743 END SUBROUTINE mp_win_flush_all
4744
4745! **************************************************************************************************
4746!> \brief Window lock
4747!> \param win ...
4748! **************************************************************************************************
4749 SUBROUTINE mp_win_lock_all(win)
4750 CLASS(mp_win_type), INTENT(IN) :: win
4751
4752 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_lock_all'
4753
4754 INTEGER :: handle, ierr
4755
4756 ierr = 0
4757 CALL mp_timeset(routinen, handle)
4758
4759#if defined(__parallel)
4760
4761 CALL mpi_win_lock_all(mpi_mode_nocheck, win%handle, ierr)
4762 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_lock_all @ "//routinen)
4763
4764 CALL add_perf(perf_id=19, count=1)
4765#else
4766 mark_used(win)
4767#endif
4768 CALL mp_timestop(handle)
4769 END SUBROUTINE mp_win_lock_all
4770
4771! **************************************************************************************************
4772!> \brief Window lock
4773!> \param win ...
4774! **************************************************************************************************
4775 SUBROUTINE mp_win_unlock_all(win)
4776 CLASS(mp_win_type), INTENT(IN) :: win
4777
4778 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_unlock_all'
4779
4780 INTEGER :: handle, ierr
4781
4782 ierr = 0
4783 CALL mp_timeset(routinen, handle)
4784
4785#if defined(__parallel)
4786
4787 CALL mpi_win_unlock_all(win%handle, ierr)
4788 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_unlock_all @ "//routinen)
4789
4790 CALL add_perf(perf_id=19, count=1)
4791#else
4792 mark_used(win)
4793#endif
4794 CALL mp_timestop(handle)
4795 END SUBROUTINE mp_win_unlock_all
4796
4797! **************************************************************************************************
4798!> \brief Starts a timer region
4799!> \param routineN ...
4800!> \param handle ...
4801! **************************************************************************************************
4802 SUBROUTINE mp_timeset(routineN, handle)
4803 CHARACTER(len=*), INTENT(IN) :: routinen
4804 INTEGER, INTENT(OUT) :: handle
4805
4806 IF (mp_collect_timings) &
4807 CALL timeset(routinen, handle)
4808 END SUBROUTINE mp_timeset
4809
4810! **************************************************************************************************
4811!> \brief Ends a timer region
4812!> \param handle ...
4813! **************************************************************************************************
4814 SUBROUTINE mp_timestop(handle)
4815 INTEGER, INTENT(IN) :: handle
4816
4817 IF (mp_collect_timings) &
4818 CALL timestop(handle)
4819 END SUBROUTINE mp_timestop
4820
4821! **************************************************************************************************
4822!> \brief Shift around the data in msg
4823!> \param[in,out] msg Rank-2 data to shift
4824!> \param[in] comm message passing environment identifier
4825!> \param[in] displ_in displacements (?)
4826!> \par Example
4827!> msg will be moved from rank to rank+displ_in (in a circular way)
4828!> \par Limitations
4829!> * displ_in will be 1 by default (others not tested)
4830!> * the message array needs to be the same size on all processes
4831! **************************************************************************************************
4832 SUBROUTINE mp_shift_im(msg, comm, displ_in)
4833
4834 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
4835 CLASS(mp_comm_type), INTENT(IN) :: comm
4836 INTEGER, INTENT(IN), OPTIONAL :: displ_in
4837
4838 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_im'
4839
4840 INTEGER :: handle, ierror
4841#if defined(__parallel)
4842 INTEGER :: displ, left, &
4843 msglen, myrank, nprocs, &
4844 right, tag
4845#endif
4846
4847 ierror = 0
4848 CALL mp_timeset(routinen, handle)
4849
4850#if defined(__parallel)
4851 CALL mpi_comm_rank(comm%handle, myrank, ierror)
4852 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
4853 CALL mpi_comm_size(comm%handle, nprocs, ierror)
4854 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
4855 IF (PRESENT(displ_in)) THEN
4856 displ = displ_in
4857 ELSE
4858 displ = 1
4859 END IF
4860 right = modulo(myrank + displ, nprocs)
4861 left = modulo(myrank - displ, nprocs)
4862 tag = 17
4863 msglen = SIZE(msg)
4864 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer, right, tag, left, tag, &
4865 comm%handle, mpi_status_ignore, ierror)
4866 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
4867 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_4_size)
4868#else
4869 mark_used(msg)
4870 mark_used(comm)
4871 mark_used(displ_in)
4872#endif
4873 CALL mp_timestop(handle)
4874
4875 END SUBROUTINE mp_shift_im
4876
4877! **************************************************************************************************
4878!> \brief Shift around the data in msg
4879!> \param[in,out] msg Data to shift
4880!> \param[in] comm message passing environment identifier
4881!> \param[in] displ_in displacements (?)
4882!> \par Example
4883!> msg will be moved from rank to rank+displ_in (in a circular way)
4884!> \par Limitations
4885!> * displ_in will be 1 by default (others not tested)
4886!> * the message array needs to be the same size on all processes
4887! **************************************************************************************************
4888 SUBROUTINE mp_shift_i (msg, comm, displ_in)
4889
4890 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
4891 CLASS(mp_comm_type), INTENT(IN) :: comm
4892 INTEGER, INTENT(IN), OPTIONAL :: displ_in
4893
4894 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_i'
4895
4896 INTEGER :: handle, ierror
4897#if defined(__parallel)
4898 INTEGER :: displ, left, &
4899 msglen, myrank, nprocs, &
4900 right, tag
4901#endif
4902
4903 ierror = 0
4904 CALL mp_timeset(routinen, handle)
4905
4906#if defined(__parallel)
4907 CALL mpi_comm_rank(comm%handle, myrank, ierror)
4908 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
4909 CALL mpi_comm_size(comm%handle, nprocs, ierror)
4910 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
4911 IF (PRESENT(displ_in)) THEN
4912 displ = displ_in
4913 ELSE
4914 displ = 1
4915 END IF
4916 right = modulo(myrank + displ, nprocs)
4917 left = modulo(myrank - displ, nprocs)
4918 tag = 19
4919 msglen = SIZE(msg)
4920 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer, right, tag, left, &
4921 tag, comm%handle, mpi_status_ignore, ierror)
4922 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
4923 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_4_size)
4924#else
4925 mark_used(msg)
4926 mark_used(comm)
4927 mark_used(displ_in)
4928#endif
4929 CALL mp_timestop(handle)
4930
4931 END SUBROUTINE mp_shift_i
4932
4933! **************************************************************************************************
4934!> \brief All-to-all data exchange, rank-1 data of different sizes
4935!> \param[in] sb Data to send
4936!> \param[in] scount Data counts for data sent to other processes
4937!> \param[in] sdispl Respective data offsets for data sent to process
4938!> \param[in,out] rb Buffer into which to receive data
4939!> \param[in] rcount Data counts for data received from other
4940!> processes
4941!> \param[in] rdispl Respective data offsets for data received from
4942!> other processes
4943!> \param[in] comm Message passing environment identifier
4944!> \par MPI mapping
4945!> mpi_alltoallv
4946!> \par Array sizes
4947!> The scount, rcount, and the sdispl and rdispl arrays have a
4948!> size equal to the number of processes.
4949!> \par Offsets
4950!> Values in sdispl and rdispl start with 0.
4951! **************************************************************************************************
4952 SUBROUTINE mp_alltoall_i11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
4953
4954 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
4955 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
4956 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
4957 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
4958 CLASS(mp_comm_type), INTENT(IN) :: comm
4959
4960 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i11v'
4961
4962 INTEGER :: handle
4963#if defined(__parallel)
4964 INTEGER :: ierr, msglen
4965#else
4966 INTEGER :: i
4967#endif
4968
4969 CALL mp_timeset(routinen, handle)
4970
4971#if defined(__parallel)
4972 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer, &
4973 rb, rcount, rdispl, mpi_integer, comm%handle, ierr)
4974 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
4975 msglen = sum(scount) + sum(rcount)
4976 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
4977#else
4978 mark_used(comm)
4979 mark_used(scount)
4980 mark_used(sdispl)
4981 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
4982 DO i = 1, rcount(1)
4983 rb(rdispl(1) + i) = sb(sdispl(1) + i)
4984 END DO
4985#endif
4986 CALL mp_timestop(handle)
4987
4988 END SUBROUTINE mp_alltoall_i11v
4989
4990! **************************************************************************************************
4991!> \brief All-to-all data exchange, rank-2 data of different sizes
4992!> \param sb ...
4993!> \param scount ...
4994!> \param sdispl ...
4995!> \param rb ...
4996!> \param rcount ...
4997!> \param rdispl ...
4998!> \param comm ...
4999!> \par MPI mapping
5000!> mpi_alltoallv
5001!> \note see mp_alltoall_i11v
5002! **************************************************************************************************
5003 SUBROUTINE mp_alltoall_i22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
5004
5005 INTEGER(KIND=int_4), DIMENSION(:, :), &
5006 INTENT(IN), CONTIGUOUS :: sb
5007 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
5008 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, &
5009 INTENT(INOUT) :: rb
5010 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
5011 CLASS(mp_comm_type), INTENT(IN) :: comm
5012
5013 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i22v'
5014
5015 INTEGER :: handle
5016#if defined(__parallel)
5017 INTEGER :: ierr, msglen
5018#endif
5019
5020 CALL mp_timeset(routinen, handle)
5021
5022#if defined(__parallel)
5023 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer, &
5024 rb, rcount, rdispl, mpi_integer, comm%handle, ierr)
5025 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
5026 msglen = sum(scount) + sum(rcount)
5027 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*int_4_size)
5028#else
5029 mark_used(comm)
5030 mark_used(scount)
5031 mark_used(sdispl)
5032 mark_used(rcount)
5033 mark_used(rdispl)
5034 rb = sb
5035#endif
5036 CALL mp_timestop(handle)
5037
5038 END SUBROUTINE mp_alltoall_i22v
5039
5040! **************************************************************************************************
5041!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
5042!> \param[in] sb array with data to send
5043!> \param[out] rb array into which data is received
5044!> \param[in] count number of elements to send/receive (product of the
5045!> extents of the first two dimensions)
5046!> \param[in] comm Message passing environment identifier
5047!> \par Index meaning
5048!> \par The first two indices specify the data while the last index counts
5049!> the processes
5050!> \par Sizes of ranks
5051!> All processes have the same data size.
5052!> \par MPI mapping
5053!> mpi_alltoall
5054! **************************************************************************************************
5055 SUBROUTINE mp_alltoall_i (sb, rb, count, comm)
5056
5057 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
5058 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
5059 INTEGER, INTENT(IN) :: count
5060 CLASS(mp_comm_type), INTENT(IN) :: comm
5061
5062 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i'
5063
5064 INTEGER :: handle
5065#if defined(__parallel)
5066 INTEGER :: ierr, msglen, np
5067#endif
5068
5069 CALL mp_timeset(routinen, handle)
5070
5071#if defined(__parallel)
5072 CALL mpi_alltoall(sb, count, mpi_integer, &
5073 rb, count, mpi_integer, comm%handle, ierr)
5074 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5075 CALL mpi_comm_size(comm%handle, np, ierr)
5076 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5077 msglen = 2*count*np
5078 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5079#else
5080 mark_used(count)
5081 mark_used(comm)
5082 rb = sb
5083#endif
5084 CALL mp_timestop(handle)
5085
5086 END SUBROUTINE mp_alltoall_i
5087
5088! **************************************************************************************************
5089!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
5090!> \param sb ...
5091!> \param rb ...
5092!> \param count ...
5093!> \param commp ...
5094!> \note see mp_alltoall_i
5095! **************************************************************************************************
5096 SUBROUTINE mp_alltoall_i22(sb, rb, count, comm)
5097
5098 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
5099 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
5100 INTEGER, INTENT(IN) :: count
5101 CLASS(mp_comm_type), INTENT(IN) :: comm
5102
5103 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i22'
5104
5105 INTEGER :: handle
5106#if defined(__parallel)
5107 INTEGER :: ierr, msglen, np
5108#endif
5109
5110 CALL mp_timeset(routinen, handle)
5111
5112#if defined(__parallel)
5113 CALL mpi_alltoall(sb, count, mpi_integer, &
5114 rb, count, mpi_integer, comm%handle, ierr)
5115 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5116 CALL mpi_comm_size(comm%handle, np, ierr)
5117 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5118 msglen = 2*SIZE(sb)*np
5119 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5120#else
5121 mark_used(count)
5122 mark_used(comm)
5123 rb = sb
5124#endif
5125 CALL mp_timestop(handle)
5126
5127 END SUBROUTINE mp_alltoall_i22
5128
5129! **************************************************************************************************
5130!> \brief All-to-all data exchange, rank-3 data with equal sizes
5131!> \param sb ...
5132!> \param rb ...
5133!> \param count ...
5134!> \param comm ...
5135!> \note see mp_alltoall_i
5136! **************************************************************************************************
5137 SUBROUTINE mp_alltoall_i33(sb, rb, count, comm)
5138
5139 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
5140 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
5141 INTEGER, INTENT(IN) :: count
5142 CLASS(mp_comm_type), INTENT(IN) :: comm
5143
5144 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i33'
5145
5146 INTEGER :: handle
5147#if defined(__parallel)
5148 INTEGER :: ierr, msglen, np
5149#endif
5150
5151 CALL mp_timeset(routinen, handle)
5152
5153#if defined(__parallel)
5154 CALL mpi_alltoall(sb, count, mpi_integer, &
5155 rb, count, mpi_integer, comm%handle, ierr)
5156 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5157 CALL mpi_comm_size(comm%handle, np, ierr)
5158 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5159 msglen = 2*count*np
5160 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5161#else
5162 mark_used(count)
5163 mark_used(comm)
5164 rb = sb
5165#endif
5166 CALL mp_timestop(handle)
5167
5168 END SUBROUTINE mp_alltoall_i33
5169
5170! **************************************************************************************************
5171!> \brief All-to-all data exchange, rank 4 data, equal sizes
5172!> \param sb ...
5173!> \param rb ...
5174!> \param count ...
5175!> \param comm ...
5176!> \note see mp_alltoall_i
5177! **************************************************************************************************
5178 SUBROUTINE mp_alltoall_i44(sb, rb, count, comm)
5179
5180 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5181 INTENT(IN) :: sb
5182 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5183 INTENT(OUT) :: rb
5184 INTEGER, INTENT(IN) :: count
5185 CLASS(mp_comm_type), INTENT(IN) :: comm
5186
5187 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i44'
5188
5189 INTEGER :: handle
5190#if defined(__parallel)
5191 INTEGER :: ierr, msglen, np
5192#endif
5193
5194 CALL mp_timeset(routinen, handle)
5195
5196#if defined(__parallel)
5197 CALL mpi_alltoall(sb, count, mpi_integer, &
5198 rb, count, mpi_integer, comm%handle, ierr)
5199 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5200 CALL mpi_comm_size(comm%handle, np, ierr)
5201 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5202 msglen = 2*count*np
5203 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5204#else
5205 mark_used(count)
5206 mark_used(comm)
5207 rb = sb
5208#endif
5209 CALL mp_timestop(handle)
5210
5211 END SUBROUTINE mp_alltoall_i44
5212
5213! **************************************************************************************************
5214!> \brief All-to-all data exchange, rank 5 data, equal sizes
5215!> \param sb ...
5216!> \param rb ...
5217!> \param count ...
5218!> \param comm ...
5219!> \note see mp_alltoall_i
5220! **************************************************************************************************
5221 SUBROUTINE mp_alltoall_i55(sb, rb, count, comm)
5222
5223 INTEGER(KIND=int_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
5224 INTENT(IN) :: sb
5225 INTEGER(KIND=int_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
5226 INTENT(OUT) :: rb
5227 INTEGER, INTENT(IN) :: count
5228 CLASS(mp_comm_type), INTENT(IN) :: comm
5229
5230 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i55'
5231
5232 INTEGER :: handle
5233#if defined(__parallel)
5234 INTEGER :: ierr, msglen, np
5235#endif
5236
5237 CALL mp_timeset(routinen, handle)
5238
5239#if defined(__parallel)
5240 CALL mpi_alltoall(sb, count, mpi_integer, &
5241 rb, count, mpi_integer, comm%handle, ierr)
5242 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5243 CALL mpi_comm_size(comm%handle, np, ierr)
5244 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5245 msglen = 2*count*np
5246 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5247#else
5248 mark_used(count)
5249 mark_used(comm)
5250 rb = sb
5251#endif
5252 CALL mp_timestop(handle)
5253
5254 END SUBROUTINE mp_alltoall_i55
5255
5256! **************************************************************************************************
5257!> \brief All-to-all data exchange, rank-4 data to rank-5 data
5258!> \param sb ...
5259!> \param rb ...
5260!> \param count ...
5261!> \param comm ...
5262!> \note see mp_alltoall_i
5263!> \note User must ensure size consistency.
5264! **************************************************************************************************
5265 SUBROUTINE mp_alltoall_i45(sb, rb, count, comm)
5266
5267 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5268 INTENT(IN) :: sb
5269 INTEGER(KIND=int_4), &
5270 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
5271 INTEGER, INTENT(IN) :: count
5272 CLASS(mp_comm_type), INTENT(IN) :: comm
5273
5274 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i45'
5275
5276 INTEGER :: handle
5277#if defined(__parallel)
5278 INTEGER :: ierr, msglen, np
5279#endif
5280
5281 CALL mp_timeset(routinen, handle)
5282
5283#if defined(__parallel)
5284 CALL mpi_alltoall(sb, count, mpi_integer, &
5285 rb, count, mpi_integer, comm%handle, ierr)
5286 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5287 CALL mpi_comm_size(comm%handle, np, ierr)
5288 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5289 msglen = 2*count*np
5290 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5291#else
5292 mark_used(count)
5293 mark_used(comm)
5294 rb = reshape(sb, shape(rb))
5295#endif
5296 CALL mp_timestop(handle)
5297
5298 END SUBROUTINE mp_alltoall_i45
5299
5300! **************************************************************************************************
5301!> \brief All-to-all data exchange, rank-3 data to rank-4 data
5302!> \param sb ...
5303!> \param rb ...
5304!> \param count ...
5305!> \param comm ...
5306!> \note see mp_alltoall_i
5307!> \note User must ensure size consistency.
5308! **************************************************************************************************
5309 SUBROUTINE mp_alltoall_i34(sb, rb, count, comm)
5310
5311 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, &
5312 INTENT(IN) :: sb
5313 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5314 INTENT(OUT) :: rb
5315 INTEGER, INTENT(IN) :: count
5316 CLASS(mp_comm_type), INTENT(IN) :: comm
5317
5318 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i34'
5319
5320 INTEGER :: handle
5321#if defined(__parallel)
5322 INTEGER :: ierr, msglen, np
5323#endif
5324
5325 CALL mp_timeset(routinen, handle)
5326
5327#if defined(__parallel)
5328 CALL mpi_alltoall(sb, count, mpi_integer, &
5329 rb, count, mpi_integer, comm%handle, ierr)
5330 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5331 CALL mpi_comm_size(comm%handle, np, ierr)
5332 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5333 msglen = 2*count*np
5334 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5335#else
5336 mark_used(count)
5337 mark_used(comm)
5338 rb = reshape(sb, shape(rb))
5339#endif
5340 CALL mp_timestop(handle)
5341
5342 END SUBROUTINE mp_alltoall_i34
5343
5344! **************************************************************************************************
5345!> \brief All-to-all data exchange, rank-5 data to rank-4 data
5346!> \param sb ...
5347!> \param rb ...
5348!> \param count ...
5349!> \param comm ...
5350!> \note see mp_alltoall_i
5351!> \note User must ensure size consistency.
5352! **************************************************************************************************
5353 SUBROUTINE mp_alltoall_i54(sb, rb, count, comm)
5354
5355 INTEGER(KIND=int_4), &
5356 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
5357 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5358 INTENT(OUT) :: rb
5359 INTEGER, INTENT(IN) :: count
5360 CLASS(mp_comm_type), INTENT(IN) :: comm
5361
5362 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i54'
5363
5364 INTEGER :: handle
5365#if defined(__parallel)
5366 INTEGER :: ierr, msglen, np
5367#endif
5368
5369 CALL mp_timeset(routinen, handle)
5370
5371#if defined(__parallel)
5372 CALL mpi_alltoall(sb, count, mpi_integer, &
5373 rb, count, mpi_integer, comm%handle, ierr)
5374 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5375 CALL mpi_comm_size(comm%handle, np, ierr)
5376 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5377 msglen = 2*count*np
5378 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5379#else
5380 mark_used(count)
5381 mark_used(comm)
5382 rb = reshape(sb, shape(rb))
5383#endif
5384 CALL mp_timestop(handle)
5385
5386 END SUBROUTINE mp_alltoall_i54
5387
5388! **************************************************************************************************
5389!> \brief Send one datum to another process
5390!> \param[in] msg Scalar to send
5391!> \param[in] dest Destination process
5392!> \param[in] tag Transfer identifier
5393!> \param[in] comm Message passing environment identifier
5394!> \par MPI mapping
5395!> mpi_send
5396! **************************************************************************************************
5397 SUBROUTINE mp_send_i (msg, dest, tag, comm)
5398 INTEGER(KIND=int_4), INTENT(IN) :: msg
5399 INTEGER, INTENT(IN) :: dest, tag
5400 CLASS(mp_comm_type), INTENT(IN) :: comm
5401
5402 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_i'
5403
5404 INTEGER :: handle
5405#if defined(__parallel)
5406 INTEGER :: ierr, msglen
5407#endif
5408
5409 CALL mp_timeset(routinen, handle)
5410
5411#if defined(__parallel)
5412 msglen = 1
5413 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5414 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5415 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5416#else
5417 mark_used(msg)
5418 mark_used(dest)
5419 mark_used(tag)
5420 mark_used(comm)
5421 ! only defined in parallel
5422 cpabort("not in parallel mode")
5423#endif
5424 CALL mp_timestop(handle)
5425 END SUBROUTINE mp_send_i
5426
5427! **************************************************************************************************
5428!> \brief Send rank-1 data to another process
5429!> \param[in] msg Rank-1 data to send
5430!> \param dest ...
5431!> \param tag ...
5432!> \param comm ...
5433!> \note see mp_send_i
5434! **************************************************************************************************
5435 SUBROUTINE mp_send_iv(msg, dest, tag, comm)
5436 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
5437 INTEGER, INTENT(IN) :: dest, tag
5438 CLASS(mp_comm_type), INTENT(IN) :: comm
5439
5440 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_iv'
5441
5442 INTEGER :: handle
5443#if defined(__parallel)
5444 INTEGER :: ierr, msglen
5445#endif
5446
5447 CALL mp_timeset(routinen, handle)
5448
5449#if defined(__parallel)
5450 msglen = SIZE(msg)
5451 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5452 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5453 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5454#else
5455 mark_used(msg)
5456 mark_used(dest)
5457 mark_used(tag)
5458 mark_used(comm)
5459 ! only defined in parallel
5460 cpabort("not in parallel mode")
5461#endif
5462 CALL mp_timestop(handle)
5463 END SUBROUTINE mp_send_iv
5464
5465! **************************************************************************************************
5466!> \brief Send rank-2 data to another process
5467!> \param[in] msg Rank-2 data to send
5468!> \param dest ...
5469!> \param tag ...
5470!> \param comm ...
5471!> \note see mp_send_i
5472! **************************************************************************************************
5473 SUBROUTINE mp_send_im2(msg, dest, tag, comm)
5474 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
5475 INTEGER, INTENT(IN) :: dest, tag
5476 CLASS(mp_comm_type), INTENT(IN) :: comm
5477
5478 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_im2'
5479
5480 INTEGER :: handle
5481#if defined(__parallel)
5482 INTEGER :: ierr, msglen
5483#endif
5484
5485 CALL mp_timeset(routinen, handle)
5486
5487#if defined(__parallel)
5488 msglen = SIZE(msg)
5489 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5490 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5491 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5492#else
5493 mark_used(msg)
5494 mark_used(dest)
5495 mark_used(tag)
5496 mark_used(comm)
5497 ! only defined in parallel
5498 cpabort("not in parallel mode")
5499#endif
5500 CALL mp_timestop(handle)
5501 END SUBROUTINE mp_send_im2
5502
5503! **************************************************************************************************
5504!> \brief Send rank-3 data to another process
5505!> \param[in] msg Rank-3 data to send
5506!> \param dest ...
5507!> \param tag ...
5508!> \param comm ...
5509!> \note see mp_send_i
5510! **************************************************************************************************
5511 SUBROUTINE mp_send_im3(msg, dest, tag, comm)
5512 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
5513 INTEGER, INTENT(IN) :: dest, tag
5514 CLASS(mp_comm_type), INTENT(IN) :: comm
5515
5516 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
5517
5518 INTEGER :: handle
5519#if defined(__parallel)
5520 INTEGER :: ierr, msglen
5521#endif
5522
5523 CALL mp_timeset(routinen, handle)
5524
5525#if defined(__parallel)
5526 msglen = SIZE(msg)
5527 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5528 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5529 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5530#else
5531 mark_used(msg)
5532 mark_used(dest)
5533 mark_used(tag)
5534 mark_used(comm)
5535 ! only defined in parallel
5536 cpabort("not in parallel mode")
5537#endif
5538 CALL mp_timestop(handle)
5539 END SUBROUTINE mp_send_im3
5540
5541! **************************************************************************************************
5542!> \brief Receive one datum from another process
5543!> \param[in,out] msg Place received data into this variable
5544!> \param[in,out] source Process to receive from
5545!> \param[in,out] tag Transfer identifier
5546!> \param[in] comm Message passing environment identifier
5547!> \par MPI mapping
5548!> mpi_send
5549! **************************************************************************************************
5550 SUBROUTINE mp_recv_i (msg, source, tag, comm)
5551 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5552 INTEGER, INTENT(INOUT) :: source, tag
5553 CLASS(mp_comm_type), INTENT(IN) :: comm
5554
5555 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_i'
5556
5557 INTEGER :: handle
5558#if defined(__parallel)
5559 INTEGER :: ierr, msglen
5560 mpi_status_type :: status
5561#endif
5562
5563 CALL mp_timeset(routinen, handle)
5564
5565#if defined(__parallel)
5566 msglen = 1
5567 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5568 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5569 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5570 ELSE
5571 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5572 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5573 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5574 source = status mpi_status_extract(mpi_source)
5575 tag = status mpi_status_extract(mpi_tag)
5576 END IF
5577#else
5578 mark_used(msg)
5579 mark_used(source)
5580 mark_used(tag)
5581 mark_used(comm)
5582 ! only defined in parallel
5583 cpabort("not in parallel mode")
5584#endif
5585 CALL mp_timestop(handle)
5586 END SUBROUTINE mp_recv_i
5587
5588! **************************************************************************************************
5589!> \brief Receive rank-1 data from another process
5590!> \param[in,out] msg Place received data into this rank-1 array
5591!> \param source ...
5592!> \param tag ...
5593!> \param comm ...
5594!> \note see mp_recv_i
5595! **************************************************************************************************
5596 SUBROUTINE mp_recv_iv(msg, source, tag, comm)
5597 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5598 INTEGER, INTENT(INOUT) :: source, tag
5599 CLASS(mp_comm_type), INTENT(IN) :: comm
5600
5601 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_iv'
5602
5603 INTEGER :: handle
5604#if defined(__parallel)
5605 INTEGER :: ierr, msglen
5606 mpi_status_type :: status
5607#endif
5608
5609 CALL mp_timeset(routinen, handle)
5610
5611#if defined(__parallel)
5612 msglen = SIZE(msg)
5613 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5614 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5615 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5616 ELSE
5617 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5618 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5619 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5620 source = status mpi_status_extract(mpi_source)
5621 tag = status mpi_status_extract(mpi_tag)
5622 END IF
5623#else
5624 mark_used(msg)
5625 mark_used(source)
5626 mark_used(tag)
5627 mark_used(comm)
5628 ! only defined in parallel
5629 cpabort("not in parallel mode")
5630#endif
5631 CALL mp_timestop(handle)
5632 END SUBROUTINE mp_recv_iv
5633
5634! **************************************************************************************************
5635!> \brief Receive rank-2 data from another process
5636!> \param[in,out] msg Place received data into this rank-2 array
5637!> \param source ...
5638!> \param tag ...
5639!> \param comm ...
5640!> \note see mp_recv_i
5641! **************************************************************************************************
5642 SUBROUTINE mp_recv_im2(msg, source, tag, comm)
5643 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5644 INTEGER, INTENT(INOUT) :: source, tag
5645 CLASS(mp_comm_type), INTENT(IN) :: comm
5646
5647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_im2'
5648
5649 INTEGER :: handle
5650#if defined(__parallel)
5651 INTEGER :: ierr, msglen
5652 mpi_status_type :: status
5653#endif
5654
5655 CALL mp_timeset(routinen, handle)
5656
5657#if defined(__parallel)
5658 msglen = SIZE(msg)
5659 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5660 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5661 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5662 ELSE
5663 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5664 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5665 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5666 source = status mpi_status_extract(mpi_source)
5667 tag = status mpi_status_extract(mpi_tag)
5668 END IF
5669#else
5670 mark_used(msg)
5671 mark_used(source)
5672 mark_used(tag)
5673 mark_used(comm)
5674 ! only defined in parallel
5675 cpabort("not in parallel mode")
5676#endif
5677 CALL mp_timestop(handle)
5678 END SUBROUTINE mp_recv_im2
5679
5680! **************************************************************************************************
5681!> \brief Receive rank-3 data from another process
5682!> \param[in,out] msg Place received data into this rank-3 array
5683!> \param source ...
5684!> \param tag ...
5685!> \param comm ...
5686!> \note see mp_recv_i
5687! **************************************************************************************************
5688 SUBROUTINE mp_recv_im3(msg, source, tag, comm)
5689 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
5690 INTEGER, INTENT(INOUT) :: source, tag
5691 CLASS(mp_comm_type), INTENT(IN) :: comm
5692
5693 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_im3'
5694
5695 INTEGER :: handle
5696#if defined(__parallel)
5697 INTEGER :: ierr, msglen
5698 mpi_status_type :: status
5699#endif
5700
5701 CALL mp_timeset(routinen, handle)
5702
5703#if defined(__parallel)
5704 msglen = SIZE(msg)
5705 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5706 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5707 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5708 ELSE
5709 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5710 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5711 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5712 source = status mpi_status_extract(mpi_source)
5713 tag = status mpi_status_extract(mpi_tag)
5714 END IF
5715#else
5716 mark_used(msg)
5717 mark_used(source)
5718 mark_used(tag)
5719 mark_used(comm)
5720 ! only defined in parallel
5721 cpabort("not in parallel mode")
5722#endif
5723 CALL mp_timestop(handle)
5724 END SUBROUTINE mp_recv_im3
5725
5726! **************************************************************************************************
5727!> \brief Broadcasts a datum to all processes.
5728!> \param[in] msg Datum to broadcast
5729!> \param[in] source Processes which broadcasts
5730!> \param[in] comm Message passing environment identifier
5731!> \par MPI mapping
5732!> mpi_bcast
5733! **************************************************************************************************
5734 SUBROUTINE mp_bcast_i (msg, source, comm)
5735 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5736 INTEGER, INTENT(IN) :: source
5737 CLASS(mp_comm_type), INTENT(IN) :: comm
5738
5739 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i'
5740
5741 INTEGER :: handle
5742#if defined(__parallel)
5743 INTEGER :: ierr, msglen
5744#endif
5745
5746 CALL mp_timeset(routinen, handle)
5747
5748#if defined(__parallel)
5749 msglen = 1
5750 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
5751 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5752 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5753#else
5754 mark_used(msg)
5755 mark_used(source)
5756 mark_used(comm)
5757#endif
5758 CALL mp_timestop(handle)
5759 END SUBROUTINE mp_bcast_i
5760
5761! **************************************************************************************************
5762!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
5763!> \param[in] msg Datum to broadcast
5764!> \param[in] comm Message passing environment identifier
5765!> \par MPI mapping
5766!> mpi_bcast
5767! **************************************************************************************************
5768 SUBROUTINE mp_bcast_i_src(msg, comm)
5769 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5770 CLASS(mp_comm_type), INTENT(IN) :: comm
5771
5772 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i_src'
5773
5774 INTEGER :: handle
5775#if defined(__parallel)
5776 INTEGER :: ierr, msglen
5777#endif
5778
5779 CALL mp_timeset(routinen, handle)
5780
5781#if defined(__parallel)
5782 msglen = 1
5783 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
5784 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5785 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5786#else
5787 mark_used(msg)
5788 mark_used(comm)
5789#endif
5790 CALL mp_timestop(handle)
5791 END SUBROUTINE mp_bcast_i_src
5792
5793! **************************************************************************************************
5794!> \brief Broadcasts a datum to all processes.
5795!> \param[in] msg Datum to broadcast
5796!> \param[in] source Processes which broadcasts
5797!> \param[in] comm Message passing environment identifier
5798!> \par MPI mapping
5799!> mpi_bcast
5800! **************************************************************************************************
5801 SUBROUTINE mp_ibcast_i (msg, source, comm, request)
5802 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5803 INTEGER, INTENT(IN) :: source
5804 CLASS(mp_comm_type), INTENT(IN) :: comm
5805 TYPE(mp_request_type), INTENT(OUT) :: request
5806
5807 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_i'
5808
5809 INTEGER :: handle
5810#if defined(__parallel)
5811 INTEGER :: ierr, msglen
5812#endif
5813
5814 CALL mp_timeset(routinen, handle)
5815
5816#if defined(__parallel)
5817 msglen = 1
5818 CALL mpi_ibcast(msg, msglen, mpi_integer, source, comm%handle, request%handle, ierr)
5819 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
5820 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_4_size)
5821#else
5822 mark_used(msg)
5823 mark_used(source)
5824 mark_used(comm)
5825 request = mp_request_null
5826#endif
5827 CALL mp_timestop(handle)
5828 END SUBROUTINE mp_ibcast_i
5829
5830! **************************************************************************************************
5831!> \brief Broadcasts rank-1 data to all processes
5832!> \param[in] msg Data to broadcast
5833!> \param source ...
5834!> \param comm ...
5835!> \note see mp_bcast_i1
5836! **************************************************************************************************
5837 SUBROUTINE mp_bcast_iv(msg, source, comm)
5838 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5839 INTEGER, INTENT(IN) :: source
5840 CLASS(mp_comm_type), INTENT(IN) :: comm
5841
5842 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_iv'
5843
5844 INTEGER :: handle
5845#if defined(__parallel)
5846 INTEGER :: ierr, msglen
5847#endif
5848
5849 CALL mp_timeset(routinen, handle)
5850
5851#if defined(__parallel)
5852 msglen = SIZE(msg)
5853 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
5854 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5855 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5856#else
5857 mark_used(msg)
5858 mark_used(source)
5859 mark_used(comm)
5860#endif
5861 CALL mp_timestop(handle)
5862 END SUBROUTINE mp_bcast_iv
5863
5864! **************************************************************************************************
5865!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
5866!> \param[in] msg Data to broadcast
5867!> \param comm ...
5868!> \note see mp_bcast_i1
5869! **************************************************************************************************
5870 SUBROUTINE mp_bcast_iv_src(msg, comm)
5871 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5872 CLASS(mp_comm_type), INTENT(IN) :: comm
5873
5874 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_iv_src'
5875
5876 INTEGER :: handle
5877#if defined(__parallel)
5878 INTEGER :: ierr, msglen
5879#endif
5880
5881 CALL mp_timeset(routinen, handle)
5882
5883#if defined(__parallel)
5884 msglen = SIZE(msg)
5885 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
5886 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5887 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5888#else
5889 mark_used(msg)
5890 mark_used(comm)
5891#endif
5892 CALL mp_timestop(handle)
5893 END SUBROUTINE mp_bcast_iv_src
5894
5895! **************************************************************************************************
5896!> \brief Broadcasts rank-1 data to all processes
5897!> \param[in] msg Data to broadcast
5898!> \param source ...
5899!> \param comm ...
5900!> \note see mp_bcast_i1
5901! **************************************************************************************************
5902 SUBROUTINE mp_ibcast_iv(msg, source, comm, request)
5903 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
5904 INTEGER, INTENT(IN) :: source
5905 CLASS(mp_comm_type), INTENT(IN) :: comm
5906 TYPE(mp_request_type) :: request
5907
5908 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_iv'
5909
5910 INTEGER :: handle
5911#if defined(__parallel)
5912 INTEGER :: ierr, msglen
5913#endif
5914
5915 CALL mp_timeset(routinen, handle)
5916
5917#if defined(__parallel)
5918#if !defined(__GNUC__) || __GNUC__ >= 9
5919 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
5920#endif
5921 msglen = SIZE(msg)
5922 CALL mpi_ibcast(msg, msglen, mpi_integer, source, comm%handle, request%handle, ierr)
5923 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
5924 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_4_size)
5925#else
5926 mark_used(msg)
5927 mark_used(source)
5928 mark_used(comm)
5929 request = mp_request_null
5930#endif
5931 CALL mp_timestop(handle)
5932 END SUBROUTINE mp_ibcast_iv
5933
5934! **************************************************************************************************
5935!> \brief Broadcasts rank-2 data to all processes
5936!> \param[in] msg Data to broadcast
5937!> \param source ...
5938!> \param comm ...
5939!> \note see mp_bcast_i1
5940! **************************************************************************************************
5941 SUBROUTINE mp_bcast_im(msg, source, comm)
5942 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5943 INTEGER, INTENT(IN) :: source
5944 CLASS(mp_comm_type), INTENT(IN) :: comm
5945
5946 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_im'
5947
5948 INTEGER :: handle
5949#if defined(__parallel)
5950 INTEGER :: ierr, msglen
5951#endif
5952
5953 CALL mp_timeset(routinen, handle)
5954
5955#if defined(__parallel)
5956 msglen = SIZE(msg)
5957 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
5958 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5959 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5960#else
5961 mark_used(msg)
5962 mark_used(source)
5963 mark_used(comm)
5964#endif
5965 CALL mp_timestop(handle)
5966 END SUBROUTINE mp_bcast_im
5967
5968! **************************************************************************************************
5969!> \brief Broadcasts rank-2 data to all processes
5970!> \param[in] msg Data to broadcast
5971!> \param source ...
5972!> \param comm ...
5973!> \note see mp_bcast_i1
5974! **************************************************************************************************
5975 SUBROUTINE mp_bcast_im_src(msg, comm)
5976 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5977 CLASS(mp_comm_type), INTENT(IN) :: comm
5978
5979 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_im_src'
5980
5981 INTEGER :: handle
5982#if defined(__parallel)
5983 INTEGER :: ierr, msglen
5984#endif
5985
5986 CALL mp_timeset(routinen, handle)
5987
5988#if defined(__parallel)
5989 msglen = SIZE(msg)
5990 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
5991 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5992 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5993#else
5994 mark_used(msg)
5995 mark_used(comm)
5996#endif
5997 CALL mp_timestop(handle)
5998 END SUBROUTINE mp_bcast_im_src
5999
6000! **************************************************************************************************
6001!> \brief Broadcasts rank-3 data to all processes
6002!> \param[in] msg Data to broadcast
6003!> \param source ...
6004!> \param comm ...
6005!> \note see mp_bcast_i1
6006! **************************************************************************************************
6007 SUBROUTINE mp_bcast_i3(msg, source, comm)
6008 INTEGER(KIND=int_4), CONTIGUOUS :: msg(:, :, :)
6009 INTEGER, INTENT(IN) :: source
6010 CLASS(mp_comm_type), INTENT(IN) :: comm
6011
6012 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i3'
6013
6014 INTEGER :: handle
6015#if defined(__parallel)
6016 INTEGER :: ierr, msglen
6017#endif
6018
6019 CALL mp_timeset(routinen, handle)
6020
6021#if defined(__parallel)
6022 msglen = SIZE(msg)
6023 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
6024 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6025 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6026#else
6027 mark_used(msg)
6028 mark_used(source)
6029 mark_used(comm)
6030#endif
6031 CALL mp_timestop(handle)
6032 END SUBROUTINE mp_bcast_i3
6033
6034! **************************************************************************************************
6035!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
6036!> \param[in] msg Data to broadcast
6037!> \param source ...
6038!> \param comm ...
6039!> \note see mp_bcast_i1
6040! **************************************************************************************************
6041 SUBROUTINE mp_bcast_i3_src(msg, comm)
6042 INTEGER(KIND=int_4), CONTIGUOUS :: msg(:, :, :)
6043 CLASS(mp_comm_type), INTENT(IN) :: comm
6044
6045 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i3_src'
6046
6047 INTEGER :: handle
6048#if defined(__parallel)
6049 INTEGER :: ierr, msglen
6050#endif
6051
6052 CALL mp_timeset(routinen, handle)
6053
6054#if defined(__parallel)
6055 msglen = SIZE(msg)
6056 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
6057 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6058 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6059#else
6060 mark_used(msg)
6061 mark_used(comm)
6062#endif
6063 CALL mp_timestop(handle)
6064 END SUBROUTINE mp_bcast_i3_src
6065
6066! **************************************************************************************************
6067!> \brief Sums a datum from all processes with result left on all processes.
6068!> \param[in,out] msg Datum to sum (input) and result (output)
6069!> \param[in] comm Message passing environment identifier
6070!> \par MPI mapping
6071!> mpi_allreduce
6072! **************************************************************************************************
6073 SUBROUTINE mp_sum_i (msg, comm)
6074 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6075 CLASS(mp_comm_type), INTENT(IN) :: comm
6076
6077 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_i'
6078
6079 INTEGER :: handle
6080#if defined(__parallel)
6081 INTEGER :: ierr, msglen
6082 INTEGER(KIND=int_4) :: res
6083#endif
6084
6085 CALL mp_timeset(routinen, handle)
6086
6087#if defined(__parallel)
6088 msglen = 1
6089 IF (comm%num_pe > 1) THEN
6090 CALL mpi_allreduce(msg, res, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6091 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6092 msg = res
6093 END IF
6094 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6095#else
6096 mark_used(msg)
6097 mark_used(comm)
6098#endif
6099 CALL mp_timestop(handle)
6100 END SUBROUTINE mp_sum_i
6101
6102! **************************************************************************************************
6103!> \brief Element-wise sum of a rank-1 array on all processes.
6104!> \param[in,out] msg Vector to sum and result
6105!> \param comm ...
6106!> \note see mp_sum_i
6107! **************************************************************************************************
6108 SUBROUTINE mp_sum_iv(msg, comm)
6109 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6110 CLASS(mp_comm_type), INTENT(IN) :: comm
6111
6112 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_iv'
6113
6114 INTEGER :: handle
6115#if defined(__parallel)
6116 INTEGER :: ierr, msglen
6117 INTEGER(KIND=int_4), ALLOCATABLE :: msgbuf(:)
6118#endif
6119
6120 CALL mp_timeset(routinen, handle)
6121
6122#if defined(__parallel)
6123 msglen = SIZE(msg)
6124 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6125 ALLOCATE (msgbuf(msglen))
6126 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6127 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6128 msg = msgbuf
6129 END IF
6130 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6131#else
6132 mark_used(msg)
6133 mark_used(comm)
6134#endif
6135 CALL mp_timestop(handle)
6136 END SUBROUTINE mp_sum_iv
6137
6138! **************************************************************************************************
6139!> \brief Element-wise sum of a rank-1 array on all processes.
6140!> \param[in,out] msg Vector to sum and result
6141!> \param comm ...
6142!> \note see mp_sum_i
6143! **************************************************************************************************
6144 SUBROUTINE mp_isum_iv(msg, comm, request)
6145 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6146 CLASS(mp_comm_type), INTENT(IN) :: comm
6147 TYPE(mp_request_type), INTENT(OUT) :: request
6148
6149 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_iv'
6150
6151 INTEGER :: handle
6152#if defined(__parallel)
6153 INTEGER :: ierr, msglen
6154#endif
6155
6156 CALL mp_timeset(routinen, handle)
6157
6158#if defined(__parallel)
6159#if !defined(__GNUC__) || __GNUC__ >= 9
6160 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
6161#endif
6162 msglen = SIZE(msg)
6163 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6164 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, request%handle, ierr)
6165 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
6166 ELSE
6167 request = mp_request_null
6168 END IF
6169 CALL add_perf(perf_id=23, count=1, msg_size=msglen*int_4_size)
6170#else
6171 mark_used(msg)
6172 mark_used(comm)
6173 request = mp_request_null
6174#endif
6175 CALL mp_timestop(handle)
6176 END SUBROUTINE mp_isum_iv
6177
6178! **************************************************************************************************
6179!> \brief Element-wise sum of a rank-2 array on all processes.
6180!> \param[in] msg Matrix to sum and result
6181!> \param comm ...
6182!> \note see mp_sum_i
6183! **************************************************************************************************
6184 SUBROUTINE mp_sum_im(msg, comm)
6185 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6186 CLASS(mp_comm_type), INTENT(IN) :: comm
6187
6188 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im'
6189
6190 INTEGER :: handle
6191#if defined(__parallel)
6192 INTEGER, PARAMETER :: max_msg = 2**25
6193 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
6194 INTEGER(KIND=int_4), ALLOCATABLE :: msgbuf(:)
6195#endif
6196
6197 CALL mp_timeset(routinen, handle)
6198
6199#if defined(__parallel)
6200 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
6201 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
6202 msglensum = 0
6203 DO m1 = lbound(msg, 2), ubound(msg, 2), step
6204 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
6205 msglensum = msglensum + msglen
6206 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6207 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
6208 ALLOCATE (msgbuf(msglen))
6209 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6210 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6211 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
6212 DEALLOCATE (msgbuf)
6213 END IF
6214 END DO
6215 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_4_size)
6216#else
6217 mark_used(msg)
6218 mark_used(comm)
6219#endif
6220 CALL mp_timestop(handle)
6221 END SUBROUTINE mp_sum_im
6222
6223! **************************************************************************************************
6224!> \brief Element-wise sum of a rank-3 array on all processes.
6225!> \param[in] msg Array to sum and result
6226!> \param comm ...
6227!> \note see mp_sum_i
6228! **************************************************************************************************
6229 SUBROUTINE mp_sum_im3(msg, comm)
6230 INTEGER(KIND=int_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
6231 CLASS(mp_comm_type), INTENT(IN) :: comm
6232
6233 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im3'
6234
6235 INTEGER :: handle
6236#if defined(__parallel)
6237 INTEGER :: ierr, msglen
6238 INTEGER(KIND=int_4), ALLOCATABLE :: msgbuf(:)
6239#endif
6240
6241 CALL mp_timeset(routinen, handle)
6242
6243#if defined(__parallel)
6244 msglen = SIZE(msg)
6245 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6246 ALLOCATE (msgbuf(msglen))
6247 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6248 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6249 msg = reshape(msgbuf, shape(msg))
6250 END IF
6251 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6252#else
6253 mark_used(msg)
6254 mark_used(comm)
6255#endif
6256 CALL mp_timestop(handle)
6257 END SUBROUTINE mp_sum_im3
6258
6259! **************************************************************************************************
6260!> \brief Element-wise sum of a rank-4 array on all processes.
6261!> \param[in] msg Array to sum and result
6262!> \param comm ...
6263!> \note see mp_sum_i
6264! **************************************************************************************************
6265 SUBROUTINE mp_sum_im4(msg, comm)
6266 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
6267 CLASS(mp_comm_type), INTENT(IN) :: comm
6268
6269 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im4'
6270
6271 INTEGER :: handle
6272#if defined(__parallel)
6273 INTEGER :: ierr, msglen
6274 INTEGER(KIND=int_4), ALLOCATABLE :: msgbuf(:)
6275#endif
6276
6277 CALL mp_timeset(routinen, handle)
6278
6279#if defined(__parallel)
6280 msglen = SIZE(msg)
6281 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6282 ALLOCATE (msgbuf(msglen))
6283 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6284 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6285 msg = reshape(msgbuf, shape(msg))
6286 END IF
6287 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6288#else
6289 mark_used(msg)
6290 mark_used(comm)
6291#endif
6292 CALL mp_timestop(handle)
6293 END SUBROUTINE mp_sum_im4
6294
6295! **************************************************************************************************
6296!> \brief Element-wise sum of data from all processes with result left only on
6297!> one.
6298!> \param[in,out] msg Vector to sum (input) and (only on process root)
6299!> result (output)
6300!> \param root ...
6301!> \param[in] comm Message passing environment identifier
6302!> \par MPI mapping
6303!> mpi_reduce
6304! **************************************************************************************************
6305 SUBROUTINE mp_sum_root_iv(msg, root, comm)
6306 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6307 INTEGER, INTENT(IN) :: root
6308 CLASS(mp_comm_type), INTENT(IN) :: comm
6309
6310 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_iv'
6311
6312 INTEGER :: handle
6313#if defined(__parallel)
6314 INTEGER :: ierr, m1, msglen, taskid
6315 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
6316#endif
6317
6318 CALL mp_timeset(routinen, handle)
6319
6320#if defined(__parallel)
6321 msglen = SIZE(msg)
6322 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6323 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6324 IF (msglen > 0) THEN
6325 m1 = SIZE(msg, 1)
6326 ALLOCATE (res(m1))
6327 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_sum, &
6328 root, comm%handle, ierr)
6329 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6330 IF (taskid == root) THEN
6331 msg = res
6332 END IF
6333 DEALLOCATE (res)
6334 END IF
6335 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6336#else
6337 mark_used(msg)
6338 mark_used(root)
6339 mark_used(comm)
6340#endif
6341 CALL mp_timestop(handle)
6342 END SUBROUTINE mp_sum_root_iv
6343
6344! **************************************************************************************************
6345!> \brief Element-wise sum of data from all processes with result left only on
6346!> one.
6347!> \param[in,out] msg Matrix to sum (input) and (only on process root)
6348!> result (output)
6349!> \param root ...
6350!> \param comm ...
6351!> \note see mp_sum_root_iv
6352! **************************************************************************************************
6353 SUBROUTINE mp_sum_root_im(msg, root, comm)
6354 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6355 INTEGER, INTENT(IN) :: root
6356 CLASS(mp_comm_type), INTENT(IN) :: comm
6357
6358 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
6359
6360 INTEGER :: handle
6361#if defined(__parallel)
6362 INTEGER :: ierr, m1, m2, msglen, taskid
6363 INTEGER(KIND=int_4), ALLOCATABLE :: res(:, :)
6364#endif
6365
6366 CALL mp_timeset(routinen, handle)
6367
6368#if defined(__parallel)
6369 msglen = SIZE(msg)
6370 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6371 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6372 IF (msglen > 0) THEN
6373 m1 = SIZE(msg, 1)
6374 m2 = SIZE(msg, 2)
6375 ALLOCATE (res(m1, m2))
6376 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_sum, root, comm%handle, ierr)
6377 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6378 IF (taskid == root) THEN
6379 msg = res
6380 END IF
6381 DEALLOCATE (res)
6382 END IF
6383 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6384#else
6385 mark_used(root)
6386 mark_used(msg)
6387 mark_used(comm)
6388#endif
6389 CALL mp_timestop(handle)
6390 END SUBROUTINE mp_sum_root_im
6391
6392! **************************************************************************************************
6393!> \brief Partial sum of data from all processes with result on each process.
6394!> \param[in] msg Matrix to sum (input)
6395!> \param[out] res Matrix containing result (output)
6396!> \param[in] comm Message passing environment identifier
6397! **************************************************************************************************
6398 SUBROUTINE mp_sum_partial_im(msg, res, comm)
6399 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
6400 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
6401 CLASS(mp_comm_type), INTENT(IN) :: comm
6402
6403 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_im'
6404
6405 INTEGER :: handle
6406#if defined(__parallel)
6407 INTEGER :: ierr, msglen, taskid
6408#endif
6409
6410 CALL mp_timeset(routinen, handle)
6411
6412#if defined(__parallel)
6413 msglen = SIZE(msg)
6414 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6415 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6416 IF (msglen > 0) THEN
6417 CALL mpi_scan(msg, res, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6418 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
6419 END IF
6420 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6421 ! perf_id is same as for other summation routines
6422#else
6423 res = msg
6424 mark_used(comm)
6425#endif
6426 CALL mp_timestop(handle)
6427 END SUBROUTINE mp_sum_partial_im
6428
6429! **************************************************************************************************
6430!> \brief Finds the maximum of a datum with the result left on all processes.
6431!> \param[in,out] msg Find maximum among these data (input) and
6432!> maximum (output)
6433!> \param[in] comm Message passing environment identifier
6434!> \par MPI mapping
6435!> mpi_allreduce
6436! **************************************************************************************************
6437 SUBROUTINE mp_max_i (msg, comm)
6438 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6439 CLASS(mp_comm_type), INTENT(IN) :: comm
6440
6441 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_i'
6442
6443 INTEGER :: handle
6444#if defined(__parallel)
6445 INTEGER :: ierr, msglen
6446 INTEGER(KIND=int_4) :: res
6447#endif
6448
6449 CALL mp_timeset(routinen, handle)
6450
6451#if defined(__parallel)
6452 msglen = 1
6453 IF (comm%num_pe > 1) THEN
6454 CALL mpi_allreduce(msg, res, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6455 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6456 msg = res
6457 END IF
6458 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6459#else
6460 mark_used(msg)
6461 mark_used(comm)
6462#endif
6463 CALL mp_timestop(handle)
6464 END SUBROUTINE mp_max_i
6465
6466! **************************************************************************************************
6467!> \brief Finds the maximum of a datum with the result left on all processes.
6468!> \param[in,out] msg Find maximum among these data (input) and
6469!> maximum (output)
6470!> \param[in] comm Message passing environment identifier
6471!> \par MPI mapping
6472!> mpi_allreduce
6473! **************************************************************************************************
6474 SUBROUTINE mp_max_root_i (msg, root, comm)
6475 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6476 INTEGER, INTENT(IN) :: root
6477 CLASS(mp_comm_type), INTENT(IN) :: comm
6478
6479 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_i'
6480
6481 INTEGER :: handle
6482#if defined(__parallel)
6483 INTEGER :: ierr, msglen
6484 INTEGER(KIND=int_4) :: res
6485#endif
6486
6487 CALL mp_timeset(routinen, handle)
6488
6489#if defined(__parallel)
6490 msglen = 1
6491 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_max, root, comm%handle, ierr)
6492 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6493 IF (root == comm%mepos) msg = res
6494 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6495#else
6496 mark_used(msg)
6497 mark_used(comm)
6498 mark_used(root)
6499#endif
6500 CALL mp_timestop(handle)
6501 END SUBROUTINE mp_max_root_i
6502
6503! **************************************************************************************************
6504!> \brief Finds the element-wise maximum of a vector with the result left on
6505!> all processes.
6506!> \param[in,out] msg Find maximum among these data (input) and
6507!> maximum (output)
6508!> \param comm ...
6509!> \note see mp_max_i
6510! **************************************************************************************************
6511 SUBROUTINE mp_max_iv(msg, comm)
6512 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6513 CLASS(mp_comm_type), INTENT(IN) :: comm
6514
6515 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_iv'
6516
6517 INTEGER :: handle
6518#if defined(__parallel)
6519 INTEGER :: ierr, msglen
6520 INTEGER(KIND=int_4), ALLOCATABLE :: msgbuf(:)
6521#endif
6522
6523 CALL mp_timeset(routinen, handle)
6524
6525#if defined(__parallel)
6526 msglen = SIZE(msg)
6527 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6528 ALLOCATE (msgbuf(msglen))
6529 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6530 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6531 msg = msgbuf
6532 END IF
6533 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6534#else
6535 mark_used(msg)
6536 mark_used(comm)
6537#endif
6538 CALL mp_timestop(handle)
6539 END SUBROUTINE mp_max_iv
6540
6541! **************************************************************************************************
6542!> \brief Finds the element-wise maximum of a rank2-array with the result left on
6543!> all processes.
6544!> \param[in] msg Matrix - Find maximum among these data (input) and
6545!> maximum (output)
6546!> \param comm ...
6547!> \note see mp_max_i
6548! **************************************************************************************************
6549 SUBROUTINE mp_max_im(msg, comm)
6550 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6551 CLASS(mp_comm_type), INTENT(IN) :: comm
6552
6553 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_im'
6554
6555 INTEGER :: handle
6556#if defined(__parallel)
6557 INTEGER, PARAMETER :: max_msg = 2**25
6558 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
6559 INTEGER(KIND=int_4), ALLOCATABLE :: msgbuf(:)
6560#endif
6561
6562 CALL mp_timeset(routinen, handle)
6563
6564#if defined(__parallel)
6565 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
6566 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
6567 msglensum = 0
6568 DO m1 = lbound(msg, 2), ubound(msg, 2), step
6569 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
6570 msglensum = msglensum + msglen
6571 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6572 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
6573 ALLOCATE (msgbuf(msglen))
6574 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6575 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6576 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
6577 DEALLOCATE (msgbuf)
6578 END IF
6579 END DO
6580 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_4_size)
6581#else
6582 mark_used(msg)
6583 mark_used(comm)
6584#endif
6585 CALL mp_timestop(handle)
6586 END SUBROUTINE mp_max_im
6587
6588! **************************************************************************************************
6589!> \brief Finds the element-wise maximum of a vector with the result left on
6590!> all processes.
6591!> \param[in,out] msg Find maximum among these data (input) and
6592!> maximum (output)
6593!> \param comm ...
6594!> \note see mp_max_i
6595! **************************************************************************************************
6596 SUBROUTINE mp_max_root_im(msg, root, comm)
6597 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6598 INTEGER :: root
6599 CLASS(mp_comm_type), INTENT(IN) :: comm
6600
6601 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_im'
6602
6603 INTEGER :: handle
6604#if defined(__parallel)
6605 INTEGER :: ierr, msglen
6606 INTEGER(KIND=int_4) :: res(size(msg, 1), size(msg, 2))
6607#endif
6608
6609 CALL mp_timeset(routinen, handle)
6610
6611#if defined(__parallel)
6612 msglen = SIZE(msg)
6613 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_max, root, comm%handle, ierr)
6614 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6615 IF (root == comm%mepos) msg = res
6616 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6617#else
6618 mark_used(msg)
6619 mark_used(comm)
6620 mark_used(root)
6621#endif
6622 CALL mp_timestop(handle)
6623 END SUBROUTINE mp_max_root_im
6624
6625! **************************************************************************************************
6626!> \brief Finds the minimum of a datum with the result left on all processes.
6627!> \param[in,out] msg Find minimum among these data (input) and
6628!> maximum (output)
6629!> \param[in] comm Message passing environment identifier
6630!> \par MPI mapping
6631!> mpi_allreduce
6632! **************************************************************************************************
6633 SUBROUTINE mp_min_i (msg, comm)
6634 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6635 CLASS(mp_comm_type), INTENT(IN) :: comm
6636
6637 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_i'
6638
6639 INTEGER :: handle
6640#if defined(__parallel)
6641 INTEGER :: ierr, msglen
6642 INTEGER(KIND=int_4) :: res
6643#endif
6644
6645 CALL mp_timeset(routinen, handle)
6646
6647#if defined(__parallel)
6648 msglen = 1
6649 IF (comm%num_pe > 1) THEN
6650 CALL mpi_allreduce(msg, res, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6651 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6652 msg = res
6653 END IF
6654 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6655#else
6656 mark_used(msg)
6657 mark_used(comm)
6658#endif
6659 CALL mp_timestop(handle)
6660 END SUBROUTINE mp_min_i
6661
6662! **************************************************************************************************
6663!> \brief Finds the element-wise minimum of vector with the result left on
6664!> all processes.
6665!> \param[in,out] msg Find minimum among these data (input) and
6666!> maximum (output)
6667!> \param comm ...
6668!> \par MPI mapping
6669!> mpi_allreduce
6670!> \note see mp_min_i
6671! **************************************************************************************************
6672 SUBROUTINE mp_min_iv(msg, comm)
6673 INTEGER(KIND=int_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
6674 CLASS(mp_comm_type), INTENT(IN) :: comm
6675
6676 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_iv'
6677
6678 INTEGER :: handle
6679#if defined(__parallel)
6680 INTEGER :: ierr, msglen
6681 INTEGER(KIND=int_4), ALLOCATABLE :: msgbuf(:)
6682#endif
6683
6684 CALL mp_timeset(routinen, handle)
6685
6686#if defined(__parallel)
6687 msglen = SIZE(msg)
6688 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6689 ALLOCATE (msgbuf(msglen))
6690 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6691 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6692 msg = msgbuf
6693 END IF
6694 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6695#else
6696 mark_used(msg)
6697 mark_used(comm)
6698#endif
6699 CALL mp_timestop(handle)
6700 END SUBROUTINE mp_min_iv
6701
6702! **************************************************************************************************
6703!> \brief Finds the element-wise minimum of a rank2-array with the result left on
6704!> all processes.
6705!> \param[in] msg Matrix - Find maximum among these data (input) and
6706!> minimum (output)
6707!> \param comm ...
6708!> \note see mp_min_i
6709! **************************************************************************************************
6710 SUBROUTINE mp_min_im(msg, comm)
6711 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6712 CLASS(mp_comm_type), INTENT(IN) :: comm
6713
6714 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_im'
6715
6716 INTEGER :: handle
6717#if defined(__parallel)
6718 INTEGER, PARAMETER :: max_msg = 2**25
6719 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
6720 INTEGER(KIND=int_4), ALLOCATABLE :: msgbuf(:)
6721#endif
6722
6723 CALL mp_timeset(routinen, handle)
6724
6725#if defined(__parallel)
6726 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
6727 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
6728 msglensum = 0
6729 DO m1 = lbound(msg, 2), ubound(msg, 2), step
6730 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
6731 msglensum = msglensum + msglen
6732 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
6733 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
6734 ALLOCATE (msgbuf(msglen))
6735 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6736 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6737 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
6738 DEALLOCATE (msgbuf)
6739 END IF
6740 END DO
6741 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_4_size)
6742#else
6743 mark_used(msg)
6744 mark_used(comm)
6745#endif
6746 CALL mp_timestop(handle)
6747 END SUBROUTINE mp_min_im
6748
6749! **************************************************************************************************
6750!> \brief Multiplies a set of numbers scattered across a number of processes,
6751!> then replicates the result.
6752!> \param[in,out] msg a number to multiply (input) and result (output)
6753!> \param[in] comm message passing environment identifier
6754!> \par MPI mapping
6755!> mpi_allreduce
6756! **************************************************************************************************
6757 SUBROUTINE mp_prod_i (msg, comm)
6758 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6759 CLASS(mp_comm_type), INTENT(IN) :: comm
6760
6761 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_i'
6762
6763 INTEGER :: handle
6764#if defined(__parallel)
6765 INTEGER :: ierr, msglen
6766 INTEGER(KIND=int_4) :: res
6767#endif
6768
6769 CALL mp_timeset(routinen, handle)
6770
6771#if defined(__parallel)
6772 msglen = 1
6773 IF (comm%num_pe > 1) THEN
6774 CALL mpi_allreduce(msg, res, msglen, mpi_integer, mpi_prod, comm%handle, ierr)
6775 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6776 msg = res
6777 END IF
6778 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6779#else
6780 mark_used(msg)
6781 mark_used(comm)
6782#endif
6783 CALL mp_timestop(handle)
6784 END SUBROUTINE mp_prod_i
6785
6786! **************************************************************************************************
6787!> \brief Scatters data from one processes to all others
6788!> \param[in] msg_scatter Data to scatter (for root process)
6789!> \param[out] msg Received data
6790!> \param[in] root Process which scatters data
6791!> \param[in] comm Message passing environment identifier
6792!> \par MPI mapping
6793!> mpi_scatter
6794! **************************************************************************************************
6795 SUBROUTINE mp_scatter_iv(msg_scatter, msg, root, comm)
6796 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
6797 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
6798 INTEGER, INTENT(IN) :: root
6799 CLASS(mp_comm_type), INTENT(IN) :: comm
6800
6801 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_iv'
6802
6803 INTEGER :: handle
6804#if defined(__parallel)
6805 INTEGER :: ierr, msglen
6806#endif
6807
6808 CALL mp_timeset(routinen, handle)
6809
6810#if defined(__parallel)
6811 msglen = SIZE(msg)
6812 CALL mpi_scatter(msg_scatter, msglen, mpi_integer, msg, &
6813 msglen, mpi_integer, root, comm%handle, ierr)
6814 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
6815 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6816#else
6817 mark_used(root)
6818 mark_used(comm)
6819 msg = msg_scatter
6820#endif
6821 CALL mp_timestop(handle)
6822 END SUBROUTINE mp_scatter_iv
6823
6824! **************************************************************************************************
6825!> \brief Scatters data from one processes to all others
6826!> \param[in] msg_scatter Data to scatter (for root process)
6827!> \param[in] root Process which scatters data
6828!> \param[in] comm Message passing environment identifier
6829!> \par MPI mapping
6830!> mpi_scatter
6831! **************************************************************************************************
6832 SUBROUTINE mp_iscatter_i (msg_scatter, msg, root, comm, request)
6833 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:)
6834 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6835 INTEGER, INTENT(IN) :: root
6836 CLASS(mp_comm_type), INTENT(IN) :: comm
6837 TYPE(mp_request_type), INTENT(OUT) :: request
6838
6839 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_i'
6840
6841 INTEGER :: handle
6842#if defined(__parallel)
6843 INTEGER :: ierr, msglen
6844#endif
6845
6846 CALL mp_timeset(routinen, handle)
6847
6848#if defined(__parallel)
6849#if !defined(__GNUC__) || __GNUC__ >= 9
6850 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
6851#endif
6852 msglen = 1
6853 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer, msg, &
6854 msglen, mpi_integer, root, comm%handle, request%handle, ierr)
6855 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
6856 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6857#else
6858 mark_used(root)
6859 mark_used(comm)
6860 msg = msg_scatter(1)
6861 request = mp_request_null
6862#endif
6863 CALL mp_timestop(handle)
6864 END SUBROUTINE mp_iscatter_i
6865
6866! **************************************************************************************************
6867!> \brief Scatters data from one processes to all others
6868!> \param[in] msg_scatter Data to scatter (for root process)
6869!> \param[in] root Process which scatters data
6870!> \param[in] comm Message passing environment identifier
6871!> \par MPI mapping
6872!> mpi_scatter
6873! **************************************************************************************************
6874 SUBROUTINE mp_iscatter_iv2(msg_scatter, msg, root, comm, request)
6875 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:, :)
6876 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6877 INTEGER, INTENT(IN) :: root
6878 CLASS(mp_comm_type), INTENT(IN) :: comm
6879 TYPE(mp_request_type), INTENT(OUT) :: request
6880
6881 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_iv2'
6882
6883 INTEGER :: handle
6884#if defined(__parallel)
6885 INTEGER :: ierr, msglen
6886#endif
6887
6888 CALL mp_timeset(routinen, handle)
6889
6890#if defined(__parallel)
6891#if !defined(__GNUC__) || __GNUC__ >= 9
6892 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
6893#endif
6894 msglen = SIZE(msg)
6895 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer, msg, &
6896 msglen, mpi_integer, root, comm%handle, request%handle, ierr)
6897 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
6898 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6899#else
6900 mark_used(root)
6901 mark_used(comm)
6902 msg(:) = msg_scatter(:, 1)
6903 request = mp_request_null
6904#endif
6905 CALL mp_timestop(handle)
6906 END SUBROUTINE mp_iscatter_iv2
6907
6908! **************************************************************************************************
6909!> \brief Scatters data from one processes to all others
6910!> \param[in] msg_scatter Data to scatter (for root process)
6911!> \param[in] root Process which scatters data
6912!> \param[in] comm Message passing environment identifier
6913!> \par MPI mapping
6914!> mpi_scatter
6915! **************************************************************************************************
6916 SUBROUTINE mp_iscatterv_iv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
6917 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:)
6918 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
6919 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6920 INTEGER, INTENT(IN) :: recvcount, root
6921 CLASS(mp_comm_type), INTENT(IN) :: comm
6922 TYPE(mp_request_type), INTENT(OUT) :: request
6923
6924 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_iv'
6925
6926 INTEGER :: handle
6927#if defined(__parallel)
6928 INTEGER :: ierr
6929#endif
6930
6931 CALL mp_timeset(routinen, handle)
6932
6933#if defined(__parallel)
6934#if !defined(__GNUC__) || __GNUC__ >= 9
6935 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
6936 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
6937 cpassert(is_contiguous(sendcounts) .OR. SIZE(sendcounts) == 0)
6938 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
6939#endif
6940 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_integer, msg, &
6941 recvcount, mpi_integer, root, comm%handle, request%handle, ierr)
6942 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
6943 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6944#else
6945 mark_used(sendcounts)
6946 mark_used(displs)
6947 mark_used(recvcount)
6948 mark_used(root)
6949 mark_used(comm)
6950 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
6951 request = mp_request_null
6952#endif
6953 CALL mp_timestop(handle)
6954 END SUBROUTINE mp_iscatterv_iv
6955
6956! **************************************************************************************************
6957!> \brief Gathers a datum from all processes to one
6958!> \param[in] msg Datum to send to root
6959!> \param[out] msg_gather Received data (on root)
6960!> \param[in] root Process which gathers the data
6961!> \param[in] comm Message passing environment identifier
6962!> \par MPI mapping
6963!> mpi_gather
6964! **************************************************************************************************
6965 SUBROUTINE mp_gather_i (msg, msg_gather, root, comm)
6966 INTEGER(KIND=int_4), INTENT(IN) :: msg
6967 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
6968 INTEGER, INTENT(IN) :: root
6969 CLASS(mp_comm_type), INTENT(IN) :: comm
6970
6971 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_i'
6972
6973 INTEGER :: handle
6974#if defined(__parallel)
6975 INTEGER :: ierr, msglen
6976#endif
6977
6978 CALL mp_timeset(routinen, handle)
6979
6980#if defined(__parallel)
6981 msglen = 1
6982 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
6983 msglen, mpi_integer, root, comm%handle, ierr)
6984 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
6985 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6986#else
6987 mark_used(root)
6988 mark_used(comm)
6989 msg_gather(1) = msg
6990#endif
6991 CALL mp_timestop(handle)
6992 END SUBROUTINE mp_gather_i
6993
6994! **************************************************************************************************
6995!> \brief Gathers a datum from all processes to one, uses the source process of comm
6996!> \param[in] msg Datum to send to root
6997!> \param[out] msg_gather Received data (on root)
6998!> \param[in] comm Message passing environment identifier
6999!> \par MPI mapping
7000!> mpi_gather
7001! **************************************************************************************************
7002 SUBROUTINE mp_gather_i_src(msg, msg_gather, comm)
7003 INTEGER(KIND=int_4), INTENT(IN) :: msg
7004 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7005 CLASS(mp_comm_type), INTENT(IN) :: comm
7006
7007 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_i_src'
7008
7009 INTEGER :: handle
7010#if defined(__parallel)
7011 INTEGER :: ierr, msglen
7012#endif
7013
7014 CALL mp_timeset(routinen, handle)
7015
7016#if defined(__parallel)
7017 msglen = 1
7018 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7019 msglen, mpi_integer, comm%source, comm%handle, ierr)
7020 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7021 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7022#else
7023 mark_used(comm)
7024 msg_gather(1) = msg
7025#endif
7026 CALL mp_timestop(handle)
7027 END SUBROUTINE mp_gather_i_src
7028
7029! **************************************************************************************************
7030!> \brief Gathers data from all processes to one
7031!> \param[in] msg Datum to send to root
7032!> \param msg_gather ...
7033!> \param root ...
7034!> \param comm ...
7035!> \par Data length
7036!> All data (msg) is equal-sized
7037!> \par MPI mapping
7038!> mpi_gather
7039!> \note see mp_gather_i
7040! **************************************************************************************************
7041 SUBROUTINE mp_gather_iv(msg, msg_gather, root, comm)
7042 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
7043 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7044 INTEGER, INTENT(IN) :: root
7045 CLASS(mp_comm_type), INTENT(IN) :: comm
7046
7047 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_iv'
7048
7049 INTEGER :: handle
7050#if defined(__parallel)
7051 INTEGER :: ierr, msglen
7052#endif
7053
7054 CALL mp_timeset(routinen, handle)
7055
7056#if defined(__parallel)
7057 msglen = SIZE(msg)
7058 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7059 msglen, mpi_integer, root, comm%handle, ierr)
7060 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7061 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7062#else
7063 mark_used(root)
7064 mark_used(comm)
7065 msg_gather = msg
7066#endif
7067 CALL mp_timestop(handle)
7068 END SUBROUTINE mp_gather_iv
7069
7070! **************************************************************************************************
7071!> \brief Gathers data from all processes to one. Gathers from comm%source
7072!> \param[in] msg Datum to send to root
7073!> \param msg_gather ...
7074!> \param comm ...
7075!> \par Data length
7076!> All data (msg) is equal-sized
7077!> \par MPI mapping
7078!> mpi_gather
7079!> \note see mp_gather_i
7080! **************************************************************************************************
7081 SUBROUTINE mp_gather_iv_src(msg, msg_gather, comm)
7082 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
7083 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7084 CLASS(mp_comm_type), INTENT(IN) :: comm
7085
7086 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_iv_src'
7087
7088 INTEGER :: handle
7089#if defined(__parallel)
7090 INTEGER :: ierr, msglen
7091#endif
7092
7093 CALL mp_timeset(routinen, handle)
7094
7095#if defined(__parallel)
7096 msglen = SIZE(msg)
7097 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7098 msglen, mpi_integer, comm%source, comm%handle, ierr)
7099 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7100 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7101#else
7102 mark_used(comm)
7103 msg_gather = msg
7104#endif
7105 CALL mp_timestop(handle)
7106 END SUBROUTINE mp_gather_iv_src
7107
7108! **************************************************************************************************
7109!> \brief Gathers data from all processes to one
7110!> \param[in] msg Datum to send to root
7111!> \param msg_gather ...
7112!> \param root ...
7113!> \param comm ...
7114!> \par Data length
7115!> All data (msg) is equal-sized
7116!> \par MPI mapping
7117!> mpi_gather
7118!> \note see mp_gather_i
7119! **************************************************************************************************
7120 SUBROUTINE mp_gather_im(msg, msg_gather, root, comm)
7121 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
7122 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
7123 INTEGER, INTENT(IN) :: root
7124 CLASS(mp_comm_type), INTENT(IN) :: comm
7125
7126 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_im'
7127
7128 INTEGER :: handle
7129#if defined(__parallel)
7130 INTEGER :: ierr, msglen
7131#endif
7132
7133 CALL mp_timeset(routinen, handle)
7134
7135#if defined(__parallel)
7136 msglen = SIZE(msg)
7137 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7138 msglen, mpi_integer, root, comm%handle, ierr)
7139 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7140 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7141#else
7142 mark_used(root)
7143 mark_used(comm)
7144 msg_gather = msg
7145#endif
7146 CALL mp_timestop(handle)
7147 END SUBROUTINE mp_gather_im
7148
7149! **************************************************************************************************
7150!> \brief Gathers data from all processes to one. Gathers from comm%source
7151!> \param[in] msg Datum to send to root
7152!> \param msg_gather ...
7153!> \param comm ...
7154!> \par Data length
7155!> All data (msg) is equal-sized
7156!> \par MPI mapping
7157!> mpi_gather
7158!> \note see mp_gather_i
7159! **************************************************************************************************
7160 SUBROUTINE mp_gather_im_src(msg, msg_gather, comm)
7161 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
7162 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
7163 CLASS(mp_comm_type), INTENT(IN) :: comm
7164
7165 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_im_src'
7166
7167 INTEGER :: handle
7168#if defined(__parallel)
7169 INTEGER :: ierr, msglen
7170#endif
7171
7172 CALL mp_timeset(routinen, handle)
7173
7174#if defined(__parallel)
7175 msglen = SIZE(msg)
7176 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7177 msglen, mpi_integer, comm%source, comm%handle, ierr)
7178 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7179 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7180#else
7181 mark_used(comm)
7182 msg_gather = msg
7183#endif
7184 CALL mp_timestop(handle)
7185 END SUBROUTINE mp_gather_im_src
7186
7187! **************************************************************************************************
7188!> \brief Gathers data from all processes to one.
7189!> \param[in] sendbuf Data to send to root
7190!> \param[out] recvbuf Received data (on root)
7191!> \param[in] recvcounts Sizes of data received from processes
7192!> \param[in] displs Offsets of data received from processes
7193!> \param[in] root Process which gathers the data
7194!> \param[in] comm Message passing environment identifier
7195!> \par Data length
7196!> Data can have different lengths
7197!> \par Offsets
7198!> Offsets start at 0
7199!> \par MPI mapping
7200!> mpi_gather
7201! **************************************************************************************************
7202 SUBROUTINE mp_gatherv_iv(sendbuf, recvbuf, recvcounts, displs, root, comm)
7203
7204 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
7205 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
7206 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7207 INTEGER, INTENT(IN) :: root
7208 CLASS(mp_comm_type), INTENT(IN) :: comm
7209
7210 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_iv'
7211
7212 INTEGER :: handle
7213#if defined(__parallel)
7214 INTEGER :: ierr, sendcount
7215#endif
7216
7217 CALL mp_timeset(routinen, handle)
7218
7219#if defined(__parallel)
7220 sendcount = SIZE(sendbuf)
7221 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7222 recvbuf, recvcounts, displs, mpi_integer, &
7223 root, comm%handle, ierr)
7224 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7225 CALL add_perf(perf_id=4, &
7226 count=1, &
7227 msg_size=sendcount*int_4_size)
7228#else
7229 mark_used(recvcounts)
7230 mark_used(root)
7231 mark_used(comm)
7232 recvbuf(1 + displs(1):) = sendbuf
7233#endif
7234 CALL mp_timestop(handle)
7235 END SUBROUTINE mp_gatherv_iv
7236
7237! **************************************************************************************************
7238!> \brief Gathers data from all processes to one. Gathers from comm%source
7239!> \param[in] sendbuf Data to send to root
7240!> \param[out] recvbuf Received data (on root)
7241!> \param[in] recvcounts Sizes of data received from processes
7242!> \param[in] displs Offsets of data received from processes
7243!> \param[in] comm Message passing environment identifier
7244!> \par Data length
7245!> Data can have different lengths
7246!> \par Offsets
7247!> Offsets start at 0
7248!> \par MPI mapping
7249!> mpi_gather
7250! **************************************************************************************************
7251 SUBROUTINE mp_gatherv_iv_src(sendbuf, recvbuf, recvcounts, displs, comm)
7252
7253 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
7254 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
7255 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7256 CLASS(mp_comm_type), INTENT(IN) :: comm
7257
7258 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_iv_src'
7259
7260 INTEGER :: handle
7261#if defined(__parallel)
7262 INTEGER :: ierr, sendcount
7263#endif
7264
7265 CALL mp_timeset(routinen, handle)
7266
7267#if defined(__parallel)
7268 sendcount = SIZE(sendbuf)
7269 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7270 recvbuf, recvcounts, displs, mpi_integer, &
7271 comm%source, comm%handle, ierr)
7272 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7273 CALL add_perf(perf_id=4, &
7274 count=1, &
7275 msg_size=sendcount*int_4_size)
7276#else
7277 mark_used(recvcounts)
7278 mark_used(comm)
7279 recvbuf(1 + displs(1):) = sendbuf
7280#endif
7281 CALL mp_timestop(handle)
7282 END SUBROUTINE mp_gatherv_iv_src
7283
7284! **************************************************************************************************
7285!> \brief Gathers data from all processes to one.
7286!> \param[in] sendbuf Data to send to root
7287!> \param[out] recvbuf Received data (on root)
7288!> \param[in] recvcounts Sizes of data received from processes
7289!> \param[in] displs Offsets of data received from processes
7290!> \param[in] root Process which gathers the data
7291!> \param[in] comm Message passing environment identifier
7292!> \par Data length
7293!> Data can have different lengths
7294!> \par Offsets
7295!> Offsets start at 0
7296!> \par MPI mapping
7297!> mpi_gather
7298! **************************************************************************************************
7299 SUBROUTINE mp_gatherv_im2(sendbuf, recvbuf, recvcounts, displs, root, comm)
7300
7301 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
7302 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
7303 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7304 INTEGER, INTENT(IN) :: root
7305 CLASS(mp_comm_type), INTENT(IN) :: comm
7306
7307 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_im2'
7308
7309 INTEGER :: handle
7310#if defined(__parallel)
7311 INTEGER :: ierr, sendcount
7312#endif
7313
7314 CALL mp_timeset(routinen, handle)
7315
7316#if defined(__parallel)
7317 sendcount = SIZE(sendbuf)
7318 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7319 recvbuf, recvcounts, displs, mpi_integer, &
7320 root, comm%handle, ierr)
7321 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7322 CALL add_perf(perf_id=4, &
7323 count=1, &
7324 msg_size=sendcount*int_4_size)
7325#else
7326 mark_used(recvcounts)
7327 mark_used(root)
7328 mark_used(comm)
7329 recvbuf(:, 1 + displs(1):) = sendbuf
7330#endif
7331 CALL mp_timestop(handle)
7332 END SUBROUTINE mp_gatherv_im2
7333
7334! **************************************************************************************************
7335!> \brief Gathers data from all processes to one.
7336!> \param[in] sendbuf Data to send to root
7337!> \param[out] recvbuf Received data (on root)
7338!> \param[in] recvcounts Sizes of data received from processes
7339!> \param[in] displs Offsets of data received from processes
7340!> \param[in] comm Message passing environment identifier
7341!> \par Data length
7342!> Data can have different lengths
7343!> \par Offsets
7344!> Offsets start at 0
7345!> \par MPI mapping
7346!> mpi_gather
7347! **************************************************************************************************
7348 SUBROUTINE mp_gatherv_im2_src(sendbuf, recvbuf, recvcounts, displs, comm)
7349
7350 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
7351 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
7352 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7353 CLASS(mp_comm_type), INTENT(IN) :: comm
7354
7355 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_im2_src'
7356
7357 INTEGER :: handle
7358#if defined(__parallel)
7359 INTEGER :: ierr, sendcount
7360#endif
7361
7362 CALL mp_timeset(routinen, handle)
7363
7364#if defined(__parallel)
7365 sendcount = SIZE(sendbuf)
7366 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7367 recvbuf, recvcounts, displs, mpi_integer, &
7368 comm%source, comm%handle, ierr)
7369 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7370 CALL add_perf(perf_id=4, &
7371 count=1, &
7372 msg_size=sendcount*int_4_size)
7373#else
7374 mark_used(recvcounts)
7375 mark_used(comm)
7376 recvbuf(:, 1 + displs(1):) = sendbuf
7377#endif
7378 CALL mp_timestop(handle)
7379 END SUBROUTINE mp_gatherv_im2_src
7380
7381! **************************************************************************************************
7382!> \brief Gathers data from all processes to one.
7383!> \param[in] sendbuf Data to send to root
7384!> \param[out] recvbuf Received data (on root)
7385!> \param[in] recvcounts Sizes of data received from processes
7386!> \param[in] displs Offsets of data received from processes
7387!> \param[in] root Process which gathers the data
7388!> \param[in] comm Message passing environment identifier
7389!> \par Data length
7390!> Data can have different lengths
7391!> \par Offsets
7392!> Offsets start at 0
7393!> \par MPI mapping
7394!> mpi_gather
7395! **************************************************************************************************
7396 SUBROUTINE mp_igatherv_iv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
7397 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: sendbuf
7398 INTEGER(KIND=int_4), DIMENSION(:), INTENT(OUT) :: recvbuf
7399 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7400 INTEGER, INTENT(IN) :: sendcount, root
7401 CLASS(mp_comm_type), INTENT(IN) :: comm
7402 TYPE(mp_request_type), INTENT(OUT) :: request
7403
7404 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_iv'
7405
7406 INTEGER :: handle
7407#if defined(__parallel)
7408 INTEGER :: ierr
7409#endif
7410
7411 CALL mp_timeset(routinen, handle)
7412
7413#if defined(__parallel)
7414#if !defined(__GNUC__) || __GNUC__ >= 9
7415 cpassert(is_contiguous(sendbuf) .OR. SIZE(sendbuf) == 0)
7416 cpassert(is_contiguous(recvbuf) .OR. SIZE(recvbuf) == 0)
7417 cpassert(is_contiguous(recvcounts) .OR. SIZE(recvcounts) == 0)
7418 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
7419#endif
7420 CALL mpi_igatherv(sendbuf, sendcount, mpi_integer, &
7421 recvbuf, recvcounts, displs, mpi_integer, &
7422 root, comm%handle, request%handle, ierr)
7423 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7424 CALL add_perf(perf_id=24, &
7425 count=1, &
7426 msg_size=sendcount*int_4_size)
7427#else
7428 mark_used(sendcount)
7429 mark_used(recvcounts)
7430 mark_used(root)
7431 mark_used(comm)
7432 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
7433 request = mp_request_null
7434#endif
7435 CALL mp_timestop(handle)
7436 END SUBROUTINE mp_igatherv_iv
7437
7438! **************************************************************************************************
7439!> \brief Gathers a datum from all processes and all processes receive the
7440!> same data
7441!> \param[in] msgout Datum to send
7442!> \param[out] msgin Received data
7443!> \param[in] comm Message passing environment identifier
7444!> \par Data size
7445!> All processes send equal-sized data
7446!> \par MPI mapping
7447!> mpi_allgather
7448! **************************************************************************************************
7449 SUBROUTINE mp_allgather_i (msgout, msgin, comm)
7450 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7451 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
7452 CLASS(mp_comm_type), INTENT(IN) :: comm
7453
7454 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i'
7455
7456 INTEGER :: handle
7457#if defined(__parallel)
7458 INTEGER :: ierr, rcount, scount
7459#endif
7460
7461 CALL mp_timeset(routinen, handle)
7462
7463#if defined(__parallel)
7464 scount = 1
7465 rcount = 1
7466 CALL mpi_allgather(msgout, scount, mpi_integer, &
7467 msgin, rcount, mpi_integer, &
7468 comm%handle, ierr)
7469 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7470#else
7471 mark_used(comm)
7472 msgin = msgout
7473#endif
7474 CALL mp_timestop(handle)
7475 END SUBROUTINE mp_allgather_i
7476
7477! **************************************************************************************************
7478!> \brief Gathers a datum from all processes and all processes receive the
7479!> same data
7480!> \param[in] msgout Datum to send
7481!> \param[out] msgin Received data
7482!> \param[in] comm Message passing environment identifier
7483!> \par Data size
7484!> All processes send equal-sized data
7485!> \par MPI mapping
7486!> mpi_allgather
7487! **************************************************************************************************
7488 SUBROUTINE mp_allgather_i2(msgout, msgin, comm)
7489 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7490 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7491 CLASS(mp_comm_type), INTENT(IN) :: comm
7492
7493 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i2'
7494
7495 INTEGER :: handle
7496#if defined(__parallel)
7497 INTEGER :: ierr, rcount, scount
7498#endif
7499
7500 CALL mp_timeset(routinen, handle)
7501
7502#if defined(__parallel)
7503 scount = 1
7504 rcount = 1
7505 CALL mpi_allgather(msgout, scount, mpi_integer, &
7506 msgin, rcount, mpi_integer, &
7507 comm%handle, ierr)
7508 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7509#else
7510 mark_used(comm)
7511 msgin = msgout
7512#endif
7513 CALL mp_timestop(handle)
7514 END SUBROUTINE mp_allgather_i2
7515
7516! **************************************************************************************************
7517!> \brief Gathers a datum from all processes and all processes receive the
7518!> same data
7519!> \param[in] msgout Datum to send
7520!> \param[out] msgin Received data
7521!> \param[in] comm Message passing environment identifier
7522!> \par Data size
7523!> All processes send equal-sized data
7524!> \par MPI mapping
7525!> mpi_allgather
7526! **************************************************************************************************
7527 SUBROUTINE mp_iallgather_i (msgout, msgin, comm, request)
7528 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7529 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7530 CLASS(mp_comm_type), INTENT(IN) :: comm
7531 TYPE(mp_request_type), INTENT(OUT) :: request
7532
7533 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i'
7534
7535 INTEGER :: handle
7536#if defined(__parallel)
7537 INTEGER :: ierr, rcount, scount
7538#endif
7539
7540 CALL mp_timeset(routinen, handle)
7541
7542#if defined(__parallel)
7543#if !defined(__GNUC__) || __GNUC__ >= 9
7544 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
7545#endif
7546 scount = 1
7547 rcount = 1
7548 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7549 msgin, rcount, mpi_integer, &
7550 comm%handle, request%handle, ierr)
7551 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7552#else
7553 mark_used(comm)
7554 msgin = msgout
7555 request = mp_request_null
7556#endif
7557 CALL mp_timestop(handle)
7558 END SUBROUTINE mp_iallgather_i
7559
7560! **************************************************************************************************
7561!> \brief Gathers vector data from all processes and all processes receive the
7562!> same data
7563!> \param[in] msgout Rank-1 data to send
7564!> \param[out] msgin Received data
7565!> \param[in] comm Message passing environment identifier
7566!> \par Data size
7567!> All processes send equal-sized data
7568!> \par Ranks
7569!> The last rank counts the processes
7570!> \par MPI mapping
7571!> mpi_allgather
7572! **************************************************************************************************
7573 SUBROUTINE mp_allgather_i12(msgout, msgin, comm)
7574 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:)
7575 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7576 CLASS(mp_comm_type), INTENT(IN) :: comm
7577
7578 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i12'
7579
7580 INTEGER :: handle
7581#if defined(__parallel)
7582 INTEGER :: ierr, rcount, scount
7583#endif
7584
7585 CALL mp_timeset(routinen, handle)
7586
7587#if defined(__parallel)
7588 scount = SIZE(msgout(:))
7589 rcount = scount
7590 CALL mpi_allgather(msgout, scount, mpi_integer, &
7591 msgin, rcount, mpi_integer, &
7592 comm%handle, ierr)
7593 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7594#else
7595 mark_used(comm)
7596 msgin(:, 1) = msgout(:)
7597#endif
7598 CALL mp_timestop(handle)
7599 END SUBROUTINE mp_allgather_i12
7600
7601! **************************************************************************************************
7602!> \brief Gathers matrix data from all processes and all processes receive the
7603!> same data
7604!> \param[in] msgout Rank-2 data to send
7605!> \param msgin ...
7606!> \param comm ...
7607!> \note see mp_allgather_i12
7608! **************************************************************************************************
7609 SUBROUTINE mp_allgather_i23(msgout, msgin, comm)
7610 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
7611 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
7612 CLASS(mp_comm_type), INTENT(IN) :: comm
7613
7614 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i23'
7615
7616 INTEGER :: handle
7617#if defined(__parallel)
7618 INTEGER :: ierr, rcount, scount
7619#endif
7620
7621 CALL mp_timeset(routinen, handle)
7622
7623#if defined(__parallel)
7624 scount = SIZE(msgout(:, :))
7625 rcount = scount
7626 CALL mpi_allgather(msgout, scount, mpi_integer, &
7627 msgin, rcount, mpi_integer, &
7628 comm%handle, ierr)
7629 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7630#else
7631 mark_used(comm)
7632 msgin(:, :, 1) = msgout(:, :)
7633#endif
7634 CALL mp_timestop(handle)
7635 END SUBROUTINE mp_allgather_i23
7636
7637! **************************************************************************************************
7638!> \brief Gathers rank-3 data from all processes and all processes receive the
7639!> same data
7640!> \param[in] msgout Rank-3 data to send
7641!> \param msgin ...
7642!> \param comm ...
7643!> \note see mp_allgather_i12
7644! **************************************************************************************************
7645 SUBROUTINE mp_allgather_i34(msgout, msgin, comm)
7646 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
7647 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
7648 CLASS(mp_comm_type), INTENT(IN) :: comm
7649
7650 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i34'
7651
7652 INTEGER :: handle
7653#if defined(__parallel)
7654 INTEGER :: ierr, rcount, scount
7655#endif
7656
7657 CALL mp_timeset(routinen, handle)
7658
7659#if defined(__parallel)
7660 scount = SIZE(msgout(:, :, :))
7661 rcount = scount
7662 CALL mpi_allgather(msgout, scount, mpi_integer, &
7663 msgin, rcount, mpi_integer, &
7664 comm%handle, ierr)
7665 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7666#else
7667 mark_used(comm)
7668 msgin(:, :, :, 1) = msgout(:, :, :)
7669#endif
7670 CALL mp_timestop(handle)
7671 END SUBROUTINE mp_allgather_i34
7672
7673! **************************************************************************************************
7674!> \brief Gathers rank-2 data from all processes and all processes receive the
7675!> same data
7676!> \param[in] msgout Rank-2 data to send
7677!> \param msgin ...
7678!> \param comm ...
7679!> \note see mp_allgather_i12
7680! **************************************************************************************************
7681 SUBROUTINE mp_allgather_i22(msgout, msgin, comm)
7682 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
7683 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7684 CLASS(mp_comm_type), INTENT(IN) :: comm
7685
7686 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i22'
7687
7688 INTEGER :: handle
7689#if defined(__parallel)
7690 INTEGER :: ierr, rcount, scount
7691#endif
7692
7693 CALL mp_timeset(routinen, handle)
7694
7695#if defined(__parallel)
7696 scount = SIZE(msgout(:, :))
7697 rcount = scount
7698 CALL mpi_allgather(msgout, scount, mpi_integer, &
7699 msgin, rcount, mpi_integer, &
7700 comm%handle, ierr)
7701 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7702#else
7703 mark_used(comm)
7704 msgin(:, :) = msgout(:, :)
7705#endif
7706 CALL mp_timestop(handle)
7707 END SUBROUTINE mp_allgather_i22
7708
7709! **************************************************************************************************
7710!> \brief Gathers rank-1 data from all processes and all processes receive the
7711!> same data
7712!> \param[in] msgout Rank-1 data to send
7713!> \param msgin ...
7714!> \param comm ...
7715!> \param request ...
7716!> \note see mp_allgather_i11
7717! **************************************************************************************************
7718 SUBROUTINE mp_iallgather_i11(msgout, msgin, comm, request)
7719 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7720 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7721 CLASS(mp_comm_type), INTENT(IN) :: comm
7722 TYPE(mp_request_type), INTENT(OUT) :: request
7723
7724 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i11'
7725
7726 INTEGER :: handle
7727#if defined(__parallel)
7728 INTEGER :: ierr, rcount, scount
7729#endif
7730
7731 CALL mp_timeset(routinen, handle)
7732
7733#if defined(__parallel)
7734#if !defined(__GNUC__) || __GNUC__ >= 9
7735 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
7736 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
7737#endif
7738 scount = SIZE(msgout(:))
7739 rcount = scount
7740 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7741 msgin, rcount, mpi_integer, &
7742 comm%handle, request%handle, ierr)
7743 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7744#else
7745 mark_used(comm)
7746 msgin = msgout
7747 request = mp_request_null
7748#endif
7749 CALL mp_timestop(handle)
7750 END SUBROUTINE mp_iallgather_i11
7751
7752! **************************************************************************************************
7753!> \brief Gathers rank-2 data from all processes and all processes receive the
7754!> same data
7755!> \param[in] msgout Rank-2 data to send
7756!> \param msgin ...
7757!> \param comm ...
7758!> \param request ...
7759!> \note see mp_allgather_i12
7760! **************************************************************************************************
7761 SUBROUTINE mp_iallgather_i13(msgout, msgin, comm, request)
7762 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7763 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :)
7764 CLASS(mp_comm_type), INTENT(IN) :: comm
7765 TYPE(mp_request_type), INTENT(OUT) :: request
7766
7767 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i13'
7768
7769 INTEGER :: handle
7770#if defined(__parallel)
7771 INTEGER :: ierr, rcount, scount
7772#endif
7773
7774 CALL mp_timeset(routinen, handle)
7775
7776#if defined(__parallel)
7777#if !defined(__GNUC__) || __GNUC__ >= 9
7778 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
7779 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
7780#endif
7781
7782 scount = SIZE(msgout(:))
7783 rcount = scount
7784 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7785 msgin, rcount, mpi_integer, &
7786 comm%handle, request%handle, ierr)
7787 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7788#else
7789 mark_used(comm)
7790 msgin(:, 1, 1) = msgout(:)
7791 request = mp_request_null
7792#endif
7793 CALL mp_timestop(handle)
7794 END SUBROUTINE mp_iallgather_i13
7795
7796! **************************************************************************************************
7797!> \brief Gathers rank-2 data from all processes and all processes receive the
7798!> same data
7799!> \param[in] msgout Rank-2 data to send
7800!> \param msgin ...
7801!> \param comm ...
7802!> \param request ...
7803!> \note see mp_allgather_i12
7804! **************************************************************************************************
7805 SUBROUTINE mp_iallgather_i22(msgout, msgin, comm, request)
7806 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :)
7807 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :)
7808 CLASS(mp_comm_type), INTENT(IN) :: comm
7809 TYPE(mp_request_type), INTENT(OUT) :: request
7810
7811 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i22'
7812
7813 INTEGER :: handle
7814#if defined(__parallel)
7815 INTEGER :: ierr, rcount, scount
7816#endif
7817
7818 CALL mp_timeset(routinen, handle)
7819
7820#if defined(__parallel)
7821#if !defined(__GNUC__) || __GNUC__ >= 9
7822 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
7823 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
7824#endif
7825
7826 scount = SIZE(msgout(:, :))
7827 rcount = scount
7828 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7829 msgin, rcount, mpi_integer, &
7830 comm%handle, request%handle, ierr)
7831 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7832#else
7833 mark_used(comm)
7834 msgin(:, :) = msgout(:, :)
7835 request = mp_request_null
7836#endif
7837 CALL mp_timestop(handle)
7838 END SUBROUTINE mp_iallgather_i22
7839
7840! **************************************************************************************************
7841!> \brief Gathers rank-2 data from all processes and all processes receive the
7842!> same data
7843!> \param[in] msgout Rank-2 data to send
7844!> \param msgin ...
7845!> \param comm ...
7846!> \param request ...
7847!> \note see mp_allgather_i12
7848! **************************************************************************************************
7849 SUBROUTINE mp_iallgather_i24(msgout, msgin, comm, request)
7850 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :)
7851 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :, :)
7852 CLASS(mp_comm_type), INTENT(IN) :: comm
7853 TYPE(mp_request_type), INTENT(OUT) :: request
7854
7855 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i24'
7856
7857 INTEGER :: handle
7858#if defined(__parallel)
7859 INTEGER :: ierr, rcount, scount
7860#endif
7861
7862 CALL mp_timeset(routinen, handle)
7863
7864#if defined(__parallel)
7865#if !defined(__GNUC__) || __GNUC__ >= 9
7866 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
7867 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
7868#endif
7869
7870 scount = SIZE(msgout(:, :))
7871 rcount = scount
7872 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7873 msgin, rcount, mpi_integer, &
7874 comm%handle, request%handle, ierr)
7875 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7876#else
7877 mark_used(comm)
7878 msgin(:, :, 1, 1) = msgout(:, :)
7879 request = mp_request_null
7880#endif
7881 CALL mp_timestop(handle)
7882 END SUBROUTINE mp_iallgather_i24
7883
7884! **************************************************************************************************
7885!> \brief Gathers rank-3 data from all processes and all processes receive the
7886!> same data
7887!> \param[in] msgout Rank-3 data to send
7888!> \param msgin ...
7889!> \param comm ...
7890!> \param request ...
7891!> \note see mp_allgather_i12
7892! **************************************************************************************************
7893 SUBROUTINE mp_iallgather_i33(msgout, msgin, comm, request)
7894 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :, :)
7895 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :)
7896 CLASS(mp_comm_type), INTENT(IN) :: comm
7897 TYPE(mp_request_type), INTENT(OUT) :: request
7898
7899 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i33'
7900
7901 INTEGER :: handle
7902#if defined(__parallel)
7903 INTEGER :: ierr, rcount, scount
7904#endif
7905
7906 CALL mp_timeset(routinen, handle)
7907
7908#if defined(__parallel)
7909#if !defined(__GNUC__) || __GNUC__ >= 9
7910 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
7911 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
7912#endif
7913
7914 scount = SIZE(msgout(:, :, :))
7915 rcount = scount
7916 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7917 msgin, rcount, mpi_integer, &
7918 comm%handle, request%handle, ierr)
7919 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7920#else
7921 mark_used(comm)
7922 msgin(:, :, :) = msgout(:, :, :)
7923 request = mp_request_null
7924#endif
7925 CALL mp_timestop(handle)
7926 END SUBROUTINE mp_iallgather_i33
7927
7928! **************************************************************************************************
7929!> \brief Gathers vector data from all processes and all processes receive the
7930!> same data
7931!> \param[in] msgout Rank-1 data to send
7932!> \param[out] msgin Received data
7933!> \param[in] rcount Size of sent data for every process
7934!> \param[in] rdispl Offset of sent data for every process
7935!> \param[in] comm Message passing environment identifier
7936!> \par Data size
7937!> Processes can send different-sized data
7938!> \par Ranks
7939!> The last rank counts the processes
7940!> \par Offsets
7941!> Offsets are from 0
7942!> \par MPI mapping
7943!> mpi_allgather
7944! **************************************************************************************************
7945 SUBROUTINE mp_allgatherv_iv(msgout, msgin, rcount, rdispl, comm)
7946 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
7947 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
7948 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
7949 CLASS(mp_comm_type), INTENT(IN) :: comm
7950
7951 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_iv'
7952
7953 INTEGER :: handle
7954#if defined(__parallel)
7955 INTEGER :: ierr, scount
7956#endif
7957
7958 CALL mp_timeset(routinen, handle)
7959
7960#if defined(__parallel)
7961 scount = SIZE(msgout)
7962 CALL mpi_allgatherv(msgout, scount, mpi_integer, msgin, rcount, &
7963 rdispl, mpi_integer, comm%handle, ierr)
7964 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
7965#else
7966 mark_used(rcount)
7967 mark_used(rdispl)
7968 mark_used(comm)
7969 msgin = msgout
7970#endif
7971 CALL mp_timestop(handle)
7972 END SUBROUTINE mp_allgatherv_iv
7973
7974! **************************************************************************************************
7975!> \brief Gathers vector data from all processes and all processes receive the
7976!> same data
7977!> \param[in] msgout Rank-1 data to send
7978!> \param[out] msgin Received data
7979!> \param[in] rcount Size of sent data for every process
7980!> \param[in] rdispl Offset of sent data for every process
7981!> \param[in] comm Message passing environment identifier
7982!> \par Data size
7983!> Processes can send different-sized data
7984!> \par Ranks
7985!> The last rank counts the processes
7986!> \par Offsets
7987!> Offsets are from 0
7988!> \par MPI mapping
7989!> mpi_allgather
7990! **************************************************************************************************
7991 SUBROUTINE mp_allgatherv_im2(msgout, msgin, rcount, rdispl, comm)
7992 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
7993 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
7994 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
7995 CLASS(mp_comm_type), INTENT(IN) :: comm
7996
7997 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_iv'
7998
7999 INTEGER :: handle
8000#if defined(__parallel)
8001 INTEGER :: ierr, scount
8002#endif
8003
8004 CALL mp_timeset(routinen, handle)
8005
8006#if defined(__parallel)
8007 scount = SIZE(msgout)
8008 CALL mpi_allgatherv(msgout, scount, mpi_integer, msgin, rcount, &
8009 rdispl, mpi_integer, comm%handle, ierr)
8010 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
8011#else
8012 mark_used(rcount)
8013 mark_used(rdispl)
8014 mark_used(comm)
8015 msgin = msgout
8016#endif
8017 CALL mp_timestop(handle)
8018 END SUBROUTINE mp_allgatherv_im2
8019
8020! **************************************************************************************************
8021!> \brief Gathers vector data from all processes and all processes receive the
8022!> same data
8023!> \param[in] msgout Rank-1 data to send
8024!> \param[out] msgin Received data
8025!> \param[in] rcount Size of sent data for every process
8026!> \param[in] rdispl Offset of sent data for every process
8027!> \param[in] comm Message passing environment identifier
8028!> \par Data size
8029!> Processes can send different-sized data
8030!> \par Ranks
8031!> The last rank counts the processes
8032!> \par Offsets
8033!> Offsets are from 0
8034!> \par MPI mapping
8035!> mpi_allgather
8036! **************************************************************************************************
8037 SUBROUTINE mp_iallgatherv_iv(msgout, msgin, rcount, rdispl, comm, request)
8038 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
8039 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
8040 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
8041 CLASS(mp_comm_type), INTENT(IN) :: comm
8042 TYPE(mp_request_type), INTENT(OUT) :: request
8043
8044 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_iv'
8045
8046 INTEGER :: handle
8047#if defined(__parallel)
8048 INTEGER :: ierr, scount, rsize
8049#endif
8050
8051 CALL mp_timeset(routinen, handle)
8052
8053#if defined(__parallel)
8054#if !defined(__GNUC__) || __GNUC__ >= 9
8055 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
8056 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
8057 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
8058 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
8059#endif
8060
8061 scount = SIZE(msgout)
8062 rsize = SIZE(rcount)
8063 CALL mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, &
8064 rdispl, comm, request, ierr)
8065 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
8066#else
8067 mark_used(rcount)
8068 mark_used(rdispl)
8069 mark_used(comm)
8070 msgin = msgout
8071 request = mp_request_null
8072#endif
8073 CALL mp_timestop(handle)
8074 END SUBROUTINE mp_iallgatherv_iv
8075
8076! **************************************************************************************************
8077!> \brief Gathers vector data from all processes and all processes receive the
8078!> same data
8079!> \param[in] msgout Rank-1 data to send
8080!> \param[out] msgin Received data
8081!> \param[in] rcount Size of sent data for every process
8082!> \param[in] rdispl Offset of sent data for every process
8083!> \param[in] comm Message passing environment identifier
8084!> \par Data size
8085!> Processes can send different-sized data
8086!> \par Ranks
8087!> The last rank counts the processes
8088!> \par Offsets
8089!> Offsets are from 0
8090!> \par MPI mapping
8091!> mpi_allgather
8092! **************************************************************************************************
8093 SUBROUTINE mp_iallgatherv_iv2(msgout, msgin, rcount, rdispl, comm, request)
8094 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
8095 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
8096 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
8097 CLASS(mp_comm_type), INTENT(IN) :: comm
8098 TYPE(mp_request_type), INTENT(OUT) :: request
8099
8100 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_iv2'
8101
8102 INTEGER :: handle
8103#if defined(__parallel)
8104 INTEGER :: ierr, scount, rsize
8105#endif
8106
8107 CALL mp_timeset(routinen, handle)
8108
8109#if defined(__parallel)
8110#if !defined(__GNUC__) || __GNUC__ >= 9
8111 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
8112 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
8113 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
8114 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
8115#endif
8116
8117 scount = SIZE(msgout)
8118 rsize = SIZE(rcount)
8119 CALL mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, &
8120 rdispl, comm, request, ierr)
8121 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
8122#else
8123 mark_used(rcount)
8124 mark_used(rdispl)
8125 mark_used(comm)
8126 msgin = msgout
8127 request = mp_request_null
8128#endif
8129 CALL mp_timestop(handle)
8130 END SUBROUTINE mp_iallgatherv_iv2
8131
8132! **************************************************************************************************
8133!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
8134!> the issue is with the rank of rcount and rdispl
8135!> \param count ...
8136!> \param array_of_requests ...
8137!> \param array_of_statuses ...
8138!> \param ierr ...
8139!> \author Alfio Lazzaro
8140! **************************************************************************************************
8141#if defined(__parallel)
8142 SUBROUTINE mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
8143 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
8144 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
8145 INTEGER, INTENT(IN) :: rsize
8146 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
8147 CLASS(mp_comm_type), INTENT(IN) :: comm
8148 TYPE(mp_request_type), INTENT(OUT) :: request
8149 INTEGER, INTENT(INOUT) :: ierr
8150
8151 CALL mpi_iallgatherv(msgout, scount, mpi_integer, msgin, rcount, &
8152 rdispl, mpi_integer, comm%handle, request%handle, ierr)
8153
8154 END SUBROUTINE mp_iallgatherv_iv_internal
8155#endif
8156
8157! **************************************************************************************************
8158!> \brief Sums a vector and partitions the result among processes
8159!> \param[in] msgout Data to sum
8160!> \param[out] msgin Received portion of summed data
8161!> \param[in] rcount Partition sizes of the summed data for
8162!> every process
8163!> \param[in] comm Message passing environment identifier
8164! **************************************************************************************************
8165 SUBROUTINE mp_sum_scatter_iv(msgout, msgin, rcount, comm)
8166 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
8167 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
8168 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
8169 CLASS(mp_comm_type), INTENT(IN) :: comm
8170
8171 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_iv'
8172
8173 INTEGER :: handle
8174#if defined(__parallel)
8175 INTEGER :: ierr
8176#endif
8177
8178 CALL mp_timeset(routinen, handle)
8179
8180#if defined(__parallel)
8181 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_integer, mpi_sum, &
8182 comm%handle, ierr)
8183 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
8184
8185 CALL add_perf(perf_id=3, count=1, &
8186 msg_size=rcount(1)*2*int_4_size)
8187#else
8188 mark_used(rcount)
8189 mark_used(comm)
8190 msgin = msgout(:, 1)
8191#endif
8192 CALL mp_timestop(handle)
8193 END SUBROUTINE mp_sum_scatter_iv
8194
8195! **************************************************************************************************
8196!> \brief Sends and receives vector data
8197!> \param[in] msgin Data to send
8198!> \param[in] dest Process to send data to
8199!> \param[out] msgout Received data
8200!> \param[in] source Process from which to receive
8201!> \param[in] comm Message passing environment identifier
8202!> \param[in] tag Send and recv tag (default: 0)
8203! **************************************************************************************************
8204 SUBROUTINE mp_sendrecv_i (msgin, dest, msgout, source, comm, tag)
8205 INTEGER(KIND=int_4), INTENT(IN) :: msgin
8206 INTEGER, INTENT(IN) :: dest
8207 INTEGER(KIND=int_4), INTENT(OUT) :: msgout
8208 INTEGER, INTENT(IN) :: source
8209 CLASS(mp_comm_type), INTENT(IN) :: comm
8210 INTEGER, INTENT(IN), OPTIONAL :: tag
8211
8212 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_i'
8213
8214 INTEGER :: handle
8215#if defined(__parallel)
8216 INTEGER :: ierr, msglen_in, msglen_out, &
8217 recv_tag, send_tag
8218#endif
8219
8220 CALL mp_timeset(routinen, handle)
8221
8222#if defined(__parallel)
8223 msglen_in = 1
8224 msglen_out = 1
8225 send_tag = 0 ! cannot think of something better here, this might be dangerous
8226 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8227 IF (PRESENT(tag)) THEN
8228 send_tag = tag
8229 recv_tag = tag
8230 END IF
8231 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8232 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8233 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8234 CALL add_perf(perf_id=7, count=1, &
8235 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8236#else
8237 mark_used(dest)
8238 mark_used(source)
8239 mark_used(comm)
8240 mark_used(tag)
8241 msgout = msgin
8242#endif
8243 CALL mp_timestop(handle)
8244 END SUBROUTINE mp_sendrecv_i
8245
8246! **************************************************************************************************
8247!> \brief Sends and receives vector data
8248!> \param[in] msgin Data to send
8249!> \param[in] dest Process to send data to
8250!> \param[out] msgout Received data
8251!> \param[in] source Process from which to receive
8252!> \param[in] comm Message passing environment identifier
8253!> \param[in] tag Send and recv tag (default: 0)
8254! **************************************************************************************************
8255 SUBROUTINE mp_sendrecv_iv(msgin, dest, msgout, source, comm, tag)
8256 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
8257 INTEGER, INTENT(IN) :: dest
8258 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
8259 INTEGER, INTENT(IN) :: source
8260 CLASS(mp_comm_type), INTENT(IN) :: comm
8261 INTEGER, INTENT(IN), OPTIONAL :: tag
8262
8263 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_iv'
8264
8265 INTEGER :: handle
8266#if defined(__parallel)
8267 INTEGER :: ierr, msglen_in, msglen_out, &
8268 recv_tag, send_tag
8269#endif
8270
8271 CALL mp_timeset(routinen, handle)
8272
8273#if defined(__parallel)
8274 msglen_in = SIZE(msgin)
8275 msglen_out = SIZE(msgout)
8276 send_tag = 0 ! cannot think of something better here, this might be dangerous
8277 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8278 IF (PRESENT(tag)) THEN
8279 send_tag = tag
8280 recv_tag = tag
8281 END IF
8282 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8283 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8284 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8285 CALL add_perf(perf_id=7, count=1, &
8286 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8287#else
8288 mark_used(dest)
8289 mark_used(source)
8290 mark_used(comm)
8291 mark_used(tag)
8292 msgout = msgin
8293#endif
8294 CALL mp_timestop(handle)
8295 END SUBROUTINE mp_sendrecv_iv
8296
8297! **************************************************************************************************
8298!> \brief Sends and receives matrix data
8299!> \param msgin ...
8300!> \param dest ...
8301!> \param msgout ...
8302!> \param source ...
8303!> \param comm ...
8304!> \param tag ...
8305!> \note see mp_sendrecv_iv
8306! **************************************************************************************************
8307 SUBROUTINE mp_sendrecv_im2(msgin, dest, msgout, source, comm, tag)
8308 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
8309 INTEGER, INTENT(IN) :: dest
8310 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
8311 INTEGER, INTENT(IN) :: source
8312 CLASS(mp_comm_type), INTENT(IN) :: comm
8313 INTEGER, INTENT(IN), OPTIONAL :: tag
8314
8315 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im2'
8316
8317 INTEGER :: handle
8318#if defined(__parallel)
8319 INTEGER :: ierr, msglen_in, msglen_out, &
8320 recv_tag, send_tag
8321#endif
8322
8323 CALL mp_timeset(routinen, handle)
8324
8325#if defined(__parallel)
8326 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
8327 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
8328 send_tag = 0 ! cannot think of something better here, this might be dangerous
8329 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8330 IF (PRESENT(tag)) THEN
8331 send_tag = tag
8332 recv_tag = tag
8333 END IF
8334 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8335 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8336 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8337 CALL add_perf(perf_id=7, count=1, &
8338 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8339#else
8340 mark_used(dest)
8341 mark_used(source)
8342 mark_used(comm)
8343 mark_used(tag)
8344 msgout = msgin
8345#endif
8346 CALL mp_timestop(handle)
8347 END SUBROUTINE mp_sendrecv_im2
8348
8349! **************************************************************************************************
8350!> \brief Sends and receives rank-3 data
8351!> \param msgin ...
8352!> \param dest ...
8353!> \param msgout ...
8354!> \param source ...
8355!> \param comm ...
8356!> \note see mp_sendrecv_iv
8357! **************************************************************************************************
8358 SUBROUTINE mp_sendrecv_im3(msgin, dest, msgout, source, comm, tag)
8359 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
8360 INTEGER, INTENT(IN) :: dest
8361 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
8362 INTEGER, INTENT(IN) :: source
8363 CLASS(mp_comm_type), INTENT(IN) :: comm
8364 INTEGER, INTENT(IN), OPTIONAL :: tag
8365
8366 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im3'
8367
8368 INTEGER :: handle
8369#if defined(__parallel)
8370 INTEGER :: ierr, msglen_in, msglen_out, &
8371 recv_tag, send_tag
8372#endif
8373
8374 CALL mp_timeset(routinen, handle)
8375
8376#if defined(__parallel)
8377 msglen_in = SIZE(msgin)
8378 msglen_out = SIZE(msgout)
8379 send_tag = 0 ! cannot think of something better here, this might be dangerous
8380 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8381 IF (PRESENT(tag)) THEN
8382 send_tag = tag
8383 recv_tag = tag
8384 END IF
8385 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8386 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8387 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8388 CALL add_perf(perf_id=7, count=1, &
8389 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8390#else
8391 mark_used(dest)
8392 mark_used(source)
8393 mark_used(comm)
8394 mark_used(tag)
8395 msgout = msgin
8396#endif
8397 CALL mp_timestop(handle)
8398 END SUBROUTINE mp_sendrecv_im3
8399
8400! **************************************************************************************************
8401!> \brief Sends and receives rank-4 data
8402!> \param msgin ...
8403!> \param dest ...
8404!> \param msgout ...
8405!> \param source ...
8406!> \param comm ...
8407!> \note see mp_sendrecv_iv
8408! **************************************************************************************************
8409 SUBROUTINE mp_sendrecv_im4(msgin, dest, msgout, source, comm, tag)
8410 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
8411 INTEGER, INTENT(IN) :: dest
8412 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
8413 INTEGER, INTENT(IN) :: source
8414 CLASS(mp_comm_type), INTENT(IN) :: comm
8415 INTEGER, INTENT(IN), OPTIONAL :: tag
8416
8417 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im4'
8418
8419 INTEGER :: handle
8420#if defined(__parallel)
8421 INTEGER :: ierr, msglen_in, msglen_out, &
8422 recv_tag, send_tag
8423#endif
8424
8425 CALL mp_timeset(routinen, handle)
8426
8427#if defined(__parallel)
8428 msglen_in = SIZE(msgin)
8429 msglen_out = SIZE(msgout)
8430 send_tag = 0 ! cannot think of something better here, this might be dangerous
8431 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8432 IF (PRESENT(tag)) THEN
8433 send_tag = tag
8434 recv_tag = tag
8435 END IF
8436 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8437 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8438 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8439 CALL add_perf(perf_id=7, count=1, &
8440 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8441#else
8442 mark_used(dest)
8443 mark_used(source)
8444 mark_used(comm)
8445 mark_used(tag)
8446 msgout = msgin
8447#endif
8448 CALL mp_timestop(handle)
8449 END SUBROUTINE mp_sendrecv_im4
8450
8451! **************************************************************************************************
8452!> \brief Non-blocking send and receive of a scalar
8453!> \param[in] msgin Scalar data to send
8454!> \param[in] dest Which process to send to
8455!> \param[out] msgout Receive data into this pointer
8456!> \param[in] source Process to receive from
8457!> \param[in] comm Message passing environment identifier
8458!> \param[out] send_request Request handle for the send
8459!> \param[out] recv_request Request handle for the receive
8460!> \param[in] tag (optional) tag to differentiate requests
8461!> \par Implementation
8462!> Calls mpi_isend and mpi_irecv.
8463!> \par History
8464!> 02.2005 created [Alfio Lazzaro]
8465! **************************************************************************************************
8466 SUBROUTINE mp_isendrecv_i (msgin, dest, msgout, source, comm, send_request, &
8467 recv_request, tag)
8468 INTEGER(KIND=int_4), INTENT(IN) :: msgin
8469 INTEGER, INTENT(IN) :: dest
8470 INTEGER(KIND=int_4), INTENT(INOUT) :: msgout
8471 INTEGER, INTENT(IN) :: source
8472 CLASS(mp_comm_type), INTENT(IN) :: comm
8473 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
8474 INTEGER, INTENT(in), OPTIONAL :: tag
8475
8476 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_i'
8477
8478 INTEGER :: handle
8479#if defined(__parallel)
8480 INTEGER :: ierr, my_tag
8481#endif
8482
8483 CALL mp_timeset(routinen, handle)
8484
8485#if defined(__parallel)
8486 my_tag = 0
8487 IF (PRESENT(tag)) my_tag = tag
8488
8489 CALL mpi_irecv(msgout, 1, mpi_integer, source, my_tag, &
8490 comm%handle, recv_request%handle, ierr)
8491 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8492
8493 CALL mpi_isend(msgin, 1, mpi_integer, dest, my_tag, &
8494 comm%handle, send_request%handle, ierr)
8495 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8496
8497 CALL add_perf(perf_id=8, count=1, msg_size=2*int_4_size)
8498#else
8499 mark_used(dest)
8500 mark_used(source)
8501 mark_used(comm)
8502 mark_used(tag)
8503 send_request = mp_request_null
8504 recv_request = mp_request_null
8505 msgout = msgin
8506#endif
8507 CALL mp_timestop(handle)
8508 END SUBROUTINE mp_isendrecv_i
8509
8510! **************************************************************************************************
8511!> \brief Non-blocking send and receive of a vector
8512!> \param[in] msgin Vector data to send
8513!> \param[in] dest Which process to send to
8514!> \param[out] msgout Receive data into this pointer
8515!> \param[in] source Process to receive from
8516!> \param[in] comm Message passing environment identifier
8517!> \param[out] send_request Request handle for the send
8518!> \param[out] recv_request Request handle for the receive
8519!> \param[in] tag (optional) tag to differentiate requests
8520!> \par Implementation
8521!> Calls mpi_isend and mpi_irecv.
8522!> \par History
8523!> 11.2004 created [Joost VandeVondele]
8524!> \note
8525!> arrays can be pointers or assumed shape, but they must be contiguous!
8526! **************************************************************************************************
8527 SUBROUTINE mp_isendrecv_iv(msgin, dest, msgout, source, comm, send_request, &
8528 recv_request, tag)
8529 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: msgin
8530 INTEGER, INTENT(IN) :: dest
8531 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT) :: msgout
8532 INTEGER, INTENT(IN) :: source
8533 CLASS(mp_comm_type), INTENT(IN) :: comm
8534 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
8535 INTEGER, INTENT(in), OPTIONAL :: tag
8536
8537 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_iv'
8538
8539 INTEGER :: handle
8540#if defined(__parallel)
8541 INTEGER :: ierr, msglen, my_tag
8542 INTEGER(KIND=int_4) :: foo
8543#endif
8544
8545 CALL mp_timeset(routinen, handle)
8546
8547#if defined(__parallel)
8548#if !defined(__GNUC__) || __GNUC__ >= 9
8549 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
8550 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
8551#endif
8552
8553 my_tag = 0
8554 IF (PRESENT(tag)) my_tag = tag
8555
8556 msglen = SIZE(msgout, 1)
8557 IF (msglen > 0) THEN
8558 CALL mpi_irecv(msgout(1), msglen, mpi_integer, source, my_tag, &
8559 comm%handle, recv_request%handle, ierr)
8560 ELSE
8561 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8562 comm%handle, recv_request%handle, ierr)
8563 END IF
8564 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8565
8566 msglen = SIZE(msgin, 1)
8567 IF (msglen > 0) THEN
8568 CALL mpi_isend(msgin(1), msglen, mpi_integer, dest, my_tag, &
8569 comm%handle, send_request%handle, ierr)
8570 ELSE
8571 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8572 comm%handle, send_request%handle, ierr)
8573 END IF
8574 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8575
8576 msglen = (msglen + SIZE(msgout, 1) + 1)/2
8577 CALL add_perf(perf_id=8, count=1, msg_size=msglen*int_4_size)
8578#else
8579 mark_used(dest)
8580 mark_used(source)
8581 mark_used(comm)
8582 mark_used(tag)
8583 send_request = mp_request_null
8584 recv_request = mp_request_null
8585 msgout = msgin
8586#endif
8587 CALL mp_timestop(handle)
8588 END SUBROUTINE mp_isendrecv_iv
8589
8590! **************************************************************************************************
8591!> \brief Non-blocking send of vector data
8592!> \param msgin ...
8593!> \param dest ...
8594!> \param comm ...
8595!> \param request ...
8596!> \param tag ...
8597!> \par History
8598!> 08.2003 created [f&j]
8599!> \note see mp_isendrecv_iv
8600!> \note
8601!> arrays can be pointers or assumed shape, but they must be contiguous!
8602! **************************************************************************************************
8603 SUBROUTINE mp_isend_iv(msgin, dest, comm, request, tag)
8604 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: msgin
8605 INTEGER, INTENT(IN) :: dest
8606 CLASS(mp_comm_type), INTENT(IN) :: comm
8607 TYPE(mp_request_type), INTENT(out) :: request
8608 INTEGER, INTENT(in), OPTIONAL :: tag
8609
8610 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_iv'
8611
8612 INTEGER :: handle, ierr
8613#if defined(__parallel)
8614 INTEGER :: msglen, my_tag
8615 INTEGER(KIND=int_4) :: foo(1)
8616#endif
8617
8618 CALL mp_timeset(routinen, handle)
8619
8620#if defined(__parallel)
8621#if !defined(__GNUC__) || __GNUC__ >= 9
8622 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
8623#endif
8624 my_tag = 0
8625 IF (PRESENT(tag)) my_tag = tag
8626
8627 msglen = SIZE(msgin)
8628 IF (msglen > 0) THEN
8629 CALL mpi_isend(msgin(1), msglen, mpi_integer, dest, my_tag, &
8630 comm%handle, request%handle, ierr)
8631 ELSE
8632 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8633 comm%handle, request%handle, ierr)
8634 END IF
8635 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8636
8637 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8638#else
8639 mark_used(msgin)
8640 mark_used(dest)
8641 mark_used(comm)
8642 mark_used(request)
8643 mark_used(tag)
8644 ierr = 1
8645 request = mp_request_null
8646 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8647#endif
8648 CALL mp_timestop(handle)
8649 END SUBROUTINE mp_isend_iv
8650
8651! **************************************************************************************************
8652!> \brief Non-blocking send of matrix data
8653!> \param msgin ...
8654!> \param dest ...
8655!> \param comm ...
8656!> \param request ...
8657!> \param tag ...
8658!> \par History
8659!> 2009-11-25 [UB] Made type-generic for templates
8660!> \author fawzi
8661!> \note see mp_isendrecv_iv
8662!> \note see mp_isend_iv
8663!> \note
8664!> arrays can be pointers or assumed shape, but they must be contiguous!
8665! **************************************************************************************************
8666 SUBROUTINE mp_isend_im2(msgin, dest, comm, request, tag)
8667 INTEGER(KIND=int_4), DIMENSION(:, :), INTENT(IN) :: msgin
8668 INTEGER, INTENT(IN) :: dest
8669 CLASS(mp_comm_type), INTENT(IN) :: comm
8670 TYPE(mp_request_type), INTENT(out) :: request
8671 INTEGER, INTENT(in), OPTIONAL :: tag
8672
8673 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im2'
8674
8675 INTEGER :: handle, ierr
8676#if defined(__parallel)
8677 INTEGER :: msglen, my_tag
8678 INTEGER(KIND=int_4) :: foo(1)
8679#endif
8680
8681 CALL mp_timeset(routinen, handle)
8682
8683#if defined(__parallel)
8684#if !defined(__GNUC__) || __GNUC__ >= 9
8685 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
8686#endif
8687
8688 my_tag = 0
8689 IF (PRESENT(tag)) my_tag = tag
8690
8691 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
8692 IF (msglen > 0) THEN
8693 CALL mpi_isend(msgin(1, 1), msglen, mpi_integer, dest, my_tag, &
8694 comm%handle, request%handle, ierr)
8695 ELSE
8696 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8697 comm%handle, request%handle, ierr)
8698 END IF
8699 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8700
8701 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8702#else
8703 mark_used(msgin)
8704 mark_used(dest)
8705 mark_used(comm)
8706 mark_used(request)
8707 mark_used(tag)
8708 ierr = 1
8709 request = mp_request_null
8710 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8711#endif
8712 CALL mp_timestop(handle)
8713 END SUBROUTINE mp_isend_im2
8714
8715! **************************************************************************************************
8716!> \brief Non-blocking send of rank-3 data
8717!> \param msgin ...
8718!> \param dest ...
8719!> \param comm ...
8720!> \param request ...
8721!> \param tag ...
8722!> \par History
8723!> 9.2008 added _rm3 subroutine [Iain Bethune]
8724!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
8725!> 2009-11-25 [UB] Made type-generic for templates
8726!> \author fawzi
8727!> \note see mp_isendrecv_iv
8728!> \note see mp_isend_iv
8729!> \note
8730!> arrays can be pointers or assumed shape, but they must be contiguous!
8731! **************************************************************************************************
8732 SUBROUTINE mp_isend_im3(msgin, dest, comm, request, tag)
8733 INTEGER(KIND=int_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
8734 INTEGER, INTENT(IN) :: dest
8735 CLASS(mp_comm_type), INTENT(IN) :: comm
8736 TYPE(mp_request_type), INTENT(out) :: request
8737 INTEGER, INTENT(in), OPTIONAL :: tag
8738
8739 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im3'
8740
8741 INTEGER :: handle, ierr
8742#if defined(__parallel)
8743 INTEGER :: msglen, my_tag
8744 INTEGER(KIND=int_4) :: foo(1)
8745#endif
8746
8747 CALL mp_timeset(routinen, handle)
8748
8749#if defined(__parallel)
8750#if !defined(__GNUC__) || __GNUC__ >= 9
8751 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
8752#endif
8753
8754 my_tag = 0
8755 IF (PRESENT(tag)) my_tag = tag
8756
8757 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
8758 IF (msglen > 0) THEN
8759 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_integer, dest, my_tag, &
8760 comm%handle, request%handle, ierr)
8761 ELSE
8762 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8763 comm%handle, request%handle, ierr)
8764 END IF
8765 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8766
8767 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8768#else
8769 mark_used(msgin)
8770 mark_used(dest)
8771 mark_used(comm)
8772 mark_used(request)
8773 mark_used(tag)
8774 ierr = 1
8775 request = mp_request_null
8776 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8777#endif
8778 CALL mp_timestop(handle)
8779 END SUBROUTINE mp_isend_im3
8780
8781! **************************************************************************************************
8782!> \brief Non-blocking send of rank-4 data
8783!> \param msgin the input message
8784!> \param dest the destination processor
8785!> \param comm the communicator object
8786!> \param request the communication request id
8787!> \param tag the message tag
8788!> \par History
8789!> 2.2016 added _im4 subroutine [Nico Holmberg]
8790!> \author fawzi
8791!> \note see mp_isend_iv
8792!> \note
8793!> arrays can be pointers or assumed shape, but they must be contiguous!
8794! **************************************************************************************************
8795 SUBROUTINE mp_isend_im4(msgin, dest, comm, request, tag)
8796 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
8797 INTEGER, INTENT(IN) :: dest
8798 CLASS(mp_comm_type), INTENT(IN) :: comm
8799 TYPE(mp_request_type), INTENT(out) :: request
8800 INTEGER, INTENT(in), OPTIONAL :: tag
8801
8802 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im4'
8803
8804 INTEGER :: handle, ierr
8805#if defined(__parallel)
8806 INTEGER :: msglen, my_tag
8807 INTEGER(KIND=int_4) :: foo(1)
8808#endif
8809
8810 CALL mp_timeset(routinen, handle)
8811
8812#if defined(__parallel)
8813#if !defined(__GNUC__) || __GNUC__ >= 9
8814 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
8815#endif
8816
8817 my_tag = 0
8818 IF (PRESENT(tag)) my_tag = tag
8819
8820 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
8821 IF (msglen > 0) THEN
8822 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_integer, dest, my_tag, &
8823 comm%handle, request%handle, ierr)
8824 ELSE
8825 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8826 comm%handle, request%handle, ierr)
8827 END IF
8828 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8829
8830 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8831#else
8832 mark_used(msgin)
8833 mark_used(dest)
8834 mark_used(comm)
8835 mark_used(request)
8836 mark_used(tag)
8837 ierr = 1
8838 request = mp_request_null
8839 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8840#endif
8841 CALL mp_timestop(handle)
8842 END SUBROUTINE mp_isend_im4
8843
8844! **************************************************************************************************
8845!> \brief Non-blocking receive of vector data
8846!> \param msgout ...
8847!> \param source ...
8848!> \param comm ...
8849!> \param request ...
8850!> \param tag ...
8851!> \par History
8852!> 08.2003 created [f&j]
8853!> 2009-11-25 [UB] Made type-generic for templates
8854!> \note see mp_isendrecv_iv
8855!> \note
8856!> arrays can be pointers or assumed shape, but they must be contiguous!
8857! **************************************************************************************************
8858 SUBROUTINE mp_irecv_iv(msgout, source, comm, request, tag)
8859 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT) :: msgout
8860 INTEGER, INTENT(IN) :: source
8861 CLASS(mp_comm_type), INTENT(IN) :: comm
8862 TYPE(mp_request_type), INTENT(out) :: request
8863 INTEGER, INTENT(in), OPTIONAL :: tag
8864
8865 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_iv'
8866
8867 INTEGER :: handle
8868#if defined(__parallel)
8869 INTEGER :: ierr, msglen, my_tag
8870 INTEGER(KIND=int_4) :: foo(1)
8871#endif
8872
8873 CALL mp_timeset(routinen, handle)
8874
8875#if defined(__parallel)
8876#if !defined(__GNUC__) || __GNUC__ >= 9
8877 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
8878#endif
8879
8880 my_tag = 0
8881 IF (PRESENT(tag)) my_tag = tag
8882
8883 msglen = SIZE(msgout)
8884 IF (msglen > 0) THEN
8885 CALL mpi_irecv(msgout(1), msglen, mpi_integer, source, my_tag, &
8886 comm%handle, request%handle, ierr)
8887 ELSE
8888 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8889 comm%handle, request%handle, ierr)
8890 END IF
8891 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8892
8893 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8894#else
8895 cpabort("mp_irecv called in non parallel case")
8896 mark_used(msgout)
8897 mark_used(source)
8898 mark_used(comm)
8899 mark_used(tag)
8900 request = mp_request_null
8901#endif
8902 CALL mp_timestop(handle)
8903 END SUBROUTINE mp_irecv_iv
8904
8905! **************************************************************************************************
8906!> \brief Non-blocking receive of matrix data
8907!> \param msgout ...
8908!> \param source ...
8909!> \param comm ...
8910!> \param request ...
8911!> \param tag ...
8912!> \par History
8913!> 2009-11-25 [UB] Made type-generic for templates
8914!> \author fawzi
8915!> \note see mp_isendrecv_iv
8916!> \note see mp_irecv_iv
8917!> \note
8918!> arrays can be pointers or assumed shape, but they must be contiguous!
8919! **************************************************************************************************
8920 SUBROUTINE mp_irecv_im2(msgout, source, comm, request, tag)
8921 INTEGER(KIND=int_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
8922 INTEGER, INTENT(IN) :: source
8923 CLASS(mp_comm_type), INTENT(IN) :: comm
8924 TYPE(mp_request_type), INTENT(out) :: request
8925 INTEGER, INTENT(in), OPTIONAL :: tag
8926
8927 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im2'
8928
8929 INTEGER :: handle
8930#if defined(__parallel)
8931 INTEGER :: ierr, msglen, my_tag
8932 INTEGER(KIND=int_4) :: foo(1)
8933#endif
8934
8935 CALL mp_timeset(routinen, handle)
8936
8937#if defined(__parallel)
8938#if !defined(__GNUC__) || __GNUC__ >= 9
8939 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
8940#endif
8941
8942 my_tag = 0
8943 IF (PRESENT(tag)) my_tag = tag
8944
8945 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
8946 IF (msglen > 0) THEN
8947 CALL mpi_irecv(msgout(1, 1), msglen, mpi_integer, source, my_tag, &
8948 comm%handle, request%handle, ierr)
8949 ELSE
8950 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8951 comm%handle, request%handle, ierr)
8952 END IF
8953 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8954
8955 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8956#else
8957 mark_used(msgout)
8958 mark_used(source)
8959 mark_used(comm)
8960 mark_used(tag)
8961 request = mp_request_null
8962 cpabort("mp_irecv called in non parallel case")
8963#endif
8964 CALL mp_timestop(handle)
8965 END SUBROUTINE mp_irecv_im2
8966
8967! **************************************************************************************************
8968!> \brief Non-blocking send of rank-3 data
8969!> \param msgout ...
8970!> \param source ...
8971!> \param comm ...
8972!> \param request ...
8973!> \param tag ...
8974!> \par History
8975!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
8976!> 2009-11-25 [UB] Made type-generic for templates
8977!> \author fawzi
8978!> \note see mp_isendrecv_iv
8979!> \note see mp_irecv_iv
8980!> \note
8981!> arrays can be pointers or assumed shape, but they must be contiguous!
8982! **************************************************************************************************
8983 SUBROUTINE mp_irecv_im3(msgout, source, comm, request, tag)
8984 INTEGER(KIND=int_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
8985 INTEGER, INTENT(IN) :: source
8986 CLASS(mp_comm_type), INTENT(IN) :: comm
8987 TYPE(mp_request_type), INTENT(out) :: request
8988 INTEGER, INTENT(in), OPTIONAL :: tag
8989
8990 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im3'
8991
8992 INTEGER :: handle
8993#if defined(__parallel)
8994 INTEGER :: ierr, msglen, my_tag
8995 INTEGER(KIND=int_4) :: foo(1)
8996#endif
8997
8998 CALL mp_timeset(routinen, handle)
8999
9000#if defined(__parallel)
9001#if !defined(__GNUC__) || __GNUC__ >= 9
9002 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
9003#endif
9004
9005 my_tag = 0
9006 IF (PRESENT(tag)) my_tag = tag
9007
9008 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
9009 IF (msglen > 0) THEN
9010 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_integer, source, my_tag, &
9011 comm%handle, request%handle, ierr)
9012 ELSE
9013 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
9014 comm%handle, request%handle, ierr)
9015 END IF
9016 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
9017
9018 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
9019#else
9020 mark_used(msgout)
9021 mark_used(source)
9022 mark_used(comm)
9023 mark_used(tag)
9024 request = mp_request_null
9025 cpabort("mp_irecv called in non parallel case")
9026#endif
9027 CALL mp_timestop(handle)
9028 END SUBROUTINE mp_irecv_im3
9029
9030! **************************************************************************************************
9031!> \brief Non-blocking receive of rank-4 data
9032!> \param msgout the output message
9033!> \param source the source processor
9034!> \param comm the communicator object
9035!> \param request the communication request id
9036!> \param tag the message tag
9037!> \par History
9038!> 2.2016 added _im4 subroutine [Nico Holmberg]
9039!> \author fawzi
9040!> \note see mp_irecv_iv
9041!> \note
9042!> arrays can be pointers or assumed shape, but they must be contiguous!
9043! **************************************************************************************************
9044 SUBROUTINE mp_irecv_im4(msgout, source, comm, request, tag)
9045 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
9046 INTEGER, INTENT(IN) :: source
9047 CLASS(mp_comm_type), INTENT(IN) :: comm
9048 TYPE(mp_request_type), INTENT(out) :: request
9049 INTEGER, INTENT(in), OPTIONAL :: tag
9050
9051 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im4'
9052
9053 INTEGER :: handle
9054#if defined(__parallel)
9055 INTEGER :: ierr, msglen, my_tag
9056 INTEGER(KIND=int_4) :: foo(1)
9057#endif
9058
9059 CALL mp_timeset(routinen, handle)
9060
9061#if defined(__parallel)
9062#if !defined(__GNUC__) || __GNUC__ >= 9
9063 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
9064#endif
9065
9066 my_tag = 0
9067 IF (PRESENT(tag)) my_tag = tag
9068
9069 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
9070 IF (msglen > 0) THEN
9071 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_integer, source, my_tag, &
9072 comm%handle, request%handle, ierr)
9073 ELSE
9074 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
9075 comm%handle, request%handle, ierr)
9076 END IF
9077 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
9078
9079 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
9080#else
9081 mark_used(msgout)
9082 mark_used(source)
9083 mark_used(comm)
9084 mark_used(tag)
9085 request = mp_request_null
9086 cpabort("mp_irecv called in non parallel case")
9087#endif
9088 CALL mp_timestop(handle)
9089 END SUBROUTINE mp_irecv_im4
9090
9091! **************************************************************************************************
9092!> \brief Window initialization function for vector data
9093!> \param base ...
9094!> \param comm ...
9095!> \param win ...
9096!> \par History
9097!> 02.2015 created [Alfio Lazzaro]
9098!> \note
9099!> arrays can be pointers or assumed shape, but they must be contiguous!
9100! **************************************************************************************************
9101 SUBROUTINE mp_win_create_iv(base, comm, win)
9102 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
9103 TYPE(mp_comm_type), INTENT(IN) :: comm
9104 CLASS(mp_win_type), INTENT(INOUT) :: win
9105
9106 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_iv'
9107
9108 INTEGER :: handle
9109#if defined(__parallel)
9110 INTEGER :: ierr
9111 INTEGER(kind=mpi_address_kind) :: len
9112 INTEGER(KIND=int_4) :: foo(1)
9113#endif
9114
9115 CALL mp_timeset(routinen, handle)
9116
9117#if defined(__parallel)
9118
9119 len = SIZE(base)*int_4_size
9120 IF (len > 0) THEN
9121 CALL mpi_win_create(base(1), len, int_4_size, mpi_info_null, comm%handle, win%handle, ierr)
9122 ELSE
9123 CALL mpi_win_create(foo, len, int_4_size, mpi_info_null, comm%handle, win%handle, ierr)
9124 END IF
9125 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
9126
9127 CALL add_perf(perf_id=20, count=1)
9128#else
9129 mark_used(base)
9130 mark_used(comm)
9131 win%handle = mp_win_null_handle
9132#endif
9133 CALL mp_timestop(handle)
9134 END SUBROUTINE mp_win_create_iv
9135
9136! **************************************************************************************************
9137!> \brief Single-sided get function for vector data
9138!> \param base ...
9139!> \param comm ...
9140!> \param win ...
9141!> \par History
9142!> 02.2015 created [Alfio Lazzaro]
9143!> \note
9144!> arrays can be pointers or assumed shape, but they must be contiguous!
9145! **************************************************************************************************
9146 SUBROUTINE mp_rget_iv(base, source, win, win_data, myproc, disp, request, &
9147 origin_datatype, target_datatype)
9148 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
9149 INTEGER, INTENT(IN) :: source
9150 CLASS(mp_win_type), INTENT(IN) :: win
9151 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: win_data
9152 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
9153 TYPE(mp_request_type), INTENT(OUT) :: request
9154 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
9155
9156 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_iv'
9157
9158 INTEGER :: handle
9159#if defined(__parallel)
9160 INTEGER :: ierr, len, &
9161 origin_len, target_len
9162 LOGICAL :: do_local_copy
9163 INTEGER(kind=mpi_address_kind) :: disp_aint
9164 mpi_data_type :: handle_origin_datatype, handle_target_datatype
9165#endif
9166
9167 CALL mp_timeset(routinen, handle)
9168
9169#if defined(__parallel)
9170 len = SIZE(base)
9171 disp_aint = 0
9172 IF (PRESENT(disp)) THEN
9173 disp_aint = int(disp, kind=mpi_address_kind)
9174 END IF
9175 handle_origin_datatype = mpi_integer
9176 origin_len = len
9177 IF (PRESENT(origin_datatype)) THEN
9178 handle_origin_datatype = origin_datatype%type_handle
9179 origin_len = 1
9180 END IF
9181 handle_target_datatype = mpi_integer
9182 target_len = len
9183 IF (PRESENT(target_datatype)) THEN
9184 handle_target_datatype = target_datatype%type_handle
9185 target_len = 1
9186 END IF
9187 IF (len > 0) THEN
9188 do_local_copy = .false.
9189 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
9190 IF (myproc .EQ. source) do_local_copy = .true.
9191 END IF
9192 IF (do_local_copy) THEN
9193 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
9194 base(:) = win_data(disp_aint + 1:disp_aint + len)
9195 !$OMP END PARALLEL WORKSHARE
9196 request = mp_request_null
9197 ierr = 0
9198 ELSE
9199 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
9200 target_len, handle_target_datatype, win%handle, request%handle, ierr)
9201 END IF
9202 ELSE
9203 request = mp_request_null
9204 ierr = 0
9205 END IF
9206 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
9207
9208 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*int_4_size)
9209#else
9210 mark_used(source)
9211 mark_used(win)
9212 mark_used(myproc)
9213 mark_used(origin_datatype)
9214 mark_used(target_datatype)
9215
9216 request = mp_request_null
9217 !
9218 IF (PRESENT(disp)) THEN
9219 base(:) = win_data(disp + 1:disp + SIZE(base))
9220 ELSE
9221 base(:) = win_data(:SIZE(base))
9222 END IF
9223
9224#endif
9225 CALL mp_timestop(handle)
9226 END SUBROUTINE mp_rget_iv
9227
9228! **************************************************************************************************
9229!> \brief ...
9230!> \param count ...
9231!> \param lengths ...
9232!> \param displs ...
9233!> \return ...
9234! ***************************************************************************
9235 FUNCTION mp_type_indexed_make_i (count, lengths, displs) &
9236 result(type_descriptor)
9237 INTEGER, INTENT(IN) :: count
9238 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
9239 TYPE(mp_type_descriptor_type) :: type_descriptor
9240
9241 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_i'
9242
9243 INTEGER :: handle
9244#if defined(__parallel)
9245 INTEGER :: ierr
9246#endif
9247
9248 CALL mp_timeset(routinen, handle)
9249
9250#if defined(__parallel)
9251 CALL mpi_type_indexed(count, lengths, displs, mpi_integer, &
9252 type_descriptor%type_handle, ierr)
9253 IF (ierr /= 0) &
9254 cpabort("MPI_Type_Indexed @ "//routinen)
9255 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
9256 IF (ierr /= 0) &
9257 cpabort("MPI_Type_commit @ "//routinen)
9258#else
9259 type_descriptor%type_handle = 17
9260#endif
9261 type_descriptor%length = count
9262 NULLIFY (type_descriptor%subtype)
9263 type_descriptor%vector_descriptor(1:2) = 1
9264 type_descriptor%has_indexing = .true.
9265 type_descriptor%index_descriptor%index => lengths
9266 type_descriptor%index_descriptor%chunks => displs
9267
9268 CALL mp_timestop(handle)
9269
9270 END FUNCTION mp_type_indexed_make_i
9271
9272! **************************************************************************************************
9273!> \brief Allocates special parallel memory
9274!> \param[in] DATA pointer to integer array to allocate
9275!> \param[in] len number of integers to allocate
9276!> \param[out] stat (optional) allocation status result
9277!> \author UB
9278! **************************************************************************************************
9279 SUBROUTINE mp_allocate_i (DATA, len, stat)
9280 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
9281 INTEGER, INTENT(IN) :: len
9282 INTEGER, INTENT(OUT), OPTIONAL :: stat
9283
9284 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_i'
9285
9286 INTEGER :: handle, ierr
9287
9288 CALL mp_timeset(routinen, handle)
9289
9290#if defined(__parallel)
9291 NULLIFY (data)
9292 CALL mp_alloc_mem(DATA, len, stat=ierr)
9293 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
9294 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
9295 CALL add_perf(perf_id=15, count=1)
9296#else
9297 ALLOCATE (DATA(len), stat=ierr)
9298 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
9299 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
9300#endif
9301 IF (PRESENT(stat)) stat = ierr
9302 CALL mp_timestop(handle)
9303 END SUBROUTINE mp_allocate_i
9304
9305! **************************************************************************************************
9306!> \brief Deallocates special parallel memory
9307!> \param[in] DATA pointer to special memory to deallocate
9308!> \param stat ...
9309!> \author UB
9310! **************************************************************************************************
9311 SUBROUTINE mp_deallocate_i (DATA, stat)
9312 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
9313 INTEGER, INTENT(OUT), OPTIONAL :: stat
9314
9315 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_i'
9316
9317 INTEGER :: handle
9318#if defined(__parallel)
9319 INTEGER :: ierr
9320#endif
9321
9322 CALL mp_timeset(routinen, handle)
9323
9324#if defined(__parallel)
9325 CALL mp_free_mem(DATA, ierr)
9326 IF (PRESENT(stat)) THEN
9327 stat = ierr
9328 ELSE
9329 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
9330 END IF
9331 NULLIFY (data)
9332 CALL add_perf(perf_id=15, count=1)
9333#else
9334 DEALLOCATE (data)
9335 IF (PRESENT(stat)) stat = 0
9336#endif
9337 CALL mp_timestop(handle)
9338 END SUBROUTINE mp_deallocate_i
9339
9340! **************************************************************************************************
9341!> \brief (parallel) Blocking individual file write using explicit offsets
9342!> (serial) Unformatted stream write
9343!> \param[in] fh file handle (file storage unit)
9344!> \param[in] offset file offset (position)
9345!> \param[in] msg data to be written to the file
9346!> \param msglen ...
9347!> \par MPI-I/O mapping mpi_file_write_at
9348!> \par STREAM-I/O mapping WRITE
9349!> \param[in](optional) msglen number of the elements of data
9350! **************************************************************************************************
9351 SUBROUTINE mp_file_write_at_iv(fh, offset, msg, msglen)
9352 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
9353 CLASS(mp_file_type), INTENT(IN) :: fh
9354 INTEGER, INTENT(IN), OPTIONAL :: msglen
9355 INTEGER(kind=file_offset), INTENT(IN) :: offset
9356
9357 INTEGER :: msg_len
9358#if defined(__parallel)
9359 INTEGER :: ierr
9360#endif
9361
9362 msg_len = SIZE(msg)
9363 IF (PRESENT(msglen)) msg_len = msglen
9364#if defined(__parallel)
9365 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9366 IF (ierr .NE. 0) &
9367 cpabort("mpi_file_write_at_iv @ mp_file_write_at_iv")
9368#else
9369 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9370#endif
9371 END SUBROUTINE mp_file_write_at_iv
9372
9373! **************************************************************************************************
9374!> \brief ...
9375!> \param fh ...
9376!> \param offset ...
9377!> \param msg ...
9378! **************************************************************************************************
9379 SUBROUTINE mp_file_write_at_i (fh, offset, msg)
9380 INTEGER(KIND=int_4), INTENT(IN) :: msg
9381 CLASS(mp_file_type), INTENT(IN) :: fh
9382 INTEGER(kind=file_offset), INTENT(IN) :: offset
9383
9384#if defined(__parallel)
9385 INTEGER :: ierr
9386
9387 ierr = 0
9388 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9389 IF (ierr .NE. 0) &
9390 cpabort("mpi_file_write_at_i @ mp_file_write_at_i")
9391#else
9392 WRITE (unit=fh%handle, pos=offset + 1) msg
9393#endif
9394 END SUBROUTINE mp_file_write_at_i
9395
9396! **************************************************************************************************
9397!> \brief (parallel) Blocking collective file write using explicit offsets
9398!> (serial) Unformatted stream write
9399!> \param fh ...
9400!> \param offset ...
9401!> \param msg ...
9402!> \param msglen ...
9403!> \par MPI-I/O mapping mpi_file_write_at_all
9404!> \par STREAM-I/O mapping WRITE
9405! **************************************************************************************************
9406 SUBROUTINE mp_file_write_at_all_iv(fh, offset, msg, msglen)
9407 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
9408 CLASS(mp_file_type), INTENT(IN) :: fh
9409 INTEGER, INTENT(IN), OPTIONAL :: msglen
9410 INTEGER(kind=file_offset), INTENT(IN) :: offset
9411
9412 INTEGER :: msg_len
9413#if defined(__parallel)
9414 INTEGER :: ierr
9415#endif
9416
9417 msg_len = SIZE(msg)
9418 IF (PRESENT(msglen)) msg_len = msglen
9419#if defined(__parallel)
9420 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9421 IF (ierr .NE. 0) &
9422 cpabort("mpi_file_write_at_all_iv @ mp_file_write_at_all_iv")
9423#else
9424 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9425#endif
9426 END SUBROUTINE mp_file_write_at_all_iv
9427
9428! **************************************************************************************************
9429!> \brief ...
9430!> \param fh ...
9431!> \param offset ...
9432!> \param msg ...
9433! **************************************************************************************************
9434 SUBROUTINE mp_file_write_at_all_i (fh, offset, msg)
9435 INTEGER(KIND=int_4), INTENT(IN) :: msg
9436 CLASS(mp_file_type), INTENT(IN) :: fh
9437 INTEGER(kind=file_offset), INTENT(IN) :: offset
9438
9439#if defined(__parallel)
9440 INTEGER :: ierr
9441
9442 ierr = 0
9443 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9444 IF (ierr .NE. 0) &
9445 cpabort("mpi_file_write_at_all_i @ mp_file_write_at_all_i")
9446#else
9447 WRITE (unit=fh%handle, pos=offset + 1) msg
9448#endif
9449 END SUBROUTINE mp_file_write_at_all_i
9450
9451! **************************************************************************************************
9452!> \brief (parallel) Blocking individual file read using explicit offsets
9453!> (serial) Unformatted stream read
9454!> \param[in] fh file handle (file storage unit)
9455!> \param[in] offset file offset (position)
9456!> \param[out] msg data to be read from the file
9457!> \param msglen ...
9458!> \par MPI-I/O mapping mpi_file_read_at
9459!> \par STREAM-I/O mapping READ
9460!> \param[in](optional) msglen number of elements of data
9461! **************************************************************************************************
9462 SUBROUTINE mp_file_read_at_iv(fh, offset, msg, msglen)
9463 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msg(:)
9464 CLASS(mp_file_type), INTENT(IN) :: fh
9465 INTEGER, INTENT(IN), OPTIONAL :: msglen
9466 INTEGER(kind=file_offset), INTENT(IN) :: offset
9467
9468 INTEGER :: msg_len
9469#if defined(__parallel)
9470 INTEGER :: ierr
9471#endif
9472
9473 msg_len = SIZE(msg)
9474 IF (PRESENT(msglen)) msg_len = msglen
9475#if defined(__parallel)
9476 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9477 IF (ierr .NE. 0) &
9478 cpabort("mpi_file_read_at_iv @ mp_file_read_at_iv")
9479#else
9480 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9481#endif
9482 END SUBROUTINE mp_file_read_at_iv
9483
9484! **************************************************************************************************
9485!> \brief ...
9486!> \param fh ...
9487!> \param offset ...
9488!> \param msg ...
9489! **************************************************************************************************
9490 SUBROUTINE mp_file_read_at_i (fh, offset, msg)
9491 INTEGER(KIND=int_4), INTENT(OUT) :: msg
9492 CLASS(mp_file_type), INTENT(IN) :: fh
9493 INTEGER(kind=file_offset), INTENT(IN) :: offset
9494
9495#if defined(__parallel)
9496 INTEGER :: ierr
9497
9498 ierr = 0
9499 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9500 IF (ierr .NE. 0) &
9501 cpabort("mpi_file_read_at_i @ mp_file_read_at_i")
9502#else
9503 READ (unit=fh%handle, pos=offset + 1) msg
9504#endif
9505 END SUBROUTINE mp_file_read_at_i
9506
9507! **************************************************************************************************
9508!> \brief (parallel) Blocking collective file read using explicit offsets
9509!> (serial) Unformatted stream read
9510!> \param fh ...
9511!> \param offset ...
9512!> \param msg ...
9513!> \param msglen ...
9514!> \par MPI-I/O mapping mpi_file_read_at_all
9515!> \par STREAM-I/O mapping READ
9516! **************************************************************************************************
9517 SUBROUTINE mp_file_read_at_all_iv(fh, offset, msg, msglen)
9518 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msg(:)
9519 CLASS(mp_file_type), INTENT(IN) :: fh
9520 INTEGER, INTENT(IN), OPTIONAL :: msglen
9521 INTEGER(kind=file_offset), INTENT(IN) :: offset
9522
9523 INTEGER :: msg_len
9524#if defined(__parallel)
9525 INTEGER :: ierr
9526#endif
9527
9528 msg_len = SIZE(msg)
9529 IF (PRESENT(msglen)) msg_len = msglen
9530#if defined(__parallel)
9531 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9532 IF (ierr .NE. 0) &
9533 cpabort("mpi_file_read_at_all_iv @ mp_file_read_at_all_iv")
9534#else
9535 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9536#endif
9537 END SUBROUTINE mp_file_read_at_all_iv
9538
9539! **************************************************************************************************
9540!> \brief ...
9541!> \param fh ...
9542!> \param offset ...
9543!> \param msg ...
9544! **************************************************************************************************
9545 SUBROUTINE mp_file_read_at_all_i (fh, offset, msg)
9546 INTEGER(KIND=int_4), INTENT(OUT) :: msg
9547 CLASS(mp_file_type), INTENT(IN) :: fh
9548 INTEGER(kind=file_offset), INTENT(IN) :: offset
9549
9550#if defined(__parallel)
9551 INTEGER :: ierr
9552
9553 ierr = 0
9554 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9555 IF (ierr .NE. 0) &
9556 cpabort("mpi_file_read_at_all_i @ mp_file_read_at_all_i")
9557#else
9558 READ (unit=fh%handle, pos=offset + 1) msg
9559#endif
9560 END SUBROUTINE mp_file_read_at_all_i
9561
9562! **************************************************************************************************
9563!> \brief ...
9564!> \param ptr ...
9565!> \param vector_descriptor ...
9566!> \param index_descriptor ...
9567!> \return ...
9568! **************************************************************************************************
9569 FUNCTION mp_type_make_i (ptr, &
9570 vector_descriptor, index_descriptor) &
9571 result(type_descriptor)
9572 INTEGER(KIND=int_4), DIMENSION(:), TARGET, asynchronous :: ptr
9573 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
9574 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
9575 TYPE(mp_type_descriptor_type) :: type_descriptor
9576
9577 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_i'
9578
9579#if defined(__parallel)
9580 INTEGER :: ierr
9581#if defined(__MPI_F08)
9582 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
9583 EXTERNAL :: mpi_get_address
9584#endif
9585#endif
9586
9587 NULLIFY (type_descriptor%subtype)
9588 type_descriptor%length = SIZE(ptr)
9589#if defined(__parallel)
9590 type_descriptor%type_handle = mpi_integer
9591 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
9592 IF (ierr /= 0) &
9593 cpabort("MPI_Get_address @ "//routinen)
9594#else
9595 type_descriptor%type_handle = 17
9596#endif
9597 type_descriptor%vector_descriptor(1:2) = 1
9598 type_descriptor%has_indexing = .false.
9599 type_descriptor%data_i => ptr
9600 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
9601 cpabort(routinen//": Vectors and indices NYI")
9602 END IF
9603 END FUNCTION mp_type_make_i
9604
9605! **************************************************************************************************
9606!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
9607!> as the Fortran version returns an integer, which we take to be a C_PTR
9608!> \param DATA data array to allocate
9609!> \param[in] len length (in data elements) of data array allocation
9610!> \param[out] stat (optional) allocation status result
9611! **************************************************************************************************
9612 SUBROUTINE mp_alloc_mem_i (DATA, len, stat)
9613 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: data
9614 INTEGER, INTENT(IN) :: len
9615 INTEGER, INTENT(OUT), OPTIONAL :: stat
9616
9617#if defined(__parallel)
9618 INTEGER :: size, ierr, length, &
9619 mp_res
9620 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
9621 TYPE(c_ptr) :: mp_baseptr
9622 mpi_info_type :: mp_info
9623
9624 length = max(len, 1)
9625 CALL mpi_type_size(mpi_integer, size, ierr)
9626 mp_size = int(length, kind=mpi_address_kind)*size
9627 IF (mp_size .GT. mp_max_memory_size) THEN
9628 cpabort("MPI cannot allocate more than 2 GiByte")
9629 END IF
9630 mp_info = mpi_info_null
9631 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
9632 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
9633 IF (PRESENT(stat)) stat = mp_res
9634#else
9635 INTEGER :: length, mystat
9636 length = max(len, 1)
9637 IF (PRESENT(stat)) THEN
9638 ALLOCATE (DATA(length), stat=mystat)
9639 stat = mystat ! show to convention checker that stat is used
9640 ELSE
9641 ALLOCATE (DATA(length))
9642 END IF
9643#endif
9644 END SUBROUTINE mp_alloc_mem_i
9645
9646! **************************************************************************************************
9647!> \brief Deallocates am array, ... this is hackish
9648!> as the Fortran version takes an integer, which we hope to get by reference
9649!> \param DATA data array to allocate
9650!> \param[out] stat (optional) allocation status result
9651! **************************************************************************************************
9652 SUBROUTINE mp_free_mem_i (DATA, stat)
9653 INTEGER(KIND=int_4), DIMENSION(:), &
9654 POINTER, asynchronous :: data
9655 INTEGER, INTENT(OUT), OPTIONAL :: stat
9656
9657#if defined(__parallel)
9658 INTEGER :: mp_res
9659 CALL mpi_free_mem(DATA, mp_res)
9660 IF (PRESENT(stat)) stat = mp_res
9661#else
9662 DEALLOCATE (data)
9663 IF (PRESENT(stat)) stat = 0
9664#endif
9665 END SUBROUTINE mp_free_mem_i
9666! **************************************************************************************************
9667!> \brief Shift around the data in msg
9668!> \param[in,out] msg Rank-2 data to shift
9669!> \param[in] comm message passing environment identifier
9670!> \param[in] displ_in displacements (?)
9671!> \par Example
9672!> msg will be moved from rank to rank+displ_in (in a circular way)
9673!> \par Limitations
9674!> * displ_in will be 1 by default (others not tested)
9675!> * the message array needs to be the same size on all processes
9676! **************************************************************************************************
9677 SUBROUTINE mp_shift_lm(msg, comm, displ_in)
9678
9679 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
9680 CLASS(mp_comm_type), INTENT(IN) :: comm
9681 INTEGER, INTENT(IN), OPTIONAL :: displ_in
9682
9683 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_lm'
9684
9685 INTEGER :: handle, ierror
9686#if defined(__parallel)
9687 INTEGER :: displ, left, &
9688 msglen, myrank, nprocs, &
9689 right, tag
9690#endif
9691
9692 ierror = 0
9693 CALL mp_timeset(routinen, handle)
9694
9695#if defined(__parallel)
9696 CALL mpi_comm_rank(comm%handle, myrank, ierror)
9697 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
9698 CALL mpi_comm_size(comm%handle, nprocs, ierror)
9699 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
9700 IF (PRESENT(displ_in)) THEN
9701 displ = displ_in
9702 ELSE
9703 displ = 1
9704 END IF
9705 right = modulo(myrank + displ, nprocs)
9706 left = modulo(myrank - displ, nprocs)
9707 tag = 17
9708 msglen = SIZE(msg)
9709 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer8, right, tag, left, tag, &
9710 comm%handle, mpi_status_ignore, ierror)
9711 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
9712 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_8_size)
9713#else
9714 mark_used(msg)
9715 mark_used(comm)
9716 mark_used(displ_in)
9717#endif
9718 CALL mp_timestop(handle)
9719
9720 END SUBROUTINE mp_shift_lm
9721
9722! **************************************************************************************************
9723!> \brief Shift around the data in msg
9724!> \param[in,out] msg Data to shift
9725!> \param[in] comm message passing environment identifier
9726!> \param[in] displ_in displacements (?)
9727!> \par Example
9728!> msg will be moved from rank to rank+displ_in (in a circular way)
9729!> \par Limitations
9730!> * displ_in will be 1 by default (others not tested)
9731!> * the message array needs to be the same size on all processes
9732! **************************************************************************************************
9733 SUBROUTINE mp_shift_l (msg, comm, displ_in)
9734
9735 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
9736 CLASS(mp_comm_type), INTENT(IN) :: comm
9737 INTEGER, INTENT(IN), OPTIONAL :: displ_in
9738
9739 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_l'
9740
9741 INTEGER :: handle, ierror
9742#if defined(__parallel)
9743 INTEGER :: displ, left, &
9744 msglen, myrank, nprocs, &
9745 right, tag
9746#endif
9747
9748 ierror = 0
9749 CALL mp_timeset(routinen, handle)
9750
9751#if defined(__parallel)
9752 CALL mpi_comm_rank(comm%handle, myrank, ierror)
9753 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
9754 CALL mpi_comm_size(comm%handle, nprocs, ierror)
9755 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
9756 IF (PRESENT(displ_in)) THEN
9757 displ = displ_in
9758 ELSE
9759 displ = 1
9760 END IF
9761 right = modulo(myrank + displ, nprocs)
9762 left = modulo(myrank - displ, nprocs)
9763 tag = 19
9764 msglen = SIZE(msg)
9765 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer8, right, tag, left, &
9766 tag, comm%handle, mpi_status_ignore, ierror)
9767 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
9768 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_8_size)
9769#else
9770 mark_used(msg)
9771 mark_used(comm)
9772 mark_used(displ_in)
9773#endif
9774 CALL mp_timestop(handle)
9775
9776 END SUBROUTINE mp_shift_l
9777
9778! **************************************************************************************************
9779!> \brief All-to-all data exchange, rank-1 data of different sizes
9780!> \param[in] sb Data to send
9781!> \param[in] scount Data counts for data sent to other processes
9782!> \param[in] sdispl Respective data offsets for data sent to process
9783!> \param[in,out] rb Buffer into which to receive data
9784!> \param[in] rcount Data counts for data received from other
9785!> processes
9786!> \param[in] rdispl Respective data offsets for data received from
9787!> other processes
9788!> \param[in] comm Message passing environment identifier
9789!> \par MPI mapping
9790!> mpi_alltoallv
9791!> \par Array sizes
9792!> The scount, rcount, and the sdispl and rdispl arrays have a
9793!> size equal to the number of processes.
9794!> \par Offsets
9795!> Values in sdispl and rdispl start with 0.
9796! **************************************************************************************************
9797 SUBROUTINE mp_alltoall_l11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
9798
9799 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
9800 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
9801 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
9802 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
9803 CLASS(mp_comm_type), INTENT(IN) :: comm
9804
9805 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l11v'
9806
9807 INTEGER :: handle
9808#if defined(__parallel)
9809 INTEGER :: ierr, msglen
9810#else
9811 INTEGER :: i
9812#endif
9813
9814 CALL mp_timeset(routinen, handle)
9815
9816#if defined(__parallel)
9817 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer8, &
9818 rb, rcount, rdispl, mpi_integer8, comm%handle, ierr)
9819 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
9820 msglen = sum(scount) + sum(rcount)
9821 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9822#else
9823 mark_used(comm)
9824 mark_used(scount)
9825 mark_used(sdispl)
9826 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
9827 DO i = 1, rcount(1)
9828 rb(rdispl(1) + i) = sb(sdispl(1) + i)
9829 END DO
9830#endif
9831 CALL mp_timestop(handle)
9832
9833 END SUBROUTINE mp_alltoall_l11v
9834
9835! **************************************************************************************************
9836!> \brief All-to-all data exchange, rank-2 data of different sizes
9837!> \param sb ...
9838!> \param scount ...
9839!> \param sdispl ...
9840!> \param rb ...
9841!> \param rcount ...
9842!> \param rdispl ...
9843!> \param comm ...
9844!> \par MPI mapping
9845!> mpi_alltoallv
9846!> \note see mp_alltoall_l11v
9847! **************************************************************************************************
9848 SUBROUTINE mp_alltoall_l22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
9849
9850 INTEGER(KIND=int_8), DIMENSION(:, :), &
9851 INTENT(IN), CONTIGUOUS :: sb
9852 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
9853 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, &
9854 INTENT(INOUT) :: rb
9855 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
9856 CLASS(mp_comm_type), INTENT(IN) :: comm
9857
9858 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l22v'
9859
9860 INTEGER :: handle
9861#if defined(__parallel)
9862 INTEGER :: ierr, msglen
9863#endif
9864
9865 CALL mp_timeset(routinen, handle)
9866
9867#if defined(__parallel)
9868 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer8, &
9869 rb, rcount, rdispl, mpi_integer8, comm%handle, ierr)
9870 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
9871 msglen = sum(scount) + sum(rcount)
9872 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*int_8_size)
9873#else
9874 mark_used(comm)
9875 mark_used(scount)
9876 mark_used(sdispl)
9877 mark_used(rcount)
9878 mark_used(rdispl)
9879 rb = sb
9880#endif
9881 CALL mp_timestop(handle)
9882
9883 END SUBROUTINE mp_alltoall_l22v
9884
9885! **************************************************************************************************
9886!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
9887!> \param[in] sb array with data to send
9888!> \param[out] rb array into which data is received
9889!> \param[in] count number of elements to send/receive (product of the
9890!> extents of the first two dimensions)
9891!> \param[in] comm Message passing environment identifier
9892!> \par Index meaning
9893!> \par The first two indices specify the data while the last index counts
9894!> the processes
9895!> \par Sizes of ranks
9896!> All processes have the same data size.
9897!> \par MPI mapping
9898!> mpi_alltoall
9899! **************************************************************************************************
9900 SUBROUTINE mp_alltoall_l (sb, rb, count, comm)
9901
9902 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
9903 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
9904 INTEGER, INTENT(IN) :: count
9905 CLASS(mp_comm_type), INTENT(IN) :: comm
9906
9907 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l'
9908
9909 INTEGER :: handle
9910#if defined(__parallel)
9911 INTEGER :: ierr, msglen, np
9912#endif
9913
9914 CALL mp_timeset(routinen, handle)
9915
9916#if defined(__parallel)
9917 CALL mpi_alltoall(sb, count, mpi_integer8, &
9918 rb, count, mpi_integer8, comm%handle, ierr)
9919 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9920 CALL mpi_comm_size(comm%handle, np, ierr)
9921 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9922 msglen = 2*count*np
9923 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9924#else
9925 mark_used(count)
9926 mark_used(comm)
9927 rb = sb
9928#endif
9929 CALL mp_timestop(handle)
9930
9931 END SUBROUTINE mp_alltoall_l
9932
9933! **************************************************************************************************
9934!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
9935!> \param sb ...
9936!> \param rb ...
9937!> \param count ...
9938!> \param commp ...
9939!> \note see mp_alltoall_l
9940! **************************************************************************************************
9941 SUBROUTINE mp_alltoall_l22(sb, rb, count, comm)
9942
9943 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
9944 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
9945 INTEGER, INTENT(IN) :: count
9946 CLASS(mp_comm_type), INTENT(IN) :: comm
9947
9948 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l22'
9949
9950 INTEGER :: handle
9951#if defined(__parallel)
9952 INTEGER :: ierr, msglen, np
9953#endif
9954
9955 CALL mp_timeset(routinen, handle)
9956
9957#if defined(__parallel)
9958 CALL mpi_alltoall(sb, count, mpi_integer8, &
9959 rb, count, mpi_integer8, comm%handle, ierr)
9960 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9961 CALL mpi_comm_size(comm%handle, np, ierr)
9962 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9963 msglen = 2*SIZE(sb)*np
9964 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9965#else
9966 mark_used(count)
9967 mark_used(comm)
9968 rb = sb
9969#endif
9970 CALL mp_timestop(handle)
9971
9972 END SUBROUTINE mp_alltoall_l22
9973
9974! **************************************************************************************************
9975!> \brief All-to-all data exchange, rank-3 data with equal sizes
9976!> \param sb ...
9977!> \param rb ...
9978!> \param count ...
9979!> \param comm ...
9980!> \note see mp_alltoall_l
9981! **************************************************************************************************
9982 SUBROUTINE mp_alltoall_l33(sb, rb, count, comm)
9983
9984 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
9985 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
9986 INTEGER, INTENT(IN) :: count
9987 CLASS(mp_comm_type), INTENT(IN) :: comm
9988
9989 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l33'
9990
9991 INTEGER :: handle
9992#if defined(__parallel)
9993 INTEGER :: ierr, msglen, np
9994#endif
9995
9996 CALL mp_timeset(routinen, handle)
9997
9998#if defined(__parallel)
9999 CALL mpi_alltoall(sb, count, mpi_integer8, &
10000 rb, count, mpi_integer8, comm%handle, ierr)
10001 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10002 CALL mpi_comm_size(comm%handle, np, ierr)
10003 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10004 msglen = 2*count*np
10005 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10006#else
10007 mark_used(count)
10008 mark_used(comm)
10009 rb = sb
10010#endif
10011 CALL mp_timestop(handle)
10012
10013 END SUBROUTINE mp_alltoall_l33
10014
10015! **************************************************************************************************
10016!> \brief All-to-all data exchange, rank 4 data, equal sizes
10017!> \param sb ...
10018!> \param rb ...
10019!> \param count ...
10020!> \param comm ...
10021!> \note see mp_alltoall_l
10022! **************************************************************************************************
10023 SUBROUTINE mp_alltoall_l44(sb, rb, count, comm)
10024
10025 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10026 INTENT(IN) :: sb
10027 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10028 INTENT(OUT) :: rb
10029 INTEGER, INTENT(IN) :: count
10030 CLASS(mp_comm_type), INTENT(IN) :: comm
10031
10032 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l44'
10033
10034 INTEGER :: handle
10035#if defined(__parallel)
10036 INTEGER :: ierr, msglen, np
10037#endif
10038
10039 CALL mp_timeset(routinen, handle)
10040
10041#if defined(__parallel)
10042 CALL mpi_alltoall(sb, count, mpi_integer8, &
10043 rb, count, mpi_integer8, comm%handle, ierr)
10044 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10045 CALL mpi_comm_size(comm%handle, np, ierr)
10046 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10047 msglen = 2*count*np
10048 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10049#else
10050 mark_used(count)
10051 mark_used(comm)
10052 rb = sb
10053#endif
10054 CALL mp_timestop(handle)
10055
10056 END SUBROUTINE mp_alltoall_l44
10057
10058! **************************************************************************************************
10059!> \brief All-to-all data exchange, rank 5 data, equal sizes
10060!> \param sb ...
10061!> \param rb ...
10062!> \param count ...
10063!> \param comm ...
10064!> \note see mp_alltoall_l
10065! **************************************************************************************************
10066 SUBROUTINE mp_alltoall_l55(sb, rb, count, comm)
10067
10068 INTEGER(KIND=int_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
10069 INTENT(IN) :: sb
10070 INTEGER(KIND=int_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
10071 INTENT(OUT) :: rb
10072 INTEGER, INTENT(IN) :: count
10073 CLASS(mp_comm_type), INTENT(IN) :: comm
10074
10075 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l55'
10076
10077 INTEGER :: handle
10078#if defined(__parallel)
10079 INTEGER :: ierr, msglen, np
10080#endif
10081
10082 CALL mp_timeset(routinen, handle)
10083
10084#if defined(__parallel)
10085 CALL mpi_alltoall(sb, count, mpi_integer8, &
10086 rb, count, mpi_integer8, comm%handle, ierr)
10087 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10088 CALL mpi_comm_size(comm%handle, np, ierr)
10089 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10090 msglen = 2*count*np
10091 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10092#else
10093 mark_used(count)
10094 mark_used(comm)
10095 rb = sb
10096#endif
10097 CALL mp_timestop(handle)
10098
10099 END SUBROUTINE mp_alltoall_l55
10100
10101! **************************************************************************************************
10102!> \brief All-to-all data exchange, rank-4 data to rank-5 data
10103!> \param sb ...
10104!> \param rb ...
10105!> \param count ...
10106!> \param comm ...
10107!> \note see mp_alltoall_l
10108!> \note User must ensure size consistency.
10109! **************************************************************************************************
10110 SUBROUTINE mp_alltoall_l45(sb, rb, count, comm)
10111
10112 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10113 INTENT(IN) :: sb
10114 INTEGER(KIND=int_8), &
10115 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
10116 INTEGER, INTENT(IN) :: count
10117 CLASS(mp_comm_type), INTENT(IN) :: comm
10118
10119 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l45'
10120
10121 INTEGER :: handle
10122#if defined(__parallel)
10123 INTEGER :: ierr, msglen, np
10124#endif
10125
10126 CALL mp_timeset(routinen, handle)
10127
10128#if defined(__parallel)
10129 CALL mpi_alltoall(sb, count, mpi_integer8, &
10130 rb, count, mpi_integer8, comm%handle, ierr)
10131 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10132 CALL mpi_comm_size(comm%handle, np, ierr)
10133 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10134 msglen = 2*count*np
10135 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10136#else
10137 mark_used(count)
10138 mark_used(comm)
10139 rb = reshape(sb, shape(rb))
10140#endif
10141 CALL mp_timestop(handle)
10142
10143 END SUBROUTINE mp_alltoall_l45
10144
10145! **************************************************************************************************
10146!> \brief All-to-all data exchange, rank-3 data to rank-4 data
10147!> \param sb ...
10148!> \param rb ...
10149!> \param count ...
10150!> \param comm ...
10151!> \note see mp_alltoall_l
10152!> \note User must ensure size consistency.
10153! **************************************************************************************************
10154 SUBROUTINE mp_alltoall_l34(sb, rb, count, comm)
10155
10156 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, &
10157 INTENT(IN) :: sb
10158 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10159 INTENT(OUT) :: rb
10160 INTEGER, INTENT(IN) :: count
10161 CLASS(mp_comm_type), INTENT(IN) :: comm
10162
10163 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l34'
10164
10165 INTEGER :: handle
10166#if defined(__parallel)
10167 INTEGER :: ierr, msglen, np
10168#endif
10169
10170 CALL mp_timeset(routinen, handle)
10171
10172#if defined(__parallel)
10173 CALL mpi_alltoall(sb, count, mpi_integer8, &
10174 rb, count, mpi_integer8, comm%handle, ierr)
10175 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10176 CALL mpi_comm_size(comm%handle, np, ierr)
10177 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10178 msglen = 2*count*np
10179 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10180#else
10181 mark_used(count)
10182 mark_used(comm)
10183 rb = reshape(sb, shape(rb))
10184#endif
10185 CALL mp_timestop(handle)
10186
10187 END SUBROUTINE mp_alltoall_l34
10188
10189! **************************************************************************************************
10190!> \brief All-to-all data exchange, rank-5 data to rank-4 data
10191!> \param sb ...
10192!> \param rb ...
10193!> \param count ...
10194!> \param comm ...
10195!> \note see mp_alltoall_l
10196!> \note User must ensure size consistency.
10197! **************************************************************************************************
10198 SUBROUTINE mp_alltoall_l54(sb, rb, count, comm)
10199
10200 INTEGER(KIND=int_8), &
10201 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
10202 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10203 INTENT(OUT) :: rb
10204 INTEGER, INTENT(IN) :: count
10205 CLASS(mp_comm_type), INTENT(IN) :: comm
10206
10207 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l54'
10208
10209 INTEGER :: handle
10210#if defined(__parallel)
10211 INTEGER :: ierr, msglen, np
10212#endif
10213
10214 CALL mp_timeset(routinen, handle)
10215
10216#if defined(__parallel)
10217 CALL mpi_alltoall(sb, count, mpi_integer8, &
10218 rb, count, mpi_integer8, comm%handle, ierr)
10219 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10220 CALL mpi_comm_size(comm%handle, np, ierr)
10221 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10222 msglen = 2*count*np
10223 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10224#else
10225 mark_used(count)
10226 mark_used(comm)
10227 rb = reshape(sb, shape(rb))
10228#endif
10229 CALL mp_timestop(handle)
10230
10231 END SUBROUTINE mp_alltoall_l54
10232
10233! **************************************************************************************************
10234!> \brief Send one datum to another process
10235!> \param[in] msg Scalar to send
10236!> \param[in] dest Destination process
10237!> \param[in] tag Transfer identifier
10238!> \param[in] comm Message passing environment identifier
10239!> \par MPI mapping
10240!> mpi_send
10241! **************************************************************************************************
10242 SUBROUTINE mp_send_l (msg, dest, tag, comm)
10243 INTEGER(KIND=int_8), INTENT(IN) :: msg
10244 INTEGER, INTENT(IN) :: dest, tag
10245 CLASS(mp_comm_type), INTENT(IN) :: comm
10246
10247 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_l'
10248
10249 INTEGER :: handle
10250#if defined(__parallel)
10251 INTEGER :: ierr, msglen
10252#endif
10253
10254 CALL mp_timeset(routinen, handle)
10255
10256#if defined(__parallel)
10257 msglen = 1
10258 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10259 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10260 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10261#else
10262 mark_used(msg)
10263 mark_used(dest)
10264 mark_used(tag)
10265 mark_used(comm)
10266 ! only defined in parallel
10267 cpabort("not in parallel mode")
10268#endif
10269 CALL mp_timestop(handle)
10270 END SUBROUTINE mp_send_l
10271
10272! **************************************************************************************************
10273!> \brief Send rank-1 data to another process
10274!> \param[in] msg Rank-1 data to send
10275!> \param dest ...
10276!> \param tag ...
10277!> \param comm ...
10278!> \note see mp_send_l
10279! **************************************************************************************************
10280 SUBROUTINE mp_send_lv(msg, dest, tag, comm)
10281 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
10282 INTEGER, INTENT(IN) :: dest, tag
10283 CLASS(mp_comm_type), INTENT(IN) :: comm
10284
10285 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_lv'
10286
10287 INTEGER :: handle
10288#if defined(__parallel)
10289 INTEGER :: ierr, msglen
10290#endif
10291
10292 CALL mp_timeset(routinen, handle)
10293
10294#if defined(__parallel)
10295 msglen = SIZE(msg)
10296 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10297 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10298 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10299#else
10300 mark_used(msg)
10301 mark_used(dest)
10302 mark_used(tag)
10303 mark_used(comm)
10304 ! only defined in parallel
10305 cpabort("not in parallel mode")
10306#endif
10307 CALL mp_timestop(handle)
10308 END SUBROUTINE mp_send_lv
10309
10310! **************************************************************************************************
10311!> \brief Send rank-2 data to another process
10312!> \param[in] msg Rank-2 data to send
10313!> \param dest ...
10314!> \param tag ...
10315!> \param comm ...
10316!> \note see mp_send_l
10317! **************************************************************************************************
10318 SUBROUTINE mp_send_lm2(msg, dest, tag, comm)
10319 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
10320 INTEGER, INTENT(IN) :: dest, tag
10321 CLASS(mp_comm_type), INTENT(IN) :: comm
10322
10323 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_lm2'
10324
10325 INTEGER :: handle
10326#if defined(__parallel)
10327 INTEGER :: ierr, msglen
10328#endif
10329
10330 CALL mp_timeset(routinen, handle)
10331
10332#if defined(__parallel)
10333 msglen = SIZE(msg)
10334 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10335 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10336 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10337#else
10338 mark_used(msg)
10339 mark_used(dest)
10340 mark_used(tag)
10341 mark_used(comm)
10342 ! only defined in parallel
10343 cpabort("not in parallel mode")
10344#endif
10345 CALL mp_timestop(handle)
10346 END SUBROUTINE mp_send_lm2
10347
10348! **************************************************************************************************
10349!> \brief Send rank-3 data to another process
10350!> \param[in] msg Rank-3 data to send
10351!> \param dest ...
10352!> \param tag ...
10353!> \param comm ...
10354!> \note see mp_send_l
10355! **************************************************************************************************
10356 SUBROUTINE mp_send_lm3(msg, dest, tag, comm)
10357 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
10358 INTEGER, INTENT(IN) :: dest, tag
10359 CLASS(mp_comm_type), INTENT(IN) :: comm
10360
10361 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
10362
10363 INTEGER :: handle
10364#if defined(__parallel)
10365 INTEGER :: ierr, msglen
10366#endif
10367
10368 CALL mp_timeset(routinen, handle)
10369
10370#if defined(__parallel)
10371 msglen = SIZE(msg)
10372 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10373 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10374 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10375#else
10376 mark_used(msg)
10377 mark_used(dest)
10378 mark_used(tag)
10379 mark_used(comm)
10380 ! only defined in parallel
10381 cpabort("not in parallel mode")
10382#endif
10383 CALL mp_timestop(handle)
10384 END SUBROUTINE mp_send_lm3
10385
10386! **************************************************************************************************
10387!> \brief Receive one datum from another process
10388!> \param[in,out] msg Place received data into this variable
10389!> \param[in,out] source Process to receive from
10390!> \param[in,out] tag Transfer identifier
10391!> \param[in] comm Message passing environment identifier
10392!> \par MPI mapping
10393!> mpi_send
10394! **************************************************************************************************
10395 SUBROUTINE mp_recv_l (msg, source, tag, comm)
10396 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10397 INTEGER, INTENT(INOUT) :: source, tag
10398 CLASS(mp_comm_type), INTENT(IN) :: comm
10399
10400 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_l'
10401
10402 INTEGER :: handle
10403#if defined(__parallel)
10404 INTEGER :: ierr, msglen
10405 mpi_status_type :: status
10406#endif
10407
10408 CALL mp_timeset(routinen, handle)
10409
10410#if defined(__parallel)
10411 msglen = 1
10412 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10413 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10414 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10415 ELSE
10416 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10417 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10418 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10419 source = status mpi_status_extract(mpi_source)
10420 tag = status mpi_status_extract(mpi_tag)
10421 END IF
10422#else
10423 mark_used(msg)
10424 mark_used(source)
10425 mark_used(tag)
10426 mark_used(comm)
10427 ! only defined in parallel
10428 cpabort("not in parallel mode")
10429#endif
10430 CALL mp_timestop(handle)
10431 END SUBROUTINE mp_recv_l
10432
10433! **************************************************************************************************
10434!> \brief Receive rank-1 data from another process
10435!> \param[in,out] msg Place received data into this rank-1 array
10436!> \param source ...
10437!> \param tag ...
10438!> \param comm ...
10439!> \note see mp_recv_l
10440! **************************************************************************************************
10441 SUBROUTINE mp_recv_lv(msg, source, tag, comm)
10442 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10443 INTEGER, INTENT(INOUT) :: source, tag
10444 CLASS(mp_comm_type), INTENT(IN) :: comm
10445
10446 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lv'
10447
10448 INTEGER :: handle
10449#if defined(__parallel)
10450 INTEGER :: ierr, msglen
10451 mpi_status_type :: status
10452#endif
10453
10454 CALL mp_timeset(routinen, handle)
10455
10456#if defined(__parallel)
10457 msglen = SIZE(msg)
10458 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10459 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10460 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10461 ELSE
10462 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10463 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10464 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10465 source = status mpi_status_extract(mpi_source)
10466 tag = status mpi_status_extract(mpi_tag)
10467 END IF
10468#else
10469 mark_used(msg)
10470 mark_used(source)
10471 mark_used(tag)
10472 mark_used(comm)
10473 ! only defined in parallel
10474 cpabort("not in parallel mode")
10475#endif
10476 CALL mp_timestop(handle)
10477 END SUBROUTINE mp_recv_lv
10478
10479! **************************************************************************************************
10480!> \brief Receive rank-2 data from another process
10481!> \param[in,out] msg Place received data into this rank-2 array
10482!> \param source ...
10483!> \param tag ...
10484!> \param comm ...
10485!> \note see mp_recv_l
10486! **************************************************************************************************
10487 SUBROUTINE mp_recv_lm2(msg, source, tag, comm)
10488 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10489 INTEGER, INTENT(INOUT) :: source, tag
10490 CLASS(mp_comm_type), INTENT(IN) :: comm
10491
10492 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lm2'
10493
10494 INTEGER :: handle
10495#if defined(__parallel)
10496 INTEGER :: ierr, msglen
10497 mpi_status_type :: status
10498#endif
10499
10500 CALL mp_timeset(routinen, handle)
10501
10502#if defined(__parallel)
10503 msglen = SIZE(msg)
10504 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10505 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10506 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10507 ELSE
10508 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10509 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10510 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10511 source = status mpi_status_extract(mpi_source)
10512 tag = status mpi_status_extract(mpi_tag)
10513 END IF
10514#else
10515 mark_used(msg)
10516 mark_used(source)
10517 mark_used(tag)
10518 mark_used(comm)
10519 ! only defined in parallel
10520 cpabort("not in parallel mode")
10521#endif
10522 CALL mp_timestop(handle)
10523 END SUBROUTINE mp_recv_lm2
10524
10525! **************************************************************************************************
10526!> \brief Receive rank-3 data from another process
10527!> \param[in,out] msg Place received data into this rank-3 array
10528!> \param source ...
10529!> \param tag ...
10530!> \param comm ...
10531!> \note see mp_recv_l
10532! **************************************************************************************************
10533 SUBROUTINE mp_recv_lm3(msg, source, tag, comm)
10534 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
10535 INTEGER, INTENT(INOUT) :: source, tag
10536 CLASS(mp_comm_type), INTENT(IN) :: comm
10537
10538 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lm3'
10539
10540 INTEGER :: handle
10541#if defined(__parallel)
10542 INTEGER :: ierr, msglen
10543 mpi_status_type :: status
10544#endif
10545
10546 CALL mp_timeset(routinen, handle)
10547
10548#if defined(__parallel)
10549 msglen = SIZE(msg)
10550 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10551 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10552 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10553 ELSE
10554 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10555 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10556 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10557 source = status mpi_status_extract(mpi_source)
10558 tag = status mpi_status_extract(mpi_tag)
10559 END IF
10560#else
10561 mark_used(msg)
10562 mark_used(source)
10563 mark_used(tag)
10564 mark_used(comm)
10565 ! only defined in parallel
10566 cpabort("not in parallel mode")
10567#endif
10568 CALL mp_timestop(handle)
10569 END SUBROUTINE mp_recv_lm3
10570
10571! **************************************************************************************************
10572!> \brief Broadcasts a datum to all processes.
10573!> \param[in] msg Datum to broadcast
10574!> \param[in] source Processes which broadcasts
10575!> \param[in] comm Message passing environment identifier
10576!> \par MPI mapping
10577!> mpi_bcast
10578! **************************************************************************************************
10579 SUBROUTINE mp_bcast_l (msg, source, comm)
10580 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10581 INTEGER, INTENT(IN) :: source
10582 CLASS(mp_comm_type), INTENT(IN) :: comm
10583
10584 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l'
10585
10586 INTEGER :: handle
10587#if defined(__parallel)
10588 INTEGER :: ierr, msglen
10589#endif
10590
10591 CALL mp_timeset(routinen, handle)
10592
10593#if defined(__parallel)
10594 msglen = 1
10595 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10596 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10597 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10598#else
10599 mark_used(msg)
10600 mark_used(source)
10601 mark_used(comm)
10602#endif
10603 CALL mp_timestop(handle)
10604 END SUBROUTINE mp_bcast_l
10605
10606! **************************************************************************************************
10607!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
10608!> \param[in] msg Datum to broadcast
10609!> \param[in] comm Message passing environment identifier
10610!> \par MPI mapping
10611!> mpi_bcast
10612! **************************************************************************************************
10613 SUBROUTINE mp_bcast_l_src(msg, comm)
10614 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10615 CLASS(mp_comm_type), INTENT(IN) :: comm
10616
10617 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l_src'
10618
10619 INTEGER :: handle
10620#if defined(__parallel)
10621 INTEGER :: ierr, msglen
10622#endif
10623
10624 CALL mp_timeset(routinen, handle)
10625
10626#if defined(__parallel)
10627 msglen = 1
10628 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10629 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10630 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10631#else
10632 mark_used(msg)
10633 mark_used(comm)
10634#endif
10635 CALL mp_timestop(handle)
10636 END SUBROUTINE mp_bcast_l_src
10637
10638! **************************************************************************************************
10639!> \brief Broadcasts a datum to all processes.
10640!> \param[in] msg Datum to broadcast
10641!> \param[in] source Processes which broadcasts
10642!> \param[in] comm Message passing environment identifier
10643!> \par MPI mapping
10644!> mpi_bcast
10645! **************************************************************************************************
10646 SUBROUTINE mp_ibcast_l (msg, source, comm, request)
10647 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10648 INTEGER, INTENT(IN) :: source
10649 CLASS(mp_comm_type), INTENT(IN) :: comm
10650 TYPE(mp_request_type), INTENT(OUT) :: request
10651
10652 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_l'
10653
10654 INTEGER :: handle
10655#if defined(__parallel)
10656 INTEGER :: ierr, msglen
10657#endif
10658
10659 CALL mp_timeset(routinen, handle)
10660
10661#if defined(__parallel)
10662 msglen = 1
10663 CALL mpi_ibcast(msg, msglen, mpi_integer8, source, comm%handle, request%handle, ierr)
10664 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
10665 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_8_size)
10666#else
10667 mark_used(msg)
10668 mark_used(source)
10669 mark_used(comm)
10670 request = mp_request_null
10671#endif
10672 CALL mp_timestop(handle)
10673 END SUBROUTINE mp_ibcast_l
10674
10675! **************************************************************************************************
10676!> \brief Broadcasts rank-1 data to all processes
10677!> \param[in] msg Data to broadcast
10678!> \param source ...
10679!> \param comm ...
10680!> \note see mp_bcast_l1
10681! **************************************************************************************************
10682 SUBROUTINE mp_bcast_lv(msg, source, comm)
10683 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10684 INTEGER, INTENT(IN) :: source
10685 CLASS(mp_comm_type), INTENT(IN) :: comm
10686
10687 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lv'
10688
10689 INTEGER :: handle
10690#if defined(__parallel)
10691 INTEGER :: ierr, msglen
10692#endif
10693
10694 CALL mp_timeset(routinen, handle)
10695
10696#if defined(__parallel)
10697 msglen = SIZE(msg)
10698 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10699 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10700 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10701#else
10702 mark_used(msg)
10703 mark_used(source)
10704 mark_used(comm)
10705#endif
10706 CALL mp_timestop(handle)
10707 END SUBROUTINE mp_bcast_lv
10708
10709! **************************************************************************************************
10710!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
10711!> \param[in] msg Data to broadcast
10712!> \param comm ...
10713!> \note see mp_bcast_l1
10714! **************************************************************************************************
10715 SUBROUTINE mp_bcast_lv_src(msg, comm)
10716 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10717 CLASS(mp_comm_type), INTENT(IN) :: comm
10718
10719 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lv_src'
10720
10721 INTEGER :: handle
10722#if defined(__parallel)
10723 INTEGER :: ierr, msglen
10724#endif
10725
10726 CALL mp_timeset(routinen, handle)
10727
10728#if defined(__parallel)
10729 msglen = SIZE(msg)
10730 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10731 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10732 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10733#else
10734 mark_used(msg)
10735 mark_used(comm)
10736#endif
10737 CALL mp_timestop(handle)
10738 END SUBROUTINE mp_bcast_lv_src
10739
10740! **************************************************************************************************
10741!> \brief Broadcasts rank-1 data to all processes
10742!> \param[in] msg Data to broadcast
10743!> \param source ...
10744!> \param comm ...
10745!> \note see mp_bcast_l1
10746! **************************************************************************************************
10747 SUBROUTINE mp_ibcast_lv(msg, source, comm, request)
10748 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
10749 INTEGER, INTENT(IN) :: source
10750 CLASS(mp_comm_type), INTENT(IN) :: comm
10751 TYPE(mp_request_type) :: request
10752
10753 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_lv'
10754
10755 INTEGER :: handle
10756#if defined(__parallel)
10757 INTEGER :: ierr, msglen
10758#endif
10759
10760 CALL mp_timeset(routinen, handle)
10761
10762#if defined(__parallel)
10763#if !defined(__GNUC__) || __GNUC__ >= 9
10764 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
10765#endif
10766 msglen = SIZE(msg)
10767 CALL mpi_ibcast(msg, msglen, mpi_integer8, source, comm%handle, request%handle, ierr)
10768 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
10769 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_8_size)
10770#else
10771 mark_used(msg)
10772 mark_used(source)
10773 mark_used(comm)
10774 request = mp_request_null
10775#endif
10776 CALL mp_timestop(handle)
10777 END SUBROUTINE mp_ibcast_lv
10778
10779! **************************************************************************************************
10780!> \brief Broadcasts rank-2 data to all processes
10781!> \param[in] msg Data to broadcast
10782!> \param source ...
10783!> \param comm ...
10784!> \note see mp_bcast_l1
10785! **************************************************************************************************
10786 SUBROUTINE mp_bcast_lm(msg, source, comm)
10787 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10788 INTEGER, INTENT(IN) :: source
10789 CLASS(mp_comm_type), INTENT(IN) :: comm
10790
10791 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lm'
10792
10793 INTEGER :: handle
10794#if defined(__parallel)
10795 INTEGER :: ierr, msglen
10796#endif
10797
10798 CALL mp_timeset(routinen, handle)
10799
10800#if defined(__parallel)
10801 msglen = SIZE(msg)
10802 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10803 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10804 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10805#else
10806 mark_used(msg)
10807 mark_used(source)
10808 mark_used(comm)
10809#endif
10810 CALL mp_timestop(handle)
10811 END SUBROUTINE mp_bcast_lm
10812
10813! **************************************************************************************************
10814!> \brief Broadcasts rank-2 data to all processes
10815!> \param[in] msg Data to broadcast
10816!> \param source ...
10817!> \param comm ...
10818!> \note see mp_bcast_l1
10819! **************************************************************************************************
10820 SUBROUTINE mp_bcast_lm_src(msg, comm)
10821 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10822 CLASS(mp_comm_type), INTENT(IN) :: comm
10823
10824 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lm_src'
10825
10826 INTEGER :: handle
10827#if defined(__parallel)
10828 INTEGER :: ierr, msglen
10829#endif
10830
10831 CALL mp_timeset(routinen, handle)
10832
10833#if defined(__parallel)
10834 msglen = SIZE(msg)
10835 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10836 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10837 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10838#else
10839 mark_used(msg)
10840 mark_used(comm)
10841#endif
10842 CALL mp_timestop(handle)
10843 END SUBROUTINE mp_bcast_lm_src
10844
10845! **************************************************************************************************
10846!> \brief Broadcasts rank-3 data to all processes
10847!> \param[in] msg Data to broadcast
10848!> \param source ...
10849!> \param comm ...
10850!> \note see mp_bcast_l1
10851! **************************************************************************************************
10852 SUBROUTINE mp_bcast_l3(msg, source, comm)
10853 INTEGER(KIND=int_8), CONTIGUOUS :: msg(:, :, :)
10854 INTEGER, INTENT(IN) :: source
10855 CLASS(mp_comm_type), INTENT(IN) :: comm
10856
10857 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l3'
10858
10859 INTEGER :: handle
10860#if defined(__parallel)
10861 INTEGER :: ierr, msglen
10862#endif
10863
10864 CALL mp_timeset(routinen, handle)
10865
10866#if defined(__parallel)
10867 msglen = SIZE(msg)
10868 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10869 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10870 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10871#else
10872 mark_used(msg)
10873 mark_used(source)
10874 mark_used(comm)
10875#endif
10876 CALL mp_timestop(handle)
10877 END SUBROUTINE mp_bcast_l3
10878
10879! **************************************************************************************************
10880!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
10881!> \param[in] msg Data to broadcast
10882!> \param source ...
10883!> \param comm ...
10884!> \note see mp_bcast_l1
10885! **************************************************************************************************
10886 SUBROUTINE mp_bcast_l3_src(msg, comm)
10887 INTEGER(KIND=int_8), CONTIGUOUS :: msg(:, :, :)
10888 CLASS(mp_comm_type), INTENT(IN) :: comm
10889
10890 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l3_src'
10891
10892 INTEGER :: handle
10893#if defined(__parallel)
10894 INTEGER :: ierr, msglen
10895#endif
10896
10897 CALL mp_timeset(routinen, handle)
10898
10899#if defined(__parallel)
10900 msglen = SIZE(msg)
10901 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10902 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10903 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10904#else
10905 mark_used(msg)
10906 mark_used(comm)
10907#endif
10908 CALL mp_timestop(handle)
10909 END SUBROUTINE mp_bcast_l3_src
10910
10911! **************************************************************************************************
10912!> \brief Sums a datum from all processes with result left on all processes.
10913!> \param[in,out] msg Datum to sum (input) and result (output)
10914!> \param[in] comm Message passing environment identifier
10915!> \par MPI mapping
10916!> mpi_allreduce
10917! **************************************************************************************************
10918 SUBROUTINE mp_sum_l (msg, comm)
10919 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10920 CLASS(mp_comm_type), INTENT(IN) :: comm
10921
10922 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_l'
10923
10924 INTEGER :: handle
10925#if defined(__parallel)
10926 INTEGER :: ierr, msglen
10927 INTEGER(KIND=int_8) :: res
10928#endif
10929
10930 CALL mp_timeset(routinen, handle)
10931
10932#if defined(__parallel)
10933 msglen = 1
10934 IF (comm%num_pe > 1) THEN
10935 CALL mpi_allreduce(msg, res, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10936 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10937 msg = res
10938 END IF
10939 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10940#else
10941 mark_used(msg)
10942 mark_used(comm)
10943#endif
10944 CALL mp_timestop(handle)
10945 END SUBROUTINE mp_sum_l
10946
10947! **************************************************************************************************
10948!> \brief Element-wise sum of a rank-1 array on all processes.
10949!> \param[in,out] msg Vector to sum and result
10950!> \param comm ...
10951!> \note see mp_sum_l
10952! **************************************************************************************************
10953 SUBROUTINE mp_sum_lv(msg, comm)
10954 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10955 CLASS(mp_comm_type), INTENT(IN) :: comm
10956
10957 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lv'
10958
10959 INTEGER :: handle
10960#if defined(__parallel)
10961 INTEGER :: ierr, msglen
10962 INTEGER(KIND=int_8), ALLOCATABLE :: msgbuf(:)
10963#endif
10964
10965 CALL mp_timeset(routinen, handle)
10966
10967#if defined(__parallel)
10968 msglen = SIZE(msg)
10969 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
10970 ALLOCATE (msgbuf(msglen))
10971 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10972 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10973 msg = msgbuf
10974 END IF
10975 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10976#else
10977 mark_used(msg)
10978 mark_used(comm)
10979#endif
10980 CALL mp_timestop(handle)
10981 END SUBROUTINE mp_sum_lv
10982
10983! **************************************************************************************************
10984!> \brief Element-wise sum of a rank-1 array on all processes.
10985!> \param[in,out] msg Vector to sum and result
10986!> \param comm ...
10987!> \note see mp_sum_l
10988! **************************************************************************************************
10989 SUBROUTINE mp_isum_lv(msg, comm, request)
10990 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
10991 CLASS(mp_comm_type), INTENT(IN) :: comm
10992 TYPE(mp_request_type), INTENT(OUT) :: request
10993
10994 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_lv'
10995
10996 INTEGER :: handle
10997#if defined(__parallel)
10998 INTEGER :: ierr, msglen
10999#endif
11000
11001 CALL mp_timeset(routinen, handle)
11002
11003#if defined(__parallel)
11004#if !defined(__GNUC__) || __GNUC__ >= 9
11005 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
11006#endif
11007 msglen = SIZE(msg)
11008 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
11009 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, request%handle, ierr)
11010 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
11011 ELSE
11012 request = mp_request_null
11013 END IF
11014 CALL add_perf(perf_id=23, count=1, msg_size=msglen*int_8_size)
11015#else
11016 mark_used(msg)
11017 mark_used(comm)
11018 request = mp_request_null
11019#endif
11020 CALL mp_timestop(handle)
11021 END SUBROUTINE mp_isum_lv
11022
11023! **************************************************************************************************
11024!> \brief Element-wise sum of a rank-2 array on all processes.
11025!> \param[in] msg Matrix to sum and result
11026!> \param comm ...
11027!> \note see mp_sum_l
11028! **************************************************************************************************
11029 SUBROUTINE mp_sum_lm(msg, comm)
11030 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11031 CLASS(mp_comm_type), INTENT(IN) :: comm
11032
11033 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm'
11034
11035 INTEGER :: handle
11036#if defined(__parallel)
11037 INTEGER, PARAMETER :: max_msg = 2**25
11038 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
11039 INTEGER(KIND=int_8), ALLOCATABLE :: msgbuf(:)
11040#endif
11041
11042 CALL mp_timeset(routinen, handle)
11043
11044#if defined(__parallel)
11045 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
11046 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
11047 msglensum = 0
11048 DO m1 = lbound(msg, 2), ubound(msg, 2), step
11049 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
11050 msglensum = msglensum + msglen
11051 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
11052 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
11053 ALLOCATE (msgbuf(msglen))
11054 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11055 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11056 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
11057 DEALLOCATE (msgbuf)
11058 END IF
11059 END DO
11060 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_8_size)
11061#else
11062 mark_used(msg)
11063 mark_used(comm)
11064#endif
11065 CALL mp_timestop(handle)
11066 END SUBROUTINE mp_sum_lm
11067
11068! **************************************************************************************************
11069!> \brief Element-wise sum of a rank-3 array on all processes.
11070!> \param[in] msg Array to sum and result
11071!> \param comm ...
11072!> \note see mp_sum_l
11073! **************************************************************************************************
11074 SUBROUTINE mp_sum_lm3(msg, comm)
11075 INTEGER(KIND=int_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
11076 CLASS(mp_comm_type), INTENT(IN) :: comm
11077
11078 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm3'
11079
11080 INTEGER :: handle
11081#if defined(__parallel)
11082 INTEGER :: ierr, msglen
11083 INTEGER(KIND=int_8), ALLOCATABLE :: msgbuf(:)
11084#endif
11085
11086 CALL mp_timeset(routinen, handle)
11087
11088#if defined(__parallel)
11089 msglen = SIZE(msg)
11090 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
11091 ALLOCATE (msgbuf(msglen))
11092 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11093 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11094 msg = reshape(msgbuf, shape(msg))
11095 END IF
11096 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11097#else
11098 mark_used(msg)
11099 mark_used(comm)
11100#endif
11101 CALL mp_timestop(handle)
11102 END SUBROUTINE mp_sum_lm3
11103
11104! **************************************************************************************************
11105!> \brief Element-wise sum of a rank-4 array on all processes.
11106!> \param[in] msg Array to sum and result
11107!> \param comm ...
11108!> \note see mp_sum_l
11109! **************************************************************************************************
11110 SUBROUTINE mp_sum_lm4(msg, comm)
11111 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
11112 CLASS(mp_comm_type), INTENT(IN) :: comm
11113
11114 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm4'
11115
11116 INTEGER :: handle
11117#if defined(__parallel)
11118 INTEGER :: ierr, msglen
11119 INTEGER(KIND=int_8), ALLOCATABLE :: msgbuf(:)
11120#endif
11121
11122 CALL mp_timeset(routinen, handle)
11123
11124#if defined(__parallel)
11125 msglen = SIZE(msg)
11126 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
11127 ALLOCATE (msgbuf(msglen))
11128 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11129 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11130 msg = reshape(msgbuf, shape(msg))
11131 END IF
11132 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11133#else
11134 mark_used(msg)
11135 mark_used(comm)
11136#endif
11137 CALL mp_timestop(handle)
11138 END SUBROUTINE mp_sum_lm4
11139
11140! **************************************************************************************************
11141!> \brief Element-wise sum of data from all processes with result left only on
11142!> one.
11143!> \param[in,out] msg Vector to sum (input) and (only on process root)
11144!> result (output)
11145!> \param root ...
11146!> \param[in] comm Message passing environment identifier
11147!> \par MPI mapping
11148!> mpi_reduce
11149! **************************************************************************************************
11150 SUBROUTINE mp_sum_root_lv(msg, root, comm)
11151 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
11152 INTEGER, INTENT(IN) :: root
11153 CLASS(mp_comm_type), INTENT(IN) :: comm
11154
11155 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_lv'
11156
11157 INTEGER :: handle
11158#if defined(__parallel)
11159 INTEGER :: ierr, m1, msglen, taskid
11160 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
11161#endif
11162
11163 CALL mp_timeset(routinen, handle)
11164
11165#if defined(__parallel)
11166 msglen = SIZE(msg)
11167 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11168 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11169 IF (msglen > 0) THEN
11170 m1 = SIZE(msg, 1)
11171 ALLOCATE (res(m1))
11172 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_sum, &
11173 root, comm%handle, ierr)
11174 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11175 IF (taskid == root) THEN
11176 msg = res
11177 END IF
11178 DEALLOCATE (res)
11179 END IF
11180 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11181#else
11182 mark_used(msg)
11183 mark_used(root)
11184 mark_used(comm)
11185#endif
11186 CALL mp_timestop(handle)
11187 END SUBROUTINE mp_sum_root_lv
11188
11189! **************************************************************************************************
11190!> \brief Element-wise sum of data from all processes with result left only on
11191!> one.
11192!> \param[in,out] msg Matrix to sum (input) and (only on process root)
11193!> result (output)
11194!> \param root ...
11195!> \param comm ...
11196!> \note see mp_sum_root_lv
11197! **************************************************************************************************
11198 SUBROUTINE mp_sum_root_lm(msg, root, comm)
11199 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11200 INTEGER, INTENT(IN) :: root
11201 CLASS(mp_comm_type), INTENT(IN) :: comm
11202
11203 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
11204
11205 INTEGER :: handle
11206#if defined(__parallel)
11207 INTEGER :: ierr, m1, m2, msglen, taskid
11208 INTEGER(KIND=int_8), ALLOCATABLE :: res(:, :)
11209#endif
11210
11211 CALL mp_timeset(routinen, handle)
11212
11213#if defined(__parallel)
11214 msglen = SIZE(msg)
11215 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11216 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11217 IF (msglen > 0) THEN
11218 m1 = SIZE(msg, 1)
11219 m2 = SIZE(msg, 2)
11220 ALLOCATE (res(m1, m2))
11221 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_sum, root, comm%handle, ierr)
11222 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11223 IF (taskid == root) THEN
11224 msg = res
11225 END IF
11226 DEALLOCATE (res)
11227 END IF
11228 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11229#else
11230 mark_used(root)
11231 mark_used(msg)
11232 mark_used(comm)
11233#endif
11234 CALL mp_timestop(handle)
11235 END SUBROUTINE mp_sum_root_lm
11236
11237! **************************************************************************************************
11238!> \brief Partial sum of data from all processes with result on each process.
11239!> \param[in] msg Matrix to sum (input)
11240!> \param[out] res Matrix containing result (output)
11241!> \param[in] comm Message passing environment identifier
11242! **************************************************************************************************
11243 SUBROUTINE mp_sum_partial_lm(msg, res, comm)
11244 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11245 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
11246 CLASS(mp_comm_type), INTENT(IN) :: comm
11247
11248 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_lm'
11249
11250 INTEGER :: handle
11251#if defined(__parallel)
11252 INTEGER :: ierr, msglen, taskid
11253#endif
11254
11255 CALL mp_timeset(routinen, handle)
11256
11257#if defined(__parallel)
11258 msglen = SIZE(msg)
11259 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11260 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11261 IF (msglen > 0) THEN
11262 CALL mpi_scan(msg, res, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11263 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
11264 END IF
11265 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11266 ! perf_id is same as for other summation routines
11267#else
11268 res = msg
11269 mark_used(comm)
11270#endif
11271 CALL mp_timestop(handle)
11272 END SUBROUTINE mp_sum_partial_lm
11273
11274! **************************************************************************************************
11275!> \brief Finds the maximum of a datum with the result left on all processes.
11276!> \param[in,out] msg Find maximum among these data (input) and
11277!> maximum (output)
11278!> \param[in] comm Message passing environment identifier
11279!> \par MPI mapping
11280!> mpi_allreduce
11281! **************************************************************************************************
11282 SUBROUTINE mp_max_l (msg, comm)
11283 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11284 CLASS(mp_comm_type), INTENT(IN) :: comm
11285
11286 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_l'
11287
11288 INTEGER :: handle
11289#if defined(__parallel)
11290 INTEGER :: ierr, msglen
11291 INTEGER(KIND=int_8) :: res
11292#endif
11293
11294 CALL mp_timeset(routinen, handle)
11295
11296#if defined(__parallel)
11297 msglen = 1
11298 IF (comm%num_pe > 1) THEN
11299 CALL mpi_allreduce(msg, res, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11300 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11301 msg = res
11302 END IF
11303 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11304#else
11305 mark_used(msg)
11306 mark_used(comm)
11307#endif
11308 CALL mp_timestop(handle)
11309 END SUBROUTINE mp_max_l
11310
11311! **************************************************************************************************
11312!> \brief Finds the maximum of a datum with the result left on all processes.
11313!> \param[in,out] msg Find maximum among these data (input) and
11314!> maximum (output)
11315!> \param[in] comm Message passing environment identifier
11316!> \par MPI mapping
11317!> mpi_allreduce
11318! **************************************************************************************************
11319 SUBROUTINE mp_max_root_l (msg, root, comm)
11320 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11321 INTEGER, INTENT(IN) :: root
11322 CLASS(mp_comm_type), INTENT(IN) :: comm
11323
11324 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_l'
11325
11326 INTEGER :: handle
11327#if defined(__parallel)
11328 INTEGER :: ierr, msglen
11329 INTEGER(KIND=int_8) :: res
11330#endif
11331
11332 CALL mp_timeset(routinen, handle)
11333
11334#if defined(__parallel)
11335 msglen = 1
11336 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_max, root, comm%handle, ierr)
11337 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11338 IF (root == comm%mepos) msg = res
11339 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11340#else
11341 mark_used(msg)
11342 mark_used(comm)
11343 mark_used(root)
11344#endif
11345 CALL mp_timestop(handle)
11346 END SUBROUTINE mp_max_root_l
11347
11348! **************************************************************************************************
11349!> \brief Finds the element-wise maximum of a vector with the result left on
11350!> all processes.
11351!> \param[in,out] msg Find maximum among these data (input) and
11352!> maximum (output)
11353!> \param comm ...
11354!> \note see mp_max_l
11355! **************************************************************************************************
11356 SUBROUTINE mp_max_lv(msg, comm)
11357 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
11358 CLASS(mp_comm_type), INTENT(IN) :: comm
11359
11360 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_lv'
11361
11362 INTEGER :: handle
11363#if defined(__parallel)
11364 INTEGER :: ierr, msglen
11365 INTEGER(KIND=int_8), ALLOCATABLE :: msgbuf(:)
11366#endif
11367
11368 CALL mp_timeset(routinen, handle)
11369
11370#if defined(__parallel)
11371 msglen = SIZE(msg)
11372 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
11373 ALLOCATE (msgbuf(msglen))
11374 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11375 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11376 msg = msgbuf
11377 END IF
11378 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11379#else
11380 mark_used(msg)
11381 mark_used(comm)
11382#endif
11383 CALL mp_timestop(handle)
11384 END SUBROUTINE mp_max_lv
11385
11386! **************************************************************************************************
11387!> \brief Finds the element-wise maximum of a rank2-array with the result left on
11388!> all processes.
11389!> \param[in] msg Matrix - Find maximum among these data (input) and
11390!> maximum (output)
11391!> \param comm ...
11392!> \note see mp_max_l
11393! **************************************************************************************************
11394 SUBROUTINE mp_max_lm(msg, comm)
11395 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11396 CLASS(mp_comm_type), INTENT(IN) :: comm
11397
11398 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_lm'
11399
11400 INTEGER :: handle
11401#if defined(__parallel)
11402 INTEGER, PARAMETER :: max_msg = 2**25
11403 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
11404 INTEGER(KIND=int_8), ALLOCATABLE :: msgbuf(:)
11405#endif
11406
11407 CALL mp_timeset(routinen, handle)
11408
11409#if defined(__parallel)
11410 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
11411 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
11412 msglensum = 0
11413 DO m1 = lbound(msg, 2), ubound(msg, 2), step
11414 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
11415 msglensum = msglensum + msglen
11416 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
11417 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
11418 ALLOCATE (msgbuf(msglen))
11419 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11420 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11421 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
11422 DEALLOCATE (msgbuf)
11423 END IF
11424 END DO
11425 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_8_size)
11426#else
11427 mark_used(msg)
11428 mark_used(comm)
11429#endif
11430 CALL mp_timestop(handle)
11431 END SUBROUTINE mp_max_lm
11432
11433! **************************************************************************************************
11434!> \brief Finds the element-wise maximum of a vector with the result left on
11435!> all processes.
11436!> \param[in,out] msg Find maximum among these data (input) and
11437!> maximum (output)
11438!> \param comm ...
11439!> \note see mp_max_l
11440! **************************************************************************************************
11441 SUBROUTINE mp_max_root_lm(msg, root, comm)
11442 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11443 INTEGER :: root
11444 CLASS(mp_comm_type), INTENT(IN) :: comm
11445
11446 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_lm'
11447
11448 INTEGER :: handle
11449#if defined(__parallel)
11450 INTEGER :: ierr, msglen
11451 INTEGER(KIND=int_8) :: res(size(msg, 1), size(msg, 2))
11452#endif
11453
11454 CALL mp_timeset(routinen, handle)
11455
11456#if defined(__parallel)
11457 msglen = SIZE(msg)
11458 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_max, root, comm%handle, ierr)
11459 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11460 IF (root == comm%mepos) msg = res
11461 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11462#else
11463 mark_used(msg)
11464 mark_used(comm)
11465 mark_used(root)
11466#endif
11467 CALL mp_timestop(handle)
11468 END SUBROUTINE mp_max_root_lm
11469
11470! **************************************************************************************************
11471!> \brief Finds the minimum of a datum with the result left on all processes.
11472!> \param[in,out] msg Find minimum among these data (input) and
11473!> maximum (output)
11474!> \param[in] comm Message passing environment identifier
11475!> \par MPI mapping
11476!> mpi_allreduce
11477! **************************************************************************************************
11478 SUBROUTINE mp_min_l (msg, comm)
11479 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11480 CLASS(mp_comm_type), INTENT(IN) :: comm
11481
11482 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_l'
11483
11484 INTEGER :: handle
11485#if defined(__parallel)
11486 INTEGER :: ierr, msglen
11487 INTEGER(KIND=int_8) :: res
11488#endif
11489
11490 CALL mp_timeset(routinen, handle)
11491
11492#if defined(__parallel)
11493 msglen = 1
11494 IF (comm%num_pe > 1) THEN
11495 CALL mpi_allreduce(msg, res, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11496 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11497 msg = res
11498 END IF
11499 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11500#else
11501 mark_used(msg)
11502 mark_used(comm)
11503#endif
11504 CALL mp_timestop(handle)
11505 END SUBROUTINE mp_min_l
11506
11507! **************************************************************************************************
11508!> \brief Finds the element-wise minimum of vector with the result left on
11509!> all processes.
11510!> \param[in,out] msg Find minimum among these data (input) and
11511!> maximum (output)
11512!> \param comm ...
11513!> \par MPI mapping
11514!> mpi_allreduce
11515!> \note see mp_min_l
11516! **************************************************************************************************
11517 SUBROUTINE mp_min_lv(msg, comm)
11518 INTEGER(KIND=int_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
11519 CLASS(mp_comm_type), INTENT(IN) :: comm
11520
11521 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_lv'
11522
11523 INTEGER :: handle
11524#if defined(__parallel)
11525 INTEGER :: ierr, msglen
11526 INTEGER(KIND=int_8), ALLOCATABLE :: msgbuf(:)
11527#endif
11528
11529 CALL mp_timeset(routinen, handle)
11530
11531#if defined(__parallel)
11532 msglen = SIZE(msg)
11533 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
11534 ALLOCATE (msgbuf(msglen))
11535 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11536 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11537 msg = msgbuf
11538 END IF
11539 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11540#else
11541 mark_used(msg)
11542 mark_used(comm)
11543#endif
11544 CALL mp_timestop(handle)
11545 END SUBROUTINE mp_min_lv
11546
11547! **************************************************************************************************
11548!> \brief Finds the element-wise minimum of a rank2-array with the result left on
11549!> all processes.
11550!> \param[in] msg Matrix - Find maximum among these data (input) and
11551!> minimum (output)
11552!> \param comm ...
11553!> \note see mp_min_l
11554! **************************************************************************************************
11555 SUBROUTINE mp_min_lm(msg, comm)
11556 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11557 CLASS(mp_comm_type), INTENT(IN) :: comm
11558
11559 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_lm'
11560
11561 INTEGER :: handle
11562#if defined(__parallel)
11563 INTEGER, PARAMETER :: max_msg = 2**25
11564 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
11565 INTEGER(KIND=int_8), ALLOCATABLE :: msgbuf(:)
11566#endif
11567
11568 CALL mp_timeset(routinen, handle)
11569
11570#if defined(__parallel)
11571 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
11572 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
11573 msglensum = 0
11574 DO m1 = lbound(msg, 2), ubound(msg, 2), step
11575 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
11576 msglensum = msglensum + msglen
11577 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
11578 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
11579 ALLOCATE (msgbuf(msglen))
11580 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11581 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11582 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
11583 DEALLOCATE (msgbuf)
11584 END IF
11585 END DO
11586 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_8_size)
11587#else
11588 mark_used(msg)
11589 mark_used(comm)
11590#endif
11591 CALL mp_timestop(handle)
11592 END SUBROUTINE mp_min_lm
11593
11594! **************************************************************************************************
11595!> \brief Multiplies a set of numbers scattered across a number of processes,
11596!> then replicates the result.
11597!> \param[in,out] msg a number to multiply (input) and result (output)
11598!> \param[in] comm message passing environment identifier
11599!> \par MPI mapping
11600!> mpi_allreduce
11601! **************************************************************************************************
11602 SUBROUTINE mp_prod_l (msg, comm)
11603 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11604 CLASS(mp_comm_type), INTENT(IN) :: comm
11605
11606 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_l'
11607
11608 INTEGER :: handle
11609#if defined(__parallel)
11610 INTEGER :: ierr, msglen
11611 INTEGER(KIND=int_8) :: res
11612#endif
11613
11614 CALL mp_timeset(routinen, handle)
11615
11616#if defined(__parallel)
11617 msglen = 1
11618 IF (comm%num_pe > 1) THEN
11619 CALL mpi_allreduce(msg, res, msglen, mpi_integer8, mpi_prod, comm%handle, ierr)
11620 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11621 msg = res
11622 END IF
11623 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11624#else
11625 mark_used(msg)
11626 mark_used(comm)
11627#endif
11628 CALL mp_timestop(handle)
11629 END SUBROUTINE mp_prod_l
11630
11631! **************************************************************************************************
11632!> \brief Scatters data from one processes to all others
11633!> \param[in] msg_scatter Data to scatter (for root process)
11634!> \param[out] msg Received data
11635!> \param[in] root Process which scatters data
11636!> \param[in] comm Message passing environment identifier
11637!> \par MPI mapping
11638!> mpi_scatter
11639! **************************************************************************************************
11640 SUBROUTINE mp_scatter_lv(msg_scatter, msg, root, comm)
11641 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
11642 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
11643 INTEGER, INTENT(IN) :: root
11644 CLASS(mp_comm_type), INTENT(IN) :: comm
11645
11646 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_lv'
11647
11648 INTEGER :: handle
11649#if defined(__parallel)
11650 INTEGER :: ierr, msglen
11651#endif
11652
11653 CALL mp_timeset(routinen, handle)
11654
11655#if defined(__parallel)
11656 msglen = SIZE(msg)
11657 CALL mpi_scatter(msg_scatter, msglen, mpi_integer8, msg, &
11658 msglen, mpi_integer8, root, comm%handle, ierr)
11659 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
11660 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11661#else
11662 mark_used(root)
11663 mark_used(comm)
11664 msg = msg_scatter
11665#endif
11666 CALL mp_timestop(handle)
11667 END SUBROUTINE mp_scatter_lv
11668
11669! **************************************************************************************************
11670!> \brief Scatters data from one processes to all others
11671!> \param[in] msg_scatter Data to scatter (for root process)
11672!> \param[in] root Process which scatters data
11673!> \param[in] comm Message passing environment identifier
11674!> \par MPI mapping
11675!> mpi_scatter
11676! **************************************************************************************************
11677 SUBROUTINE mp_iscatter_l (msg_scatter, msg, root, comm, request)
11678 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:)
11679 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11680 INTEGER, INTENT(IN) :: root
11681 CLASS(mp_comm_type), INTENT(IN) :: comm
11682 TYPE(mp_request_type), INTENT(OUT) :: request
11683
11684 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_l'
11685
11686 INTEGER :: handle
11687#if defined(__parallel)
11688 INTEGER :: ierr, msglen
11689#endif
11690
11691 CALL mp_timeset(routinen, handle)
11692
11693#if defined(__parallel)
11694#if !defined(__GNUC__) || __GNUC__ >= 9
11695 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
11696#endif
11697 msglen = 1
11698 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer8, msg, &
11699 msglen, mpi_integer8, root, comm%handle, request%handle, ierr)
11700 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
11701 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11702#else
11703 mark_used(root)
11704 mark_used(comm)
11705 msg = msg_scatter(1)
11706 request = mp_request_null
11707#endif
11708 CALL mp_timestop(handle)
11709 END SUBROUTINE mp_iscatter_l
11710
11711! **************************************************************************************************
11712!> \brief Scatters data from one processes to all others
11713!> \param[in] msg_scatter Data to scatter (for root process)
11714!> \param[in] root Process which scatters data
11715!> \param[in] comm Message passing environment identifier
11716!> \par MPI mapping
11717!> mpi_scatter
11718! **************************************************************************************************
11719 SUBROUTINE mp_iscatter_lv2(msg_scatter, msg, root, comm, request)
11720 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:, :)
11721 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11722 INTEGER, INTENT(IN) :: root
11723 CLASS(mp_comm_type), INTENT(IN) :: comm
11724 TYPE(mp_request_type), INTENT(OUT) :: request
11725
11726 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_lv2'
11727
11728 INTEGER :: handle
11729#if defined(__parallel)
11730 INTEGER :: ierr, msglen
11731#endif
11732
11733 CALL mp_timeset(routinen, handle)
11734
11735#if defined(__parallel)
11736#if !defined(__GNUC__) || __GNUC__ >= 9
11737 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
11738#endif
11739 msglen = SIZE(msg)
11740 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer8, msg, &
11741 msglen, mpi_integer8, root, comm%handle, request%handle, ierr)
11742 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
11743 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11744#else
11745 mark_used(root)
11746 mark_used(comm)
11747 msg(:) = msg_scatter(:, 1)
11748 request = mp_request_null
11749#endif
11750 CALL mp_timestop(handle)
11751 END SUBROUTINE mp_iscatter_lv2
11752
11753! **************************************************************************************************
11754!> \brief Scatters data from one processes to all others
11755!> \param[in] msg_scatter Data to scatter (for root process)
11756!> \param[in] root Process which scatters data
11757!> \param[in] comm Message passing environment identifier
11758!> \par MPI mapping
11759!> mpi_scatter
11760! **************************************************************************************************
11761 SUBROUTINE mp_iscatterv_lv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
11762 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:)
11763 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
11764 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11765 INTEGER, INTENT(IN) :: recvcount, root
11766 CLASS(mp_comm_type), INTENT(IN) :: comm
11767 TYPE(mp_request_type), INTENT(OUT) :: request
11768
11769 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_lv'
11770
11771 INTEGER :: handle
11772#if defined(__parallel)
11773 INTEGER :: ierr
11774#endif
11775
11776 CALL mp_timeset(routinen, handle)
11777
11778#if defined(__parallel)
11779#if !defined(__GNUC__) || __GNUC__ >= 9
11780 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
11781 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
11782 cpassert(is_contiguous(sendcounts) .OR. SIZE(sendcounts) == 0)
11783 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
11784#endif
11785 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_integer8, msg, &
11786 recvcount, mpi_integer8, root, comm%handle, request%handle, ierr)
11787 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
11788 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11789#else
11790 mark_used(sendcounts)
11791 mark_used(displs)
11792 mark_used(recvcount)
11793 mark_used(root)
11794 mark_used(comm)
11795 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
11796 request = mp_request_null
11797#endif
11798 CALL mp_timestop(handle)
11799 END SUBROUTINE mp_iscatterv_lv
11800
11801! **************************************************************************************************
11802!> \brief Gathers a datum from all processes to one
11803!> \param[in] msg Datum to send to root
11804!> \param[out] msg_gather Received data (on root)
11805!> \param[in] root Process which gathers the data
11806!> \param[in] comm Message passing environment identifier
11807!> \par MPI mapping
11808!> mpi_gather
11809! **************************************************************************************************
11810 SUBROUTINE mp_gather_l (msg, msg_gather, root, comm)
11811 INTEGER(KIND=int_8), INTENT(IN) :: msg
11812 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11813 INTEGER, INTENT(IN) :: root
11814 CLASS(mp_comm_type), INTENT(IN) :: comm
11815
11816 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_l'
11817
11818 INTEGER :: handle
11819#if defined(__parallel)
11820 INTEGER :: ierr, msglen
11821#endif
11822
11823 CALL mp_timeset(routinen, handle)
11824
11825#if defined(__parallel)
11826 msglen = 1
11827 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11828 msglen, mpi_integer8, root, comm%handle, ierr)
11829 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11830 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11831#else
11832 mark_used(root)
11833 mark_used(comm)
11834 msg_gather(1) = msg
11835#endif
11836 CALL mp_timestop(handle)
11837 END SUBROUTINE mp_gather_l
11838
11839! **************************************************************************************************
11840!> \brief Gathers a datum from all processes to one, uses the source process of comm
11841!> \param[in] msg Datum to send to root
11842!> \param[out] msg_gather Received data (on root)
11843!> \param[in] comm Message passing environment identifier
11844!> \par MPI mapping
11845!> mpi_gather
11846! **************************************************************************************************
11847 SUBROUTINE mp_gather_l_src(msg, msg_gather, comm)
11848 INTEGER(KIND=int_8), INTENT(IN) :: msg
11849 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11850 CLASS(mp_comm_type), INTENT(IN) :: comm
11851
11852 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_l_src'
11853
11854 INTEGER :: handle
11855#if defined(__parallel)
11856 INTEGER :: ierr, msglen
11857#endif
11858
11859 CALL mp_timeset(routinen, handle)
11860
11861#if defined(__parallel)
11862 msglen = 1
11863 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11864 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11865 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11866 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11867#else
11868 mark_used(comm)
11869 msg_gather(1) = msg
11870#endif
11871 CALL mp_timestop(handle)
11872 END SUBROUTINE mp_gather_l_src
11873
11874! **************************************************************************************************
11875!> \brief Gathers data from all processes to one
11876!> \param[in] msg Datum to send to root
11877!> \param msg_gather ...
11878!> \param root ...
11879!> \param comm ...
11880!> \par Data length
11881!> All data (msg) is equal-sized
11882!> \par MPI mapping
11883!> mpi_gather
11884!> \note see mp_gather_l
11885! **************************************************************************************************
11886 SUBROUTINE mp_gather_lv(msg, msg_gather, root, comm)
11887 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
11888 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11889 INTEGER, INTENT(IN) :: root
11890 CLASS(mp_comm_type), INTENT(IN) :: comm
11891
11892 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lv'
11893
11894 INTEGER :: handle
11895#if defined(__parallel)
11896 INTEGER :: ierr, msglen
11897#endif
11898
11899 CALL mp_timeset(routinen, handle)
11900
11901#if defined(__parallel)
11902 msglen = SIZE(msg)
11903 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11904 msglen, mpi_integer8, root, comm%handle, ierr)
11905 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11906 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11907#else
11908 mark_used(root)
11909 mark_used(comm)
11910 msg_gather = msg
11911#endif
11912 CALL mp_timestop(handle)
11913 END SUBROUTINE mp_gather_lv
11914
11915! **************************************************************************************************
11916!> \brief Gathers data from all processes to one. Gathers from comm%source
11917!> \param[in] msg Datum to send to root
11918!> \param msg_gather ...
11919!> \param comm ...
11920!> \par Data length
11921!> All data (msg) is equal-sized
11922!> \par MPI mapping
11923!> mpi_gather
11924!> \note see mp_gather_l
11925! **************************************************************************************************
11926 SUBROUTINE mp_gather_lv_src(msg, msg_gather, comm)
11927 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
11928 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11929 CLASS(mp_comm_type), INTENT(IN) :: comm
11930
11931 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lv_src'
11932
11933 INTEGER :: handle
11934#if defined(__parallel)
11935 INTEGER :: ierr, msglen
11936#endif
11937
11938 CALL mp_timeset(routinen, handle)
11939
11940#if defined(__parallel)
11941 msglen = SIZE(msg)
11942 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11943 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11944 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11945 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11946#else
11947 mark_used(comm)
11948 msg_gather = msg
11949#endif
11950 CALL mp_timestop(handle)
11951 END SUBROUTINE mp_gather_lv_src
11952
11953! **************************************************************************************************
11954!> \brief Gathers data from all processes to one
11955!> \param[in] msg Datum to send to root
11956!> \param msg_gather ...
11957!> \param root ...
11958!> \param comm ...
11959!> \par Data length
11960!> All data (msg) is equal-sized
11961!> \par MPI mapping
11962!> mpi_gather
11963!> \note see mp_gather_l
11964! **************************************************************************************************
11965 SUBROUTINE mp_gather_lm(msg, msg_gather, root, comm)
11966 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11967 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
11968 INTEGER, INTENT(IN) :: root
11969 CLASS(mp_comm_type), INTENT(IN) :: comm
11970
11971 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lm'
11972
11973 INTEGER :: handle
11974#if defined(__parallel)
11975 INTEGER :: ierr, msglen
11976#endif
11977
11978 CALL mp_timeset(routinen, handle)
11979
11980#if defined(__parallel)
11981 msglen = SIZE(msg)
11982 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11983 msglen, mpi_integer8, root, comm%handle, ierr)
11984 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11985 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11986#else
11987 mark_used(root)
11988 mark_used(comm)
11989 msg_gather = msg
11990#endif
11991 CALL mp_timestop(handle)
11992 END SUBROUTINE mp_gather_lm
11993
11994! **************************************************************************************************
11995!> \brief Gathers data from all processes to one. Gathers from comm%source
11996!> \param[in] msg Datum to send to root
11997!> \param msg_gather ...
11998!> \param comm ...
11999!> \par Data length
12000!> All data (msg) is equal-sized
12001!> \par MPI mapping
12002!> mpi_gather
12003!> \note see mp_gather_l
12004! **************************************************************************************************
12005 SUBROUTINE mp_gather_lm_src(msg, msg_gather, comm)
12006 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
12007 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
12008 CLASS(mp_comm_type), INTENT(IN) :: comm
12009
12010 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lm_src'
12011
12012 INTEGER :: handle
12013#if defined(__parallel)
12014 INTEGER :: ierr, msglen
12015#endif
12016
12017 CALL mp_timeset(routinen, handle)
12018
12019#if defined(__parallel)
12020 msglen = SIZE(msg)
12021 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
12022 msglen, mpi_integer8, comm%source, comm%handle, ierr)
12023 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
12024 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
12025#else
12026 mark_used(comm)
12027 msg_gather = msg
12028#endif
12029 CALL mp_timestop(handle)
12030 END SUBROUTINE mp_gather_lm_src
12031
12032! **************************************************************************************************
12033!> \brief Gathers data from all processes to one.
12034!> \param[in] sendbuf Data to send to root
12035!> \param[out] recvbuf Received data (on root)
12036!> \param[in] recvcounts Sizes of data received from processes
12037!> \param[in] displs Offsets of data received from processes
12038!> \param[in] root Process which gathers the data
12039!> \param[in] comm Message passing environment identifier
12040!> \par Data length
12041!> Data can have different lengths
12042!> \par Offsets
12043!> Offsets start at 0
12044!> \par MPI mapping
12045!> mpi_gather
12046! **************************************************************************************************
12047 SUBROUTINE mp_gatherv_lv(sendbuf, recvbuf, recvcounts, displs, root, comm)
12048
12049 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
12050 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
12051 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12052 INTEGER, INTENT(IN) :: root
12053 CLASS(mp_comm_type), INTENT(IN) :: comm
12054
12055 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lv'
12056
12057 INTEGER :: handle
12058#if defined(__parallel)
12059 INTEGER :: ierr, sendcount
12060#endif
12061
12062 CALL mp_timeset(routinen, handle)
12063
12064#if defined(__parallel)
12065 sendcount = SIZE(sendbuf)
12066 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12067 recvbuf, recvcounts, displs, mpi_integer8, &
12068 root, comm%handle, ierr)
12069 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12070 CALL add_perf(perf_id=4, &
12071 count=1, &
12072 msg_size=sendcount*int_8_size)
12073#else
12074 mark_used(recvcounts)
12075 mark_used(root)
12076 mark_used(comm)
12077 recvbuf(1 + displs(1):) = sendbuf
12078#endif
12079 CALL mp_timestop(handle)
12080 END SUBROUTINE mp_gatherv_lv
12081
12082! **************************************************************************************************
12083!> \brief Gathers data from all processes to one. Gathers from comm%source
12084!> \param[in] sendbuf Data to send to root
12085!> \param[out] recvbuf Received data (on root)
12086!> \param[in] recvcounts Sizes of data received from processes
12087!> \param[in] displs Offsets of data received from processes
12088!> \param[in] comm Message passing environment identifier
12089!> \par Data length
12090!> Data can have different lengths
12091!> \par Offsets
12092!> Offsets start at 0
12093!> \par MPI mapping
12094!> mpi_gather
12095! **************************************************************************************************
12096 SUBROUTINE mp_gatherv_lv_src(sendbuf, recvbuf, recvcounts, displs, comm)
12097
12098 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
12099 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
12100 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12101 CLASS(mp_comm_type), INTENT(IN) :: comm
12102
12103 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lv_src'
12104
12105 INTEGER :: handle
12106#if defined(__parallel)
12107 INTEGER :: ierr, sendcount
12108#endif
12109
12110 CALL mp_timeset(routinen, handle)
12111
12112#if defined(__parallel)
12113 sendcount = SIZE(sendbuf)
12114 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12115 recvbuf, recvcounts, displs, mpi_integer8, &
12116 comm%source, comm%handle, ierr)
12117 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12118 CALL add_perf(perf_id=4, &
12119 count=1, &
12120 msg_size=sendcount*int_8_size)
12121#else
12122 mark_used(recvcounts)
12123 mark_used(comm)
12124 recvbuf(1 + displs(1):) = sendbuf
12125#endif
12126 CALL mp_timestop(handle)
12127 END SUBROUTINE mp_gatherv_lv_src
12128
12129! **************************************************************************************************
12130!> \brief Gathers data from all processes to one.
12131!> \param[in] sendbuf Data to send to root
12132!> \param[out] recvbuf Received data (on root)
12133!> \param[in] recvcounts Sizes of data received from processes
12134!> \param[in] displs Offsets of data received from processes
12135!> \param[in] root Process which gathers the data
12136!> \param[in] comm Message passing environment identifier
12137!> \par Data length
12138!> Data can have different lengths
12139!> \par Offsets
12140!> Offsets start at 0
12141!> \par MPI mapping
12142!> mpi_gather
12143! **************************************************************************************************
12144 SUBROUTINE mp_gatherv_lm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
12145
12146 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
12147 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
12148 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12149 INTEGER, INTENT(IN) :: root
12150 CLASS(mp_comm_type), INTENT(IN) :: comm
12151
12152 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lm2'
12153
12154 INTEGER :: handle
12155#if defined(__parallel)
12156 INTEGER :: ierr, sendcount
12157#endif
12158
12159 CALL mp_timeset(routinen, handle)
12160
12161#if defined(__parallel)
12162 sendcount = SIZE(sendbuf)
12163 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12164 recvbuf, recvcounts, displs, mpi_integer8, &
12165 root, comm%handle, ierr)
12166 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12167 CALL add_perf(perf_id=4, &
12168 count=1, &
12169 msg_size=sendcount*int_8_size)
12170#else
12171 mark_used(recvcounts)
12172 mark_used(root)
12173 mark_used(comm)
12174 recvbuf(:, 1 + displs(1):) = sendbuf
12175#endif
12176 CALL mp_timestop(handle)
12177 END SUBROUTINE mp_gatherv_lm2
12178
12179! **************************************************************************************************
12180!> \brief Gathers data from all processes to one.
12181!> \param[in] sendbuf Data to send to root
12182!> \param[out] recvbuf Received data (on root)
12183!> \param[in] recvcounts Sizes of data received from processes
12184!> \param[in] displs Offsets of data received from processes
12185!> \param[in] comm Message passing environment identifier
12186!> \par Data length
12187!> Data can have different lengths
12188!> \par Offsets
12189!> Offsets start at 0
12190!> \par MPI mapping
12191!> mpi_gather
12192! **************************************************************************************************
12193 SUBROUTINE mp_gatherv_lm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
12194
12195 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
12196 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
12197 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12198 CLASS(mp_comm_type), INTENT(IN) :: comm
12199
12200 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lm2_src'
12201
12202 INTEGER :: handle
12203#if defined(__parallel)
12204 INTEGER :: ierr, sendcount
12205#endif
12206
12207 CALL mp_timeset(routinen, handle)
12208
12209#if defined(__parallel)
12210 sendcount = SIZE(sendbuf)
12211 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12212 recvbuf, recvcounts, displs, mpi_integer8, &
12213 comm%source, comm%handle, ierr)
12214 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12215 CALL add_perf(perf_id=4, &
12216 count=1, &
12217 msg_size=sendcount*int_8_size)
12218#else
12219 mark_used(recvcounts)
12220 mark_used(comm)
12221 recvbuf(:, 1 + displs(1):) = sendbuf
12222#endif
12223 CALL mp_timestop(handle)
12224 END SUBROUTINE mp_gatherv_lm2_src
12225
12226! **************************************************************************************************
12227!> \brief Gathers data from all processes to one.
12228!> \param[in] sendbuf Data to send to root
12229!> \param[out] recvbuf Received data (on root)
12230!> \param[in] recvcounts Sizes of data received from processes
12231!> \param[in] displs Offsets of data received from processes
12232!> \param[in] root Process which gathers the data
12233!> \param[in] comm Message passing environment identifier
12234!> \par Data length
12235!> Data can have different lengths
12236!> \par Offsets
12237!> Offsets start at 0
12238!> \par MPI mapping
12239!> mpi_gather
12240! **************************************************************************************************
12241 SUBROUTINE mp_igatherv_lv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
12242 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: sendbuf
12243 INTEGER(KIND=int_8), DIMENSION(:), INTENT(OUT) :: recvbuf
12244 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12245 INTEGER, INTENT(IN) :: sendcount, root
12246 CLASS(mp_comm_type), INTENT(IN) :: comm
12247 TYPE(mp_request_type), INTENT(OUT) :: request
12248
12249 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_lv'
12250
12251 INTEGER :: handle
12252#if defined(__parallel)
12253 INTEGER :: ierr
12254#endif
12255
12256 CALL mp_timeset(routinen, handle)
12257
12258#if defined(__parallel)
12259#if !defined(__GNUC__) || __GNUC__ >= 9
12260 cpassert(is_contiguous(sendbuf) .OR. SIZE(sendbuf) == 0)
12261 cpassert(is_contiguous(recvbuf) .OR. SIZE(recvbuf) == 0)
12262 cpassert(is_contiguous(recvcounts) .OR. SIZE(recvcounts) == 0)
12263 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
12264#endif
12265 CALL mpi_igatherv(sendbuf, sendcount, mpi_integer8, &
12266 recvbuf, recvcounts, displs, mpi_integer8, &
12267 root, comm%handle, request%handle, ierr)
12268 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12269 CALL add_perf(perf_id=24, &
12270 count=1, &
12271 msg_size=sendcount*int_8_size)
12272#else
12273 mark_used(sendcount)
12274 mark_used(recvcounts)
12275 mark_used(root)
12276 mark_used(comm)
12277 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
12278 request = mp_request_null
12279#endif
12280 CALL mp_timestop(handle)
12281 END SUBROUTINE mp_igatherv_lv
12282
12283! **************************************************************************************************
12284!> \brief Gathers a datum from all processes and all processes receive the
12285!> same data
12286!> \param[in] msgout Datum to send
12287!> \param[out] msgin Received data
12288!> \param[in] comm Message passing environment identifier
12289!> \par Data size
12290!> All processes send equal-sized data
12291!> \par MPI mapping
12292!> mpi_allgather
12293! **************************************************************************************************
12294 SUBROUTINE mp_allgather_l (msgout, msgin, comm)
12295 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12296 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
12297 CLASS(mp_comm_type), INTENT(IN) :: comm
12298
12299 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l'
12300
12301 INTEGER :: handle
12302#if defined(__parallel)
12303 INTEGER :: ierr, rcount, scount
12304#endif
12305
12306 CALL mp_timeset(routinen, handle)
12307
12308#if defined(__parallel)
12309 scount = 1
12310 rcount = 1
12311 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12312 msgin, rcount, mpi_integer8, &
12313 comm%handle, ierr)
12314 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12315#else
12316 mark_used(comm)
12317 msgin = msgout
12318#endif
12319 CALL mp_timestop(handle)
12320 END SUBROUTINE mp_allgather_l
12321
12322! **************************************************************************************************
12323!> \brief Gathers a datum from all processes and all processes receive the
12324!> same data
12325!> \param[in] msgout Datum to send
12326!> \param[out] msgin Received data
12327!> \param[in] comm Message passing environment identifier
12328!> \par Data size
12329!> All processes send equal-sized data
12330!> \par MPI mapping
12331!> mpi_allgather
12332! **************************************************************************************************
12333 SUBROUTINE mp_allgather_l2(msgout, msgin, comm)
12334 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12335 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12336 CLASS(mp_comm_type), INTENT(IN) :: comm
12337
12338 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l2'
12339
12340 INTEGER :: handle
12341#if defined(__parallel)
12342 INTEGER :: ierr, rcount, scount
12343#endif
12344
12345 CALL mp_timeset(routinen, handle)
12346
12347#if defined(__parallel)
12348 scount = 1
12349 rcount = 1
12350 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12351 msgin, rcount, mpi_integer8, &
12352 comm%handle, ierr)
12353 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12354#else
12355 mark_used(comm)
12356 msgin = msgout
12357#endif
12358 CALL mp_timestop(handle)
12359 END SUBROUTINE mp_allgather_l2
12360
12361! **************************************************************************************************
12362!> \brief Gathers a datum from all processes and all processes receive the
12363!> same data
12364!> \param[in] msgout Datum to send
12365!> \param[out] msgin Received data
12366!> \param[in] comm Message passing environment identifier
12367!> \par Data size
12368!> All processes send equal-sized data
12369!> \par MPI mapping
12370!> mpi_allgather
12371! **************************************************************************************************
12372 SUBROUTINE mp_iallgather_l (msgout, msgin, comm, request)
12373 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12374 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12375 CLASS(mp_comm_type), INTENT(IN) :: comm
12376 TYPE(mp_request_type), INTENT(OUT) :: request
12377
12378 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l'
12379
12380 INTEGER :: handle
12381#if defined(__parallel)
12382 INTEGER :: ierr, rcount, scount
12383#endif
12384
12385 CALL mp_timeset(routinen, handle)
12386
12387#if defined(__parallel)
12388#if !defined(__GNUC__) || __GNUC__ >= 9
12389 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
12390#endif
12391 scount = 1
12392 rcount = 1
12393 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12394 msgin, rcount, mpi_integer8, &
12395 comm%handle, request%handle, ierr)
12396 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12397#else
12398 mark_used(comm)
12399 msgin = msgout
12400 request = mp_request_null
12401#endif
12402 CALL mp_timestop(handle)
12403 END SUBROUTINE mp_iallgather_l
12404
12405! **************************************************************************************************
12406!> \brief Gathers vector data from all processes and all processes receive the
12407!> same data
12408!> \param[in] msgout Rank-1 data to send
12409!> \param[out] msgin Received data
12410!> \param[in] comm Message passing environment identifier
12411!> \par Data size
12412!> All processes send equal-sized data
12413!> \par Ranks
12414!> The last rank counts the processes
12415!> \par MPI mapping
12416!> mpi_allgather
12417! **************************************************************************************************
12418 SUBROUTINE mp_allgather_l12(msgout, msgin, comm)
12419 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:)
12420 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12421 CLASS(mp_comm_type), INTENT(IN) :: comm
12422
12423 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l12'
12424
12425 INTEGER :: handle
12426#if defined(__parallel)
12427 INTEGER :: ierr, rcount, scount
12428#endif
12429
12430 CALL mp_timeset(routinen, handle)
12431
12432#if defined(__parallel)
12433 scount = SIZE(msgout(:))
12434 rcount = scount
12435 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12436 msgin, rcount, mpi_integer8, &
12437 comm%handle, ierr)
12438 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12439#else
12440 mark_used(comm)
12441 msgin(:, 1) = msgout(:)
12442#endif
12443 CALL mp_timestop(handle)
12444 END SUBROUTINE mp_allgather_l12
12445
12446! **************************************************************************************************
12447!> \brief Gathers matrix data from all processes and all processes receive the
12448!> same data
12449!> \param[in] msgout Rank-2 data to send
12450!> \param msgin ...
12451!> \param comm ...
12452!> \note see mp_allgather_l12
12453! **************************************************************************************************
12454 SUBROUTINE mp_allgather_l23(msgout, msgin, comm)
12455 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
12456 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
12457 CLASS(mp_comm_type), INTENT(IN) :: comm
12458
12459 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l23'
12460
12461 INTEGER :: handle
12462#if defined(__parallel)
12463 INTEGER :: ierr, rcount, scount
12464#endif
12465
12466 CALL mp_timeset(routinen, handle)
12467
12468#if defined(__parallel)
12469 scount = SIZE(msgout(:, :))
12470 rcount = scount
12471 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12472 msgin, rcount, mpi_integer8, &
12473 comm%handle, ierr)
12474 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12475#else
12476 mark_used(comm)
12477 msgin(:, :, 1) = msgout(:, :)
12478#endif
12479 CALL mp_timestop(handle)
12480 END SUBROUTINE mp_allgather_l23
12481
12482! **************************************************************************************************
12483!> \brief Gathers rank-3 data from all processes and all processes receive the
12484!> same data
12485!> \param[in] msgout Rank-3 data to send
12486!> \param msgin ...
12487!> \param comm ...
12488!> \note see mp_allgather_l12
12489! **************************************************************************************************
12490 SUBROUTINE mp_allgather_l34(msgout, msgin, comm)
12491 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
12492 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
12493 CLASS(mp_comm_type), INTENT(IN) :: comm
12494
12495 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l34'
12496
12497 INTEGER :: handle
12498#if defined(__parallel)
12499 INTEGER :: ierr, rcount, scount
12500#endif
12501
12502 CALL mp_timeset(routinen, handle)
12503
12504#if defined(__parallel)
12505 scount = SIZE(msgout(:, :, :))
12506 rcount = scount
12507 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12508 msgin, rcount, mpi_integer8, &
12509 comm%handle, ierr)
12510 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12511#else
12512 mark_used(comm)
12513 msgin(:, :, :, 1) = msgout(:, :, :)
12514#endif
12515 CALL mp_timestop(handle)
12516 END SUBROUTINE mp_allgather_l34
12517
12518! **************************************************************************************************
12519!> \brief Gathers rank-2 data from all processes and all processes receive the
12520!> same data
12521!> \param[in] msgout Rank-2 data to send
12522!> \param msgin ...
12523!> \param comm ...
12524!> \note see mp_allgather_l12
12525! **************************************************************************************************
12526 SUBROUTINE mp_allgather_l22(msgout, msgin, comm)
12527 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
12528 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12529 CLASS(mp_comm_type), INTENT(IN) :: comm
12530
12531 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l22'
12532
12533 INTEGER :: handle
12534#if defined(__parallel)
12535 INTEGER :: ierr, rcount, scount
12536#endif
12537
12538 CALL mp_timeset(routinen, handle)
12539
12540#if defined(__parallel)
12541 scount = SIZE(msgout(:, :))
12542 rcount = scount
12543 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12544 msgin, rcount, mpi_integer8, &
12545 comm%handle, ierr)
12546 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12547#else
12548 mark_used(comm)
12549 msgin(:, :) = msgout(:, :)
12550#endif
12551 CALL mp_timestop(handle)
12552 END SUBROUTINE mp_allgather_l22
12553
12554! **************************************************************************************************
12555!> \brief Gathers rank-1 data from all processes and all processes receive the
12556!> same data
12557!> \param[in] msgout Rank-1 data to send
12558!> \param msgin ...
12559!> \param comm ...
12560!> \param request ...
12561!> \note see mp_allgather_l11
12562! **************************************************************************************************
12563 SUBROUTINE mp_iallgather_l11(msgout, msgin, comm, request)
12564 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12565 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12566 CLASS(mp_comm_type), INTENT(IN) :: comm
12567 TYPE(mp_request_type), INTENT(OUT) :: request
12568
12569 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l11'
12570
12571 INTEGER :: handle
12572#if defined(__parallel)
12573 INTEGER :: ierr, rcount, scount
12574#endif
12575
12576 CALL mp_timeset(routinen, handle)
12577
12578#if defined(__parallel)
12579#if !defined(__GNUC__) || __GNUC__ >= 9
12580 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
12581 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
12582#endif
12583 scount = SIZE(msgout(:))
12584 rcount = scount
12585 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12586 msgin, rcount, mpi_integer8, &
12587 comm%handle, request%handle, ierr)
12588 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12589#else
12590 mark_used(comm)
12591 msgin = msgout
12592 request = mp_request_null
12593#endif
12594 CALL mp_timestop(handle)
12595 END SUBROUTINE mp_iallgather_l11
12596
12597! **************************************************************************************************
12598!> \brief Gathers rank-2 data from all processes and all processes receive the
12599!> same data
12600!> \param[in] msgout Rank-2 data to send
12601!> \param msgin ...
12602!> \param comm ...
12603!> \param request ...
12604!> \note see mp_allgather_l12
12605! **************************************************************************************************
12606 SUBROUTINE mp_iallgather_l13(msgout, msgin, comm, request)
12607 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12608 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :)
12609 CLASS(mp_comm_type), INTENT(IN) :: comm
12610 TYPE(mp_request_type), INTENT(OUT) :: request
12611
12612 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l13'
12613
12614 INTEGER :: handle
12615#if defined(__parallel)
12616 INTEGER :: ierr, rcount, scount
12617#endif
12618
12619 CALL mp_timeset(routinen, handle)
12620
12621#if defined(__parallel)
12622#if !defined(__GNUC__) || __GNUC__ >= 9
12623 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
12624 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
12625#endif
12626
12627 scount = SIZE(msgout(:))
12628 rcount = scount
12629 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12630 msgin, rcount, mpi_integer8, &
12631 comm%handle, request%handle, ierr)
12632 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12633#else
12634 mark_used(comm)
12635 msgin(:, 1, 1) = msgout(:)
12636 request = mp_request_null
12637#endif
12638 CALL mp_timestop(handle)
12639 END SUBROUTINE mp_iallgather_l13
12640
12641! **************************************************************************************************
12642!> \brief Gathers rank-2 data from all processes and all processes receive the
12643!> same data
12644!> \param[in] msgout Rank-2 data to send
12645!> \param msgin ...
12646!> \param comm ...
12647!> \param request ...
12648!> \note see mp_allgather_l12
12649! **************************************************************************************************
12650 SUBROUTINE mp_iallgather_l22(msgout, msgin, comm, request)
12651 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :)
12652 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :)
12653 CLASS(mp_comm_type), INTENT(IN) :: comm
12654 TYPE(mp_request_type), INTENT(OUT) :: request
12655
12656 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l22'
12657
12658 INTEGER :: handle
12659#if defined(__parallel)
12660 INTEGER :: ierr, rcount, scount
12661#endif
12662
12663 CALL mp_timeset(routinen, handle)
12664
12665#if defined(__parallel)
12666#if !defined(__GNUC__) || __GNUC__ >= 9
12667 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
12668 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
12669#endif
12670
12671 scount = SIZE(msgout(:, :))
12672 rcount = scount
12673 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12674 msgin, rcount, mpi_integer8, &
12675 comm%handle, request%handle, ierr)
12676 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12677#else
12678 mark_used(comm)
12679 msgin(:, :) = msgout(:, :)
12680 request = mp_request_null
12681#endif
12682 CALL mp_timestop(handle)
12683 END SUBROUTINE mp_iallgather_l22
12684
12685! **************************************************************************************************
12686!> \brief Gathers rank-2 data from all processes and all processes receive the
12687!> same data
12688!> \param[in] msgout Rank-2 data to send
12689!> \param msgin ...
12690!> \param comm ...
12691!> \param request ...
12692!> \note see mp_allgather_l12
12693! **************************************************************************************************
12694 SUBROUTINE mp_iallgather_l24(msgout, msgin, comm, request)
12695 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :)
12696 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :, :)
12697 CLASS(mp_comm_type), INTENT(IN) :: comm
12698 TYPE(mp_request_type), INTENT(OUT) :: request
12699
12700 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l24'
12701
12702 INTEGER :: handle
12703#if defined(__parallel)
12704 INTEGER :: ierr, rcount, scount
12705#endif
12706
12707 CALL mp_timeset(routinen, handle)
12708
12709#if defined(__parallel)
12710#if !defined(__GNUC__) || __GNUC__ >= 9
12711 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
12712 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
12713#endif
12714
12715 scount = SIZE(msgout(:, :))
12716 rcount = scount
12717 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12718 msgin, rcount, mpi_integer8, &
12719 comm%handle, request%handle, ierr)
12720 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12721#else
12722 mark_used(comm)
12723 msgin(:, :, 1, 1) = msgout(:, :)
12724 request = mp_request_null
12725#endif
12726 CALL mp_timestop(handle)
12727 END SUBROUTINE mp_iallgather_l24
12728
12729! **************************************************************************************************
12730!> \brief Gathers rank-3 data from all processes and all processes receive the
12731!> same data
12732!> \param[in] msgout Rank-3 data to send
12733!> \param msgin ...
12734!> \param comm ...
12735!> \param request ...
12736!> \note see mp_allgather_l12
12737! **************************************************************************************************
12738 SUBROUTINE mp_iallgather_l33(msgout, msgin, comm, request)
12739 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :, :)
12740 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :)
12741 CLASS(mp_comm_type), INTENT(IN) :: comm
12742 TYPE(mp_request_type), INTENT(OUT) :: request
12743
12744 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l33'
12745
12746 INTEGER :: handle
12747#if defined(__parallel)
12748 INTEGER :: ierr, rcount, scount
12749#endif
12750
12751 CALL mp_timeset(routinen, handle)
12752
12753#if defined(__parallel)
12754#if !defined(__GNUC__) || __GNUC__ >= 9
12755 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
12756 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
12757#endif
12758
12759 scount = SIZE(msgout(:, :, :))
12760 rcount = scount
12761 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12762 msgin, rcount, mpi_integer8, &
12763 comm%handle, request%handle, ierr)
12764 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12765#else
12766 mark_used(comm)
12767 msgin(:, :, :) = msgout(:, :, :)
12768 request = mp_request_null
12769#endif
12770 CALL mp_timestop(handle)
12771 END SUBROUTINE mp_iallgather_l33
12772
12773! **************************************************************************************************
12774!> \brief Gathers vector data from all processes and all processes receive the
12775!> same data
12776!> \param[in] msgout Rank-1 data to send
12777!> \param[out] msgin Received data
12778!> \param[in] rcount Size of sent data for every process
12779!> \param[in] rdispl Offset of sent data for every process
12780!> \param[in] comm Message passing environment identifier
12781!> \par Data size
12782!> Processes can send different-sized data
12783!> \par Ranks
12784!> The last rank counts the processes
12785!> \par Offsets
12786!> Offsets are from 0
12787!> \par MPI mapping
12788!> mpi_allgather
12789! **************************************************************************************************
12790 SUBROUTINE mp_allgatherv_lv(msgout, msgin, rcount, rdispl, comm)
12791 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
12792 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12793 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12794 CLASS(mp_comm_type), INTENT(IN) :: comm
12795
12796 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_lv'
12797
12798 INTEGER :: handle
12799#if defined(__parallel)
12800 INTEGER :: ierr, scount
12801#endif
12802
12803 CALL mp_timeset(routinen, handle)
12804
12805#if defined(__parallel)
12806 scount = SIZE(msgout)
12807 CALL mpi_allgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12808 rdispl, mpi_integer8, comm%handle, ierr)
12809 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
12810#else
12811 mark_used(rcount)
12812 mark_used(rdispl)
12813 mark_used(comm)
12814 msgin = msgout
12815#endif
12816 CALL mp_timestop(handle)
12817 END SUBROUTINE mp_allgatherv_lv
12818
12819! **************************************************************************************************
12820!> \brief Gathers vector data from all processes and all processes receive the
12821!> same data
12822!> \param[in] msgout Rank-1 data to send
12823!> \param[out] msgin Received data
12824!> \param[in] rcount Size of sent data for every process
12825!> \param[in] rdispl Offset of sent data for every process
12826!> \param[in] comm Message passing environment identifier
12827!> \par Data size
12828!> Processes can send different-sized data
12829!> \par Ranks
12830!> The last rank counts the processes
12831!> \par Offsets
12832!> Offsets are from 0
12833!> \par MPI mapping
12834!> mpi_allgather
12835! **************************************************************************************************
12836 SUBROUTINE mp_allgatherv_lm2(msgout, msgin, rcount, rdispl, comm)
12837 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
12838 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
12839 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12840 CLASS(mp_comm_type), INTENT(IN) :: comm
12841
12842 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_lv'
12843
12844 INTEGER :: handle
12845#if defined(__parallel)
12846 INTEGER :: ierr, scount
12847#endif
12848
12849 CALL mp_timeset(routinen, handle)
12850
12851#if defined(__parallel)
12852 scount = SIZE(msgout)
12853 CALL mpi_allgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12854 rdispl, mpi_integer8, comm%handle, ierr)
12855 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
12856#else
12857 mark_used(rcount)
12858 mark_used(rdispl)
12859 mark_used(comm)
12860 msgin = msgout
12861#endif
12862 CALL mp_timestop(handle)
12863 END SUBROUTINE mp_allgatherv_lm2
12864
12865! **************************************************************************************************
12866!> \brief Gathers vector data from all processes and all processes receive the
12867!> same data
12868!> \param[in] msgout Rank-1 data to send
12869!> \param[out] msgin Received data
12870!> \param[in] rcount Size of sent data for every process
12871!> \param[in] rdispl Offset of sent data for every process
12872!> \param[in] comm Message passing environment identifier
12873!> \par Data size
12874!> Processes can send different-sized data
12875!> \par Ranks
12876!> The last rank counts the processes
12877!> \par Offsets
12878!> Offsets are from 0
12879!> \par MPI mapping
12880!> mpi_allgather
12881! **************************************************************************************************
12882 SUBROUTINE mp_iallgatherv_lv(msgout, msgin, rcount, rdispl, comm, request)
12883 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12884 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12885 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12886 CLASS(mp_comm_type), INTENT(IN) :: comm
12887 TYPE(mp_request_type), INTENT(OUT) :: request
12888
12889 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_lv'
12890
12891 INTEGER :: handle
12892#if defined(__parallel)
12893 INTEGER :: ierr, scount, rsize
12894#endif
12895
12896 CALL mp_timeset(routinen, handle)
12897
12898#if defined(__parallel)
12899#if !defined(__GNUC__) || __GNUC__ >= 9
12900 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
12901 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
12902 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
12903 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
12904#endif
12905
12906 scount = SIZE(msgout)
12907 rsize = SIZE(rcount)
12908 CALL mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, &
12909 rdispl, comm, request, ierr)
12910 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
12911#else
12912 mark_used(rcount)
12913 mark_used(rdispl)
12914 mark_used(comm)
12915 msgin = msgout
12916 request = mp_request_null
12917#endif
12918 CALL mp_timestop(handle)
12919 END SUBROUTINE mp_iallgatherv_lv
12920
12921! **************************************************************************************************
12922!> \brief Gathers vector data from all processes and all processes receive the
12923!> same data
12924!> \param[in] msgout Rank-1 data to send
12925!> \param[out] msgin Received data
12926!> \param[in] rcount Size of sent data for every process
12927!> \param[in] rdispl Offset of sent data for every process
12928!> \param[in] comm Message passing environment identifier
12929!> \par Data size
12930!> Processes can send different-sized data
12931!> \par Ranks
12932!> The last rank counts the processes
12933!> \par Offsets
12934!> Offsets are from 0
12935!> \par MPI mapping
12936!> mpi_allgather
12937! **************************************************************************************************
12938 SUBROUTINE mp_iallgatherv_lv2(msgout, msgin, rcount, rdispl, comm, request)
12939 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12940 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12941 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
12942 CLASS(mp_comm_type), INTENT(IN) :: comm
12943 TYPE(mp_request_type), INTENT(OUT) :: request
12944
12945 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_lv2'
12946
12947 INTEGER :: handle
12948#if defined(__parallel)
12949 INTEGER :: ierr, scount, rsize
12950#endif
12951
12952 CALL mp_timeset(routinen, handle)
12953
12954#if defined(__parallel)
12955#if !defined(__GNUC__) || __GNUC__ >= 9
12956 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
12957 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
12958 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
12959 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
12960#endif
12961
12962 scount = SIZE(msgout)
12963 rsize = SIZE(rcount)
12964 CALL mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, &
12965 rdispl, comm, request, ierr)
12966 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
12967#else
12968 mark_used(rcount)
12969 mark_used(rdispl)
12970 mark_used(comm)
12971 msgin = msgout
12972 request = mp_request_null
12973#endif
12974 CALL mp_timestop(handle)
12975 END SUBROUTINE mp_iallgatherv_lv2
12976
12977! **************************************************************************************************
12978!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
12979!> the issue is with the rank of rcount and rdispl
12980!> \param count ...
12981!> \param array_of_requests ...
12982!> \param array_of_statuses ...
12983!> \param ierr ...
12984!> \author Alfio Lazzaro
12985! **************************************************************************************************
12986#if defined(__parallel)
12987 SUBROUTINE mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
12988 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
12989 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12990 INTEGER, INTENT(IN) :: rsize
12991 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
12992 CLASS(mp_comm_type), INTENT(IN) :: comm
12993 TYPE(mp_request_type), INTENT(OUT) :: request
12994 INTEGER, INTENT(INOUT) :: ierr
12995
12996 CALL mpi_iallgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12997 rdispl, mpi_integer8, comm%handle, request%handle, ierr)
12998
12999 END SUBROUTINE mp_iallgatherv_lv_internal
13000#endif
13001
13002! **************************************************************************************************
13003!> \brief Sums a vector and partitions the result among processes
13004!> \param[in] msgout Data to sum
13005!> \param[out] msgin Received portion of summed data
13006!> \param[in] rcount Partition sizes of the summed data for
13007!> every process
13008!> \param[in] comm Message passing environment identifier
13009! **************************************************************************************************
13010 SUBROUTINE mp_sum_scatter_lv(msgout, msgin, rcount, comm)
13011 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
13012 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
13013 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
13014 CLASS(mp_comm_type), INTENT(IN) :: comm
13015
13016 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_lv'
13017
13018 INTEGER :: handle
13019#if defined(__parallel)
13020 INTEGER :: ierr
13021#endif
13022
13023 CALL mp_timeset(routinen, handle)
13024
13025#if defined(__parallel)
13026 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_integer8, mpi_sum, &
13027 comm%handle, ierr)
13028 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
13029
13030 CALL add_perf(perf_id=3, count=1, &
13031 msg_size=rcount(1)*2*int_8_size)
13032#else
13033 mark_used(rcount)
13034 mark_used(comm)
13035 msgin = msgout(:, 1)
13036#endif
13037 CALL mp_timestop(handle)
13038 END SUBROUTINE mp_sum_scatter_lv
13039
13040! **************************************************************************************************
13041!> \brief Sends and receives vector data
13042!> \param[in] msgin Data to send
13043!> \param[in] dest Process to send data to
13044!> \param[out] msgout Received data
13045!> \param[in] source Process from which to receive
13046!> \param[in] comm Message passing environment identifier
13047!> \param[in] tag Send and recv tag (default: 0)
13048! **************************************************************************************************
13049 SUBROUTINE mp_sendrecv_l (msgin, dest, msgout, source, comm, tag)
13050 INTEGER(KIND=int_8), INTENT(IN) :: msgin
13051 INTEGER, INTENT(IN) :: dest
13052 INTEGER(KIND=int_8), INTENT(OUT) :: msgout
13053 INTEGER, INTENT(IN) :: source
13054 CLASS(mp_comm_type), INTENT(IN) :: comm
13055 INTEGER, INTENT(IN), OPTIONAL :: tag
13056
13057 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_l'
13058
13059 INTEGER :: handle
13060#if defined(__parallel)
13061 INTEGER :: ierr, msglen_in, msglen_out, &
13062 recv_tag, send_tag
13063#endif
13064
13065 CALL mp_timeset(routinen, handle)
13066
13067#if defined(__parallel)
13068 msglen_in = 1
13069 msglen_out = 1
13070 send_tag = 0 ! cannot think of something better here, this might be dangerous
13071 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13072 IF (PRESENT(tag)) THEN
13073 send_tag = tag
13074 recv_tag = tag
13075 END IF
13076 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13077 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13078 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13079 CALL add_perf(perf_id=7, count=1, &
13080 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13081#else
13082 mark_used(dest)
13083 mark_used(source)
13084 mark_used(comm)
13085 mark_used(tag)
13086 msgout = msgin
13087#endif
13088 CALL mp_timestop(handle)
13089 END SUBROUTINE mp_sendrecv_l
13090
13091! **************************************************************************************************
13092!> \brief Sends and receives vector data
13093!> \param[in] msgin Data to send
13094!> \param[in] dest Process to send data to
13095!> \param[out] msgout Received data
13096!> \param[in] source Process from which to receive
13097!> \param[in] comm Message passing environment identifier
13098!> \param[in] tag Send and recv tag (default: 0)
13099! **************************************************************************************************
13100 SUBROUTINE mp_sendrecv_lv(msgin, dest, msgout, source, comm, tag)
13101 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
13102 INTEGER, INTENT(IN) :: dest
13103 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
13104 INTEGER, INTENT(IN) :: source
13105 CLASS(mp_comm_type), INTENT(IN) :: comm
13106 INTEGER, INTENT(IN), OPTIONAL :: tag
13107
13108 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lv'
13109
13110 INTEGER :: handle
13111#if defined(__parallel)
13112 INTEGER :: ierr, msglen_in, msglen_out, &
13113 recv_tag, send_tag
13114#endif
13115
13116 CALL mp_timeset(routinen, handle)
13117
13118#if defined(__parallel)
13119 msglen_in = SIZE(msgin)
13120 msglen_out = SIZE(msgout)
13121 send_tag = 0 ! cannot think of something better here, this might be dangerous
13122 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13123 IF (PRESENT(tag)) THEN
13124 send_tag = tag
13125 recv_tag = tag
13126 END IF
13127 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13128 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13129 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13130 CALL add_perf(perf_id=7, count=1, &
13131 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13132#else
13133 mark_used(dest)
13134 mark_used(source)
13135 mark_used(comm)
13136 mark_used(tag)
13137 msgout = msgin
13138#endif
13139 CALL mp_timestop(handle)
13140 END SUBROUTINE mp_sendrecv_lv
13141
13142! **************************************************************************************************
13143!> \brief Sends and receives matrix data
13144!> \param msgin ...
13145!> \param dest ...
13146!> \param msgout ...
13147!> \param source ...
13148!> \param comm ...
13149!> \param tag ...
13150!> \note see mp_sendrecv_lv
13151! **************************************************************************************************
13152 SUBROUTINE mp_sendrecv_lm2(msgin, dest, msgout, source, comm, tag)
13153 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
13154 INTEGER, INTENT(IN) :: dest
13155 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
13156 INTEGER, INTENT(IN) :: source
13157 CLASS(mp_comm_type), INTENT(IN) :: comm
13158 INTEGER, INTENT(IN), OPTIONAL :: tag
13159
13160 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm2'
13161
13162 INTEGER :: handle
13163#if defined(__parallel)
13164 INTEGER :: ierr, msglen_in, msglen_out, &
13165 recv_tag, send_tag
13166#endif
13167
13168 CALL mp_timeset(routinen, handle)
13169
13170#if defined(__parallel)
13171 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
13172 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
13173 send_tag = 0 ! cannot think of something better here, this might be dangerous
13174 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13175 IF (PRESENT(tag)) THEN
13176 send_tag = tag
13177 recv_tag = tag
13178 END IF
13179 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13180 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13181 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13182 CALL add_perf(perf_id=7, count=1, &
13183 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13184#else
13185 mark_used(dest)
13186 mark_used(source)
13187 mark_used(comm)
13188 mark_used(tag)
13189 msgout = msgin
13190#endif
13191 CALL mp_timestop(handle)
13192 END SUBROUTINE mp_sendrecv_lm2
13193
13194! **************************************************************************************************
13195!> \brief Sends and receives rank-3 data
13196!> \param msgin ...
13197!> \param dest ...
13198!> \param msgout ...
13199!> \param source ...
13200!> \param comm ...
13201!> \note see mp_sendrecv_lv
13202! **************************************************************************************************
13203 SUBROUTINE mp_sendrecv_lm3(msgin, dest, msgout, source, comm, tag)
13204 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
13205 INTEGER, INTENT(IN) :: dest
13206 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
13207 INTEGER, INTENT(IN) :: source
13208 CLASS(mp_comm_type), INTENT(IN) :: comm
13209 INTEGER, INTENT(IN), OPTIONAL :: tag
13210
13211 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm3'
13212
13213 INTEGER :: handle
13214#if defined(__parallel)
13215 INTEGER :: ierr, msglen_in, msglen_out, &
13216 recv_tag, send_tag
13217#endif
13218
13219 CALL mp_timeset(routinen, handle)
13220
13221#if defined(__parallel)
13222 msglen_in = SIZE(msgin)
13223 msglen_out = SIZE(msgout)
13224 send_tag = 0 ! cannot think of something better here, this might be dangerous
13225 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13226 IF (PRESENT(tag)) THEN
13227 send_tag = tag
13228 recv_tag = tag
13229 END IF
13230 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13231 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13232 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13233 CALL add_perf(perf_id=7, count=1, &
13234 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13235#else
13236 mark_used(dest)
13237 mark_used(source)
13238 mark_used(comm)
13239 mark_used(tag)
13240 msgout = msgin
13241#endif
13242 CALL mp_timestop(handle)
13243 END SUBROUTINE mp_sendrecv_lm3
13244
13245! **************************************************************************************************
13246!> \brief Sends and receives rank-4 data
13247!> \param msgin ...
13248!> \param dest ...
13249!> \param msgout ...
13250!> \param source ...
13251!> \param comm ...
13252!> \note see mp_sendrecv_lv
13253! **************************************************************************************************
13254 SUBROUTINE mp_sendrecv_lm4(msgin, dest, msgout, source, comm, tag)
13255 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
13256 INTEGER, INTENT(IN) :: dest
13257 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
13258 INTEGER, INTENT(IN) :: source
13259 CLASS(mp_comm_type), INTENT(IN) :: comm
13260 INTEGER, INTENT(IN), OPTIONAL :: tag
13261
13262 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm4'
13263
13264 INTEGER :: handle
13265#if defined(__parallel)
13266 INTEGER :: ierr, msglen_in, msglen_out, &
13267 recv_tag, send_tag
13268#endif
13269
13270 CALL mp_timeset(routinen, handle)
13271
13272#if defined(__parallel)
13273 msglen_in = SIZE(msgin)
13274 msglen_out = SIZE(msgout)
13275 send_tag = 0 ! cannot think of something better here, this might be dangerous
13276 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13277 IF (PRESENT(tag)) THEN
13278 send_tag = tag
13279 recv_tag = tag
13280 END IF
13281 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13282 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13283 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13284 CALL add_perf(perf_id=7, count=1, &
13285 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13286#else
13287 mark_used(dest)
13288 mark_used(source)
13289 mark_used(comm)
13290 mark_used(tag)
13291 msgout = msgin
13292#endif
13293 CALL mp_timestop(handle)
13294 END SUBROUTINE mp_sendrecv_lm4
13295
13296! **************************************************************************************************
13297!> \brief Non-blocking send and receive of a scalar
13298!> \param[in] msgin Scalar data to send
13299!> \param[in] dest Which process to send to
13300!> \param[out] msgout Receive data into this pointer
13301!> \param[in] source Process to receive from
13302!> \param[in] comm Message passing environment identifier
13303!> \param[out] send_request Request handle for the send
13304!> \param[out] recv_request Request handle for the receive
13305!> \param[in] tag (optional) tag to differentiate requests
13306!> \par Implementation
13307!> Calls mpi_isend and mpi_irecv.
13308!> \par History
13309!> 02.2005 created [Alfio Lazzaro]
13310! **************************************************************************************************
13311 SUBROUTINE mp_isendrecv_l (msgin, dest, msgout, source, comm, send_request, &
13312 recv_request, tag)
13313 INTEGER(KIND=int_8), INTENT(IN) :: msgin
13314 INTEGER, INTENT(IN) :: dest
13315 INTEGER(KIND=int_8), INTENT(INOUT) :: msgout
13316 INTEGER, INTENT(IN) :: source
13317 CLASS(mp_comm_type), INTENT(IN) :: comm
13318 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
13319 INTEGER, INTENT(in), OPTIONAL :: tag
13320
13321 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_l'
13322
13323 INTEGER :: handle
13324#if defined(__parallel)
13325 INTEGER :: ierr, my_tag
13326#endif
13327
13328 CALL mp_timeset(routinen, handle)
13329
13330#if defined(__parallel)
13331 my_tag = 0
13332 IF (PRESENT(tag)) my_tag = tag
13333
13334 CALL mpi_irecv(msgout, 1, mpi_integer8, source, my_tag, &
13335 comm%handle, recv_request%handle, ierr)
13336 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13337
13338 CALL mpi_isend(msgin, 1, mpi_integer8, dest, my_tag, &
13339 comm%handle, send_request%handle, ierr)
13340 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13341
13342 CALL add_perf(perf_id=8, count=1, msg_size=2*int_8_size)
13343#else
13344 mark_used(dest)
13345 mark_used(source)
13346 mark_used(comm)
13347 mark_used(tag)
13348 send_request = mp_request_null
13349 recv_request = mp_request_null
13350 msgout = msgin
13351#endif
13352 CALL mp_timestop(handle)
13353 END SUBROUTINE mp_isendrecv_l
13354
13355! **************************************************************************************************
13356!> \brief Non-blocking send and receive of a vector
13357!> \param[in] msgin Vector data to send
13358!> \param[in] dest Which process to send to
13359!> \param[out] msgout Receive data into this pointer
13360!> \param[in] source Process to receive from
13361!> \param[in] comm Message passing environment identifier
13362!> \param[out] send_request Request handle for the send
13363!> \param[out] recv_request Request handle for the receive
13364!> \param[in] tag (optional) tag to differentiate requests
13365!> \par Implementation
13366!> Calls mpi_isend and mpi_irecv.
13367!> \par History
13368!> 11.2004 created [Joost VandeVondele]
13369!> \note
13370!> arrays can be pointers or assumed shape, but they must be contiguous!
13371! **************************************************************************************************
13372 SUBROUTINE mp_isendrecv_lv(msgin, dest, msgout, source, comm, send_request, &
13373 recv_request, tag)
13374 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: msgin
13375 INTEGER, INTENT(IN) :: dest
13376 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT) :: msgout
13377 INTEGER, INTENT(IN) :: source
13378 CLASS(mp_comm_type), INTENT(IN) :: comm
13379 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
13380 INTEGER, INTENT(in), OPTIONAL :: tag
13381
13382 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_lv'
13383
13384 INTEGER :: handle
13385#if defined(__parallel)
13386 INTEGER :: ierr, msglen, my_tag
13387 INTEGER(KIND=int_8) :: foo
13388#endif
13389
13390 CALL mp_timeset(routinen, handle)
13391
13392#if defined(__parallel)
13393#if !defined(__GNUC__) || __GNUC__ >= 9
13394 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
13395 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
13396#endif
13397
13398 my_tag = 0
13399 IF (PRESENT(tag)) my_tag = tag
13400
13401 msglen = SIZE(msgout, 1)
13402 IF (msglen > 0) THEN
13403 CALL mpi_irecv(msgout(1), msglen, mpi_integer8, source, my_tag, &
13404 comm%handle, recv_request%handle, ierr)
13405 ELSE
13406 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13407 comm%handle, recv_request%handle, ierr)
13408 END IF
13409 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13410
13411 msglen = SIZE(msgin, 1)
13412 IF (msglen > 0) THEN
13413 CALL mpi_isend(msgin(1), msglen, mpi_integer8, dest, my_tag, &
13414 comm%handle, send_request%handle, ierr)
13415 ELSE
13416 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13417 comm%handle, send_request%handle, ierr)
13418 END IF
13419 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13420
13421 msglen = (msglen + SIZE(msgout, 1) + 1)/2
13422 CALL add_perf(perf_id=8, count=1, msg_size=msglen*int_8_size)
13423#else
13424 mark_used(dest)
13425 mark_used(source)
13426 mark_used(comm)
13427 mark_used(tag)
13428 send_request = mp_request_null
13429 recv_request = mp_request_null
13430 msgout = msgin
13431#endif
13432 CALL mp_timestop(handle)
13433 END SUBROUTINE mp_isendrecv_lv
13434
13435! **************************************************************************************************
13436!> \brief Non-blocking send of vector data
13437!> \param msgin ...
13438!> \param dest ...
13439!> \param comm ...
13440!> \param request ...
13441!> \param tag ...
13442!> \par History
13443!> 08.2003 created [f&j]
13444!> \note see mp_isendrecv_lv
13445!> \note
13446!> arrays can be pointers or assumed shape, but they must be contiguous!
13447! **************************************************************************************************
13448 SUBROUTINE mp_isend_lv(msgin, dest, comm, request, tag)
13449 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: msgin
13450 INTEGER, INTENT(IN) :: dest
13451 CLASS(mp_comm_type), INTENT(IN) :: comm
13452 TYPE(mp_request_type), INTENT(out) :: request
13453 INTEGER, INTENT(in), OPTIONAL :: tag
13454
13455 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lv'
13456
13457 INTEGER :: handle, ierr
13458#if defined(__parallel)
13459 INTEGER :: msglen, my_tag
13460 INTEGER(KIND=int_8) :: foo(1)
13461#endif
13462
13463 CALL mp_timeset(routinen, handle)
13464
13465#if defined(__parallel)
13466#if !defined(__GNUC__) || __GNUC__ >= 9
13467 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
13468#endif
13469 my_tag = 0
13470 IF (PRESENT(tag)) my_tag = tag
13471
13472 msglen = SIZE(msgin)
13473 IF (msglen > 0) THEN
13474 CALL mpi_isend(msgin(1), msglen, mpi_integer8, dest, my_tag, &
13475 comm%handle, request%handle, ierr)
13476 ELSE
13477 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13478 comm%handle, request%handle, ierr)
13479 END IF
13480 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13481
13482 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13483#else
13484 mark_used(msgin)
13485 mark_used(dest)
13486 mark_used(comm)
13487 mark_used(request)
13488 mark_used(tag)
13489 ierr = 1
13490 request = mp_request_null
13491 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13492#endif
13493 CALL mp_timestop(handle)
13494 END SUBROUTINE mp_isend_lv
13495
13496! **************************************************************************************************
13497!> \brief Non-blocking send of matrix data
13498!> \param msgin ...
13499!> \param dest ...
13500!> \param comm ...
13501!> \param request ...
13502!> \param tag ...
13503!> \par History
13504!> 2009-11-25 [UB] Made type-generic for templates
13505!> \author fawzi
13506!> \note see mp_isendrecv_lv
13507!> \note see mp_isend_lv
13508!> \note
13509!> arrays can be pointers or assumed shape, but they must be contiguous!
13510! **************************************************************************************************
13511 SUBROUTINE mp_isend_lm2(msgin, dest, comm, request, tag)
13512 INTEGER(KIND=int_8), DIMENSION(:, :), INTENT(IN) :: msgin
13513 INTEGER, INTENT(IN) :: dest
13514 CLASS(mp_comm_type), INTENT(IN) :: comm
13515 TYPE(mp_request_type), INTENT(out) :: request
13516 INTEGER, INTENT(in), OPTIONAL :: tag
13517
13518 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm2'
13519
13520 INTEGER :: handle, ierr
13521#if defined(__parallel)
13522 INTEGER :: msglen, my_tag
13523 INTEGER(KIND=int_8) :: foo(1)
13524#endif
13525
13526 CALL mp_timeset(routinen, handle)
13527
13528#if defined(__parallel)
13529#if !defined(__GNUC__) || __GNUC__ >= 9
13530 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
13531#endif
13532
13533 my_tag = 0
13534 IF (PRESENT(tag)) my_tag = tag
13535
13536 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
13537 IF (msglen > 0) THEN
13538 CALL mpi_isend(msgin(1, 1), msglen, mpi_integer8, dest, my_tag, &
13539 comm%handle, request%handle, ierr)
13540 ELSE
13541 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13542 comm%handle, request%handle, ierr)
13543 END IF
13544 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13545
13546 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13547#else
13548 mark_used(msgin)
13549 mark_used(dest)
13550 mark_used(comm)
13551 mark_used(request)
13552 mark_used(tag)
13553 ierr = 1
13554 request = mp_request_null
13555 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13556#endif
13557 CALL mp_timestop(handle)
13558 END SUBROUTINE mp_isend_lm2
13559
13560! **************************************************************************************************
13561!> \brief Non-blocking send of rank-3 data
13562!> \param msgin ...
13563!> \param dest ...
13564!> \param comm ...
13565!> \param request ...
13566!> \param tag ...
13567!> \par History
13568!> 9.2008 added _rm3 subroutine [Iain Bethune]
13569!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
13570!> 2009-11-25 [UB] Made type-generic for templates
13571!> \author fawzi
13572!> \note see mp_isendrecv_lv
13573!> \note see mp_isend_lv
13574!> \note
13575!> arrays can be pointers or assumed shape, but they must be contiguous!
13576! **************************************************************************************************
13577 SUBROUTINE mp_isend_lm3(msgin, dest, comm, request, tag)
13578 INTEGER(KIND=int_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
13579 INTEGER, INTENT(IN) :: dest
13580 CLASS(mp_comm_type), INTENT(IN) :: comm
13581 TYPE(mp_request_type), INTENT(out) :: request
13582 INTEGER, INTENT(in), OPTIONAL :: tag
13583
13584 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm3'
13585
13586 INTEGER :: handle, ierr
13587#if defined(__parallel)
13588 INTEGER :: msglen, my_tag
13589 INTEGER(KIND=int_8) :: foo(1)
13590#endif
13591
13592 CALL mp_timeset(routinen, handle)
13593
13594#if defined(__parallel)
13595#if !defined(__GNUC__) || __GNUC__ >= 9
13596 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
13597#endif
13598
13599 my_tag = 0
13600 IF (PRESENT(tag)) my_tag = tag
13601
13602 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
13603 IF (msglen > 0) THEN
13604 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_integer8, dest, my_tag, &
13605 comm%handle, request%handle, ierr)
13606 ELSE
13607 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13608 comm%handle, request%handle, ierr)
13609 END IF
13610 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13611
13612 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13613#else
13614 mark_used(msgin)
13615 mark_used(dest)
13616 mark_used(comm)
13617 mark_used(request)
13618 mark_used(tag)
13619 ierr = 1
13620 request = mp_request_null
13621 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13622#endif
13623 CALL mp_timestop(handle)
13624 END SUBROUTINE mp_isend_lm3
13625
13626! **************************************************************************************************
13627!> \brief Non-blocking send of rank-4 data
13628!> \param msgin the input message
13629!> \param dest the destination processor
13630!> \param comm the communicator object
13631!> \param request the communication request id
13632!> \param tag the message tag
13633!> \par History
13634!> 2.2016 added _lm4 subroutine [Nico Holmberg]
13635!> \author fawzi
13636!> \note see mp_isend_lv
13637!> \note
13638!> arrays can be pointers or assumed shape, but they must be contiguous!
13639! **************************************************************************************************
13640 SUBROUTINE mp_isend_lm4(msgin, dest, comm, request, tag)
13641 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
13642 INTEGER, INTENT(IN) :: dest
13643 CLASS(mp_comm_type), INTENT(IN) :: comm
13644 TYPE(mp_request_type), INTENT(out) :: request
13645 INTEGER, INTENT(in), OPTIONAL :: tag
13646
13647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm4'
13648
13649 INTEGER :: handle, ierr
13650#if defined(__parallel)
13651 INTEGER :: msglen, my_tag
13652 INTEGER(KIND=int_8) :: foo(1)
13653#endif
13654
13655 CALL mp_timeset(routinen, handle)
13656
13657#if defined(__parallel)
13658#if !defined(__GNUC__) || __GNUC__ >= 9
13659 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
13660#endif
13661
13662 my_tag = 0
13663 IF (PRESENT(tag)) my_tag = tag
13664
13665 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
13666 IF (msglen > 0) THEN
13667 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_integer8, dest, my_tag, &
13668 comm%handle, request%handle, ierr)
13669 ELSE
13670 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13671 comm%handle, request%handle, ierr)
13672 END IF
13673 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13674
13675 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13676#else
13677 mark_used(msgin)
13678 mark_used(dest)
13679 mark_used(comm)
13680 mark_used(request)
13681 mark_used(tag)
13682 ierr = 1
13683 request = mp_request_null
13684 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13685#endif
13686 CALL mp_timestop(handle)
13687 END SUBROUTINE mp_isend_lm4
13688
13689! **************************************************************************************************
13690!> \brief Non-blocking receive of vector data
13691!> \param msgout ...
13692!> \param source ...
13693!> \param comm ...
13694!> \param request ...
13695!> \param tag ...
13696!> \par History
13697!> 08.2003 created [f&j]
13698!> 2009-11-25 [UB] Made type-generic for templates
13699!> \note see mp_isendrecv_lv
13700!> \note
13701!> arrays can be pointers or assumed shape, but they must be contiguous!
13702! **************************************************************************************************
13703 SUBROUTINE mp_irecv_lv(msgout, source, comm, request, tag)
13704 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT) :: msgout
13705 INTEGER, INTENT(IN) :: source
13706 CLASS(mp_comm_type), INTENT(IN) :: comm
13707 TYPE(mp_request_type), INTENT(out) :: request
13708 INTEGER, INTENT(in), OPTIONAL :: tag
13709
13710 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lv'
13711
13712 INTEGER :: handle
13713#if defined(__parallel)
13714 INTEGER :: ierr, msglen, my_tag
13715 INTEGER(KIND=int_8) :: foo(1)
13716#endif
13717
13718 CALL mp_timeset(routinen, handle)
13719
13720#if defined(__parallel)
13721#if !defined(__GNUC__) || __GNUC__ >= 9
13722 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
13723#endif
13724
13725 my_tag = 0
13726 IF (PRESENT(tag)) my_tag = tag
13727
13728 msglen = SIZE(msgout)
13729 IF (msglen > 0) THEN
13730 CALL mpi_irecv(msgout(1), msglen, mpi_integer8, source, my_tag, &
13731 comm%handle, request%handle, ierr)
13732 ELSE
13733 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13734 comm%handle, request%handle, ierr)
13735 END IF
13736 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13737
13738 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13739#else
13740 cpabort("mp_irecv called in non parallel case")
13741 mark_used(msgout)
13742 mark_used(source)
13743 mark_used(comm)
13744 mark_used(tag)
13745 request = mp_request_null
13746#endif
13747 CALL mp_timestop(handle)
13748 END SUBROUTINE mp_irecv_lv
13749
13750! **************************************************************************************************
13751!> \brief Non-blocking receive of matrix data
13752!> \param msgout ...
13753!> \param source ...
13754!> \param comm ...
13755!> \param request ...
13756!> \param tag ...
13757!> \par History
13758!> 2009-11-25 [UB] Made type-generic for templates
13759!> \author fawzi
13760!> \note see mp_isendrecv_lv
13761!> \note see mp_irecv_lv
13762!> \note
13763!> arrays can be pointers or assumed shape, but they must be contiguous!
13764! **************************************************************************************************
13765 SUBROUTINE mp_irecv_lm2(msgout, source, comm, request, tag)
13766 INTEGER(KIND=int_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
13767 INTEGER, INTENT(IN) :: source
13768 CLASS(mp_comm_type), INTENT(IN) :: comm
13769 TYPE(mp_request_type), INTENT(out) :: request
13770 INTEGER, INTENT(in), OPTIONAL :: tag
13771
13772 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm2'
13773
13774 INTEGER :: handle
13775#if defined(__parallel)
13776 INTEGER :: ierr, msglen, my_tag
13777 INTEGER(KIND=int_8) :: foo(1)
13778#endif
13779
13780 CALL mp_timeset(routinen, handle)
13781
13782#if defined(__parallel)
13783#if !defined(__GNUC__) || __GNUC__ >= 9
13784 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
13785#endif
13786
13787 my_tag = 0
13788 IF (PRESENT(tag)) my_tag = tag
13789
13790 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
13791 IF (msglen > 0) THEN
13792 CALL mpi_irecv(msgout(1, 1), msglen, mpi_integer8, source, my_tag, &
13793 comm%handle, request%handle, ierr)
13794 ELSE
13795 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13796 comm%handle, request%handle, ierr)
13797 END IF
13798 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13799
13800 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13801#else
13802 mark_used(msgout)
13803 mark_used(source)
13804 mark_used(comm)
13805 mark_used(tag)
13806 request = mp_request_null
13807 cpabort("mp_irecv called in non parallel case")
13808#endif
13809 CALL mp_timestop(handle)
13810 END SUBROUTINE mp_irecv_lm2
13811
13812! **************************************************************************************************
13813!> \brief Non-blocking send of rank-3 data
13814!> \param msgout ...
13815!> \param source ...
13816!> \param comm ...
13817!> \param request ...
13818!> \param tag ...
13819!> \par History
13820!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
13821!> 2009-11-25 [UB] Made type-generic for templates
13822!> \author fawzi
13823!> \note see mp_isendrecv_lv
13824!> \note see mp_irecv_lv
13825!> \note
13826!> arrays can be pointers or assumed shape, but they must be contiguous!
13827! **************************************************************************************************
13828 SUBROUTINE mp_irecv_lm3(msgout, source, comm, request, tag)
13829 INTEGER(KIND=int_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
13830 INTEGER, INTENT(IN) :: source
13831 CLASS(mp_comm_type), INTENT(IN) :: comm
13832 TYPE(mp_request_type), INTENT(out) :: request
13833 INTEGER, INTENT(in), OPTIONAL :: tag
13834
13835 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm3'
13836
13837 INTEGER :: handle
13838#if defined(__parallel)
13839 INTEGER :: ierr, msglen, my_tag
13840 INTEGER(KIND=int_8) :: foo(1)
13841#endif
13842
13843 CALL mp_timeset(routinen, handle)
13844
13845#if defined(__parallel)
13846#if !defined(__GNUC__) || __GNUC__ >= 9
13847 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
13848#endif
13849
13850 my_tag = 0
13851 IF (PRESENT(tag)) my_tag = tag
13852
13853 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
13854 IF (msglen > 0) THEN
13855 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_integer8, source, my_tag, &
13856 comm%handle, request%handle, ierr)
13857 ELSE
13858 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13859 comm%handle, request%handle, ierr)
13860 END IF
13861 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
13862
13863 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13864#else
13865 mark_used(msgout)
13866 mark_used(source)
13867 mark_used(comm)
13868 mark_used(tag)
13869 request = mp_request_null
13870 cpabort("mp_irecv called in non parallel case")
13871#endif
13872 CALL mp_timestop(handle)
13873 END SUBROUTINE mp_irecv_lm3
13874
13875! **************************************************************************************************
13876!> \brief Non-blocking receive of rank-4 data
13877!> \param msgout the output message
13878!> \param source the source processor
13879!> \param comm the communicator object
13880!> \param request the communication request id
13881!> \param tag the message tag
13882!> \par History
13883!> 2.2016 added _lm4 subroutine [Nico Holmberg]
13884!> \author fawzi
13885!> \note see mp_irecv_lv
13886!> \note
13887!> arrays can be pointers or assumed shape, but they must be contiguous!
13888! **************************************************************************************************
13889 SUBROUTINE mp_irecv_lm4(msgout, source, comm, request, tag)
13890 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
13891 INTEGER, INTENT(IN) :: source
13892 CLASS(mp_comm_type), INTENT(IN) :: comm
13893 TYPE(mp_request_type), INTENT(out) :: request
13894 INTEGER, INTENT(in), OPTIONAL :: tag
13895
13896 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm4'
13897
13898 INTEGER :: handle
13899#if defined(__parallel)
13900 INTEGER :: ierr, msglen, my_tag
13901 INTEGER(KIND=int_8) :: foo(1)
13902#endif
13903
13904 CALL mp_timeset(routinen, handle)
13905
13906#if defined(__parallel)
13907#if !defined(__GNUC__) || __GNUC__ >= 9
13908 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
13909#endif
13910
13911 my_tag = 0
13912 IF (PRESENT(tag)) my_tag = tag
13913
13914 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
13915 IF (msglen > 0) THEN
13916 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_integer8, source, my_tag, &
13917 comm%handle, request%handle, ierr)
13918 ELSE
13919 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13920 comm%handle, request%handle, ierr)
13921 END IF
13922 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
13923
13924 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13925#else
13926 mark_used(msgout)
13927 mark_used(source)
13928 mark_used(comm)
13929 mark_used(tag)
13930 request = mp_request_null
13931 cpabort("mp_irecv called in non parallel case")
13932#endif
13933 CALL mp_timestop(handle)
13934 END SUBROUTINE mp_irecv_lm4
13935
13936! **************************************************************************************************
13937!> \brief Window initialization function for vector data
13938!> \param base ...
13939!> \param comm ...
13940!> \param win ...
13941!> \par History
13942!> 02.2015 created [Alfio Lazzaro]
13943!> \note
13944!> arrays can be pointers or assumed shape, but they must be contiguous!
13945! **************************************************************************************************
13946 SUBROUTINE mp_win_create_lv(base, comm, win)
13947 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
13948 TYPE(mp_comm_type), INTENT(IN) :: comm
13949 CLASS(mp_win_type), INTENT(INOUT) :: win
13950
13951 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_lv'
13952
13953 INTEGER :: handle
13954#if defined(__parallel)
13955 INTEGER :: ierr
13956 INTEGER(kind=mpi_address_kind) :: len
13957 INTEGER(KIND=int_8) :: foo(1)
13958#endif
13959
13960 CALL mp_timeset(routinen, handle)
13961
13962#if defined(__parallel)
13963
13964 len = SIZE(base)*int_8_size
13965 IF (len > 0) THEN
13966 CALL mpi_win_create(base(1), len, int_8_size, mpi_info_null, comm%handle, win%handle, ierr)
13967 ELSE
13968 CALL mpi_win_create(foo, len, int_8_size, mpi_info_null, comm%handle, win%handle, ierr)
13969 END IF
13970 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
13971
13972 CALL add_perf(perf_id=20, count=1)
13973#else
13974 mark_used(base)
13975 mark_used(comm)
13976 win%handle = mp_win_null_handle
13977#endif
13978 CALL mp_timestop(handle)
13979 END SUBROUTINE mp_win_create_lv
13980
13981! **************************************************************************************************
13982!> \brief Single-sided get function for vector data
13983!> \param base ...
13984!> \param comm ...
13985!> \param win ...
13986!> \par History
13987!> 02.2015 created [Alfio Lazzaro]
13988!> \note
13989!> arrays can be pointers or assumed shape, but they must be contiguous!
13990! **************************************************************************************************
13991 SUBROUTINE mp_rget_lv(base, source, win, win_data, myproc, disp, request, &
13992 origin_datatype, target_datatype)
13993 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
13994 INTEGER, INTENT(IN) :: source
13995 CLASS(mp_win_type), INTENT(IN) :: win
13996 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: win_data
13997 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
13998 TYPE(mp_request_type), INTENT(OUT) :: request
13999 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
14000
14001 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_lv'
14002
14003 INTEGER :: handle
14004#if defined(__parallel)
14005 INTEGER :: ierr, len, &
14006 origin_len, target_len
14007 LOGICAL :: do_local_copy
14008 INTEGER(kind=mpi_address_kind) :: disp_aint
14009 mpi_data_type :: handle_origin_datatype, handle_target_datatype
14010#endif
14011
14012 CALL mp_timeset(routinen, handle)
14013
14014#if defined(__parallel)
14015 len = SIZE(base)
14016 disp_aint = 0
14017 IF (PRESENT(disp)) THEN
14018 disp_aint = int(disp, kind=mpi_address_kind)
14019 END IF
14020 handle_origin_datatype = mpi_integer8
14021 origin_len = len
14022 IF (PRESENT(origin_datatype)) THEN
14023 handle_origin_datatype = origin_datatype%type_handle
14024 origin_len = 1
14025 END IF
14026 handle_target_datatype = mpi_integer8
14027 target_len = len
14028 IF (PRESENT(target_datatype)) THEN
14029 handle_target_datatype = target_datatype%type_handle
14030 target_len = 1
14031 END IF
14032 IF (len > 0) THEN
14033 do_local_copy = .false.
14034 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
14035 IF (myproc .EQ. source) do_local_copy = .true.
14036 END IF
14037 IF (do_local_copy) THEN
14038 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
14039 base(:) = win_data(disp_aint + 1:disp_aint + len)
14040 !$OMP END PARALLEL WORKSHARE
14041 request = mp_request_null
14042 ierr = 0
14043 ELSE
14044 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
14045 target_len, handle_target_datatype, win%handle, request%handle, ierr)
14046 END IF
14047 ELSE
14048 request = mp_request_null
14049 ierr = 0
14050 END IF
14051 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
14052
14053 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*int_8_size)
14054#else
14055 mark_used(source)
14056 mark_used(win)
14057 mark_used(myproc)
14058 mark_used(origin_datatype)
14059 mark_used(target_datatype)
14060
14061 request = mp_request_null
14062 !
14063 IF (PRESENT(disp)) THEN
14064 base(:) = win_data(disp + 1:disp + SIZE(base))
14065 ELSE
14066 base(:) = win_data(:SIZE(base))
14067 END IF
14068
14069#endif
14070 CALL mp_timestop(handle)
14071 END SUBROUTINE mp_rget_lv
14072
14073! **************************************************************************************************
14074!> \brief ...
14075!> \param count ...
14076!> \param lengths ...
14077!> \param displs ...
14078!> \return ...
14079! ***************************************************************************
14080 FUNCTION mp_type_indexed_make_l (count, lengths, displs) &
14081 result(type_descriptor)
14082 INTEGER, INTENT(IN) :: count
14083 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
14084 TYPE(mp_type_descriptor_type) :: type_descriptor
14085
14086 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_l'
14087
14088 INTEGER :: handle
14089#if defined(__parallel)
14090 INTEGER :: ierr
14091#endif
14092
14093 CALL mp_timeset(routinen, handle)
14094
14095#if defined(__parallel)
14096 CALL mpi_type_indexed(count, lengths, displs, mpi_integer8, &
14097 type_descriptor%type_handle, ierr)
14098 IF (ierr /= 0) &
14099 cpabort("MPI_Type_Indexed @ "//routinen)
14100 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
14101 IF (ierr /= 0) &
14102 cpabort("MPI_Type_commit @ "//routinen)
14103#else
14104 type_descriptor%type_handle = 19
14105#endif
14106 type_descriptor%length = count
14107 NULLIFY (type_descriptor%subtype)
14108 type_descriptor%vector_descriptor(1:2) = 1
14109 type_descriptor%has_indexing = .true.
14110 type_descriptor%index_descriptor%index => lengths
14111 type_descriptor%index_descriptor%chunks => displs
14112
14113 CALL mp_timestop(handle)
14114
14115 END FUNCTION mp_type_indexed_make_l
14116
14117! **************************************************************************************************
14118!> \brief Allocates special parallel memory
14119!> \param[in] DATA pointer to integer array to allocate
14120!> \param[in] len number of integers to allocate
14121!> \param[out] stat (optional) allocation status result
14122!> \author UB
14123! **************************************************************************************************
14124 SUBROUTINE mp_allocate_l (DATA, len, stat)
14125 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
14126 INTEGER, INTENT(IN) :: len
14127 INTEGER, INTENT(OUT), OPTIONAL :: stat
14128
14129 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_l'
14130
14131 INTEGER :: handle, ierr
14132
14133 CALL mp_timeset(routinen, handle)
14134
14135#if defined(__parallel)
14136 NULLIFY (data)
14137 CALL mp_alloc_mem(DATA, len, stat=ierr)
14138 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
14139 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
14140 CALL add_perf(perf_id=15, count=1)
14141#else
14142 ALLOCATE (DATA(len), stat=ierr)
14143 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
14144 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
14145#endif
14146 IF (PRESENT(stat)) stat = ierr
14147 CALL mp_timestop(handle)
14148 END SUBROUTINE mp_allocate_l
14149
14150! **************************************************************************************************
14151!> \brief Deallocates special parallel memory
14152!> \param[in] DATA pointer to special memory to deallocate
14153!> \param stat ...
14154!> \author UB
14155! **************************************************************************************************
14156 SUBROUTINE mp_deallocate_l (DATA, stat)
14157 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
14158 INTEGER, INTENT(OUT), OPTIONAL :: stat
14159
14160 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_l'
14161
14162 INTEGER :: handle
14163#if defined(__parallel)
14164 INTEGER :: ierr
14165#endif
14166
14167 CALL mp_timeset(routinen, handle)
14168
14169#if defined(__parallel)
14170 CALL mp_free_mem(DATA, ierr)
14171 IF (PRESENT(stat)) THEN
14172 stat = ierr
14173 ELSE
14174 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
14175 END IF
14176 NULLIFY (data)
14177 CALL add_perf(perf_id=15, count=1)
14178#else
14179 DEALLOCATE (data)
14180 IF (PRESENT(stat)) stat = 0
14181#endif
14182 CALL mp_timestop(handle)
14183 END SUBROUTINE mp_deallocate_l
14184
14185! **************************************************************************************************
14186!> \brief (parallel) Blocking individual file write using explicit offsets
14187!> (serial) Unformatted stream write
14188!> \param[in] fh file handle (file storage unit)
14189!> \param[in] offset file offset (position)
14190!> \param[in] msg data to be written to the file
14191!> \param msglen ...
14192!> \par MPI-I/O mapping mpi_file_write_at
14193!> \par STREAM-I/O mapping WRITE
14194!> \param[in](optional) msglen number of the elements of data
14195! **************************************************************************************************
14196 SUBROUTINE mp_file_write_at_lv(fh, offset, msg, msglen)
14197 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
14198 CLASS(mp_file_type), INTENT(IN) :: fh
14199 INTEGER, INTENT(IN), OPTIONAL :: msglen
14200 INTEGER(kind=file_offset), INTENT(IN) :: offset
14201
14202 INTEGER :: msg_len
14203#if defined(__parallel)
14204 INTEGER :: ierr
14205#endif
14206
14207 msg_len = SIZE(msg)
14208 IF (PRESENT(msglen)) msg_len = msglen
14209#if defined(__parallel)
14210 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14211 IF (ierr .NE. 0) &
14212 cpabort("mpi_file_write_at_lv @ mp_file_write_at_lv")
14213#else
14214 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14215#endif
14216 END SUBROUTINE mp_file_write_at_lv
14217
14218! **************************************************************************************************
14219!> \brief ...
14220!> \param fh ...
14221!> \param offset ...
14222!> \param msg ...
14223! **************************************************************************************************
14224 SUBROUTINE mp_file_write_at_l (fh, offset, msg)
14225 INTEGER(KIND=int_8), INTENT(IN) :: msg
14226 CLASS(mp_file_type), INTENT(IN) :: fh
14227 INTEGER(kind=file_offset), INTENT(IN) :: offset
14228
14229#if defined(__parallel)
14230 INTEGER :: ierr
14231
14232 ierr = 0
14233 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14234 IF (ierr .NE. 0) &
14235 cpabort("mpi_file_write_at_l @ mp_file_write_at_l")
14236#else
14237 WRITE (unit=fh%handle, pos=offset + 1) msg
14238#endif
14239 END SUBROUTINE mp_file_write_at_l
14240
14241! **************************************************************************************************
14242!> \brief (parallel) Blocking collective file write using explicit offsets
14243!> (serial) Unformatted stream write
14244!> \param fh ...
14245!> \param offset ...
14246!> \param msg ...
14247!> \param msglen ...
14248!> \par MPI-I/O mapping mpi_file_write_at_all
14249!> \par STREAM-I/O mapping WRITE
14250! **************************************************************************************************
14251 SUBROUTINE mp_file_write_at_all_lv(fh, offset, msg, msglen)
14252 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
14253 CLASS(mp_file_type), INTENT(IN) :: fh
14254 INTEGER, INTENT(IN), OPTIONAL :: msglen
14255 INTEGER(kind=file_offset), INTENT(IN) :: offset
14256
14257 INTEGER :: msg_len
14258#if defined(__parallel)
14259 INTEGER :: ierr
14260#endif
14261
14262 msg_len = SIZE(msg)
14263 IF (PRESENT(msglen)) msg_len = msglen
14264#if defined(__parallel)
14265 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14266 IF (ierr .NE. 0) &
14267 cpabort("mpi_file_write_at_all_lv @ mp_file_write_at_all_lv")
14268#else
14269 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14270#endif
14271 END SUBROUTINE mp_file_write_at_all_lv
14272
14273! **************************************************************************************************
14274!> \brief ...
14275!> \param fh ...
14276!> \param offset ...
14277!> \param msg ...
14278! **************************************************************************************************
14279 SUBROUTINE mp_file_write_at_all_l (fh, offset, msg)
14280 INTEGER(KIND=int_8), INTENT(IN) :: msg
14281 CLASS(mp_file_type), INTENT(IN) :: fh
14282 INTEGER(kind=file_offset), INTENT(IN) :: offset
14283
14284#if defined(__parallel)
14285 INTEGER :: ierr
14286
14287 ierr = 0
14288 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14289 IF (ierr .NE. 0) &
14290 cpabort("mpi_file_write_at_all_l @ mp_file_write_at_all_l")
14291#else
14292 WRITE (unit=fh%handle, pos=offset + 1) msg
14293#endif
14294 END SUBROUTINE mp_file_write_at_all_l
14295
14296! **************************************************************************************************
14297!> \brief (parallel) Blocking individual file read using explicit offsets
14298!> (serial) Unformatted stream read
14299!> \param[in] fh file handle (file storage unit)
14300!> \param[in] offset file offset (position)
14301!> \param[out] msg data to be read from the file
14302!> \param msglen ...
14303!> \par MPI-I/O mapping mpi_file_read_at
14304!> \par STREAM-I/O mapping READ
14305!> \param[in](optional) msglen number of elements of data
14306! **************************************************************************************************
14307 SUBROUTINE mp_file_read_at_lv(fh, offset, msg, msglen)
14308 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msg(:)
14309 CLASS(mp_file_type), INTENT(IN) :: fh
14310 INTEGER, INTENT(IN), OPTIONAL :: msglen
14311 INTEGER(kind=file_offset), INTENT(IN) :: offset
14312
14313 INTEGER :: msg_len
14314#if defined(__parallel)
14315 INTEGER :: ierr
14316#endif
14317
14318 msg_len = SIZE(msg)
14319 IF (PRESENT(msglen)) msg_len = msglen
14320#if defined(__parallel)
14321 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14322 IF (ierr .NE. 0) &
14323 cpabort("mpi_file_read_at_lv @ mp_file_read_at_lv")
14324#else
14325 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14326#endif
14327 END SUBROUTINE mp_file_read_at_lv
14328
14329! **************************************************************************************************
14330!> \brief ...
14331!> \param fh ...
14332!> \param offset ...
14333!> \param msg ...
14334! **************************************************************************************************
14335 SUBROUTINE mp_file_read_at_l (fh, offset, msg)
14336 INTEGER(KIND=int_8), INTENT(OUT) :: msg
14337 CLASS(mp_file_type), INTENT(IN) :: fh
14338 INTEGER(kind=file_offset), INTENT(IN) :: offset
14339
14340#if defined(__parallel)
14341 INTEGER :: ierr
14342
14343 ierr = 0
14344 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14345 IF (ierr .NE. 0) &
14346 cpabort("mpi_file_read_at_l @ mp_file_read_at_l")
14347#else
14348 READ (unit=fh%handle, pos=offset + 1) msg
14349#endif
14350 END SUBROUTINE mp_file_read_at_l
14351
14352! **************************************************************************************************
14353!> \brief (parallel) Blocking collective file read using explicit offsets
14354!> (serial) Unformatted stream read
14355!> \param fh ...
14356!> \param offset ...
14357!> \param msg ...
14358!> \param msglen ...
14359!> \par MPI-I/O mapping mpi_file_read_at_all
14360!> \par STREAM-I/O mapping READ
14361! **************************************************************************************************
14362 SUBROUTINE mp_file_read_at_all_lv(fh, offset, msg, msglen)
14363 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msg(:)
14364 CLASS(mp_file_type), INTENT(IN) :: fh
14365 INTEGER, INTENT(IN), OPTIONAL :: msglen
14366 INTEGER(kind=file_offset), INTENT(IN) :: offset
14367
14368 INTEGER :: msg_len
14369#if defined(__parallel)
14370 INTEGER :: ierr
14371#endif
14372
14373 msg_len = SIZE(msg)
14374 IF (PRESENT(msglen)) msg_len = msglen
14375#if defined(__parallel)
14376 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14377 IF (ierr .NE. 0) &
14378 cpabort("mpi_file_read_at_all_lv @ mp_file_read_at_all_lv")
14379#else
14380 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14381#endif
14382 END SUBROUTINE mp_file_read_at_all_lv
14383
14384! **************************************************************************************************
14385!> \brief ...
14386!> \param fh ...
14387!> \param offset ...
14388!> \param msg ...
14389! **************************************************************************************************
14390 SUBROUTINE mp_file_read_at_all_l (fh, offset, msg)
14391 INTEGER(KIND=int_8), INTENT(OUT) :: msg
14392 CLASS(mp_file_type), INTENT(IN) :: fh
14393 INTEGER(kind=file_offset), INTENT(IN) :: offset
14394
14395#if defined(__parallel)
14396 INTEGER :: ierr
14397
14398 ierr = 0
14399 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14400 IF (ierr .NE. 0) &
14401 cpabort("mpi_file_read_at_all_l @ mp_file_read_at_all_l")
14402#else
14403 READ (unit=fh%handle, pos=offset + 1) msg
14404#endif
14405 END SUBROUTINE mp_file_read_at_all_l
14406
14407! **************************************************************************************************
14408!> \brief ...
14409!> \param ptr ...
14410!> \param vector_descriptor ...
14411!> \param index_descriptor ...
14412!> \return ...
14413! **************************************************************************************************
14414 FUNCTION mp_type_make_l (ptr, &
14415 vector_descriptor, index_descriptor) &
14416 result(type_descriptor)
14417 INTEGER(KIND=int_8), DIMENSION(:), TARGET, asynchronous :: ptr
14418 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
14419 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
14420 TYPE(mp_type_descriptor_type) :: type_descriptor
14421
14422 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_l'
14423
14424#if defined(__parallel)
14425 INTEGER :: ierr
14426#if defined(__MPI_F08)
14427 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
14428 EXTERNAL :: mpi_get_address
14429#endif
14430#endif
14431
14432 NULLIFY (type_descriptor%subtype)
14433 type_descriptor%length = SIZE(ptr)
14434#if defined(__parallel)
14435 type_descriptor%type_handle = mpi_integer8
14436 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
14437 IF (ierr /= 0) &
14438 cpabort("MPI_Get_address @ "//routinen)
14439#else
14440 type_descriptor%type_handle = 19
14441#endif
14442 type_descriptor%vector_descriptor(1:2) = 1
14443 type_descriptor%has_indexing = .false.
14444 type_descriptor%data_l => ptr
14445 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
14446 cpabort(routinen//": Vectors and indices NYI")
14447 END IF
14448 END FUNCTION mp_type_make_l
14449
14450! **************************************************************************************************
14451!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
14452!> as the Fortran version returns an integer, which we take to be a C_PTR
14453!> \param DATA data array to allocate
14454!> \param[in] len length (in data elements) of data array allocation
14455!> \param[out] stat (optional) allocation status result
14456! **************************************************************************************************
14457 SUBROUTINE mp_alloc_mem_l (DATA, len, stat)
14458 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: data
14459 INTEGER, INTENT(IN) :: len
14460 INTEGER, INTENT(OUT), OPTIONAL :: stat
14461
14462#if defined(__parallel)
14463 INTEGER :: size, ierr, length, &
14464 mp_res
14465 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
14466 TYPE(c_ptr) :: mp_baseptr
14467 mpi_info_type :: mp_info
14468
14469 length = max(len, 1)
14470 CALL mpi_type_size(mpi_integer8, size, ierr)
14471 mp_size = int(length, kind=mpi_address_kind)*size
14472 IF (mp_size .GT. mp_max_memory_size) THEN
14473 cpabort("MPI cannot allocate more than 2 GiByte")
14474 END IF
14475 mp_info = mpi_info_null
14476 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
14477 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
14478 IF (PRESENT(stat)) stat = mp_res
14479#else
14480 INTEGER :: length, mystat
14481 length = max(len, 1)
14482 IF (PRESENT(stat)) THEN
14483 ALLOCATE (DATA(length), stat=mystat)
14484 stat = mystat ! show to convention checker that stat is used
14485 ELSE
14486 ALLOCATE (DATA(length))
14487 END IF
14488#endif
14489 END SUBROUTINE mp_alloc_mem_l
14490
14491! **************************************************************************************************
14492!> \brief Deallocates am array, ... this is hackish
14493!> as the Fortran version takes an integer, which we hope to get by reference
14494!> \param DATA data array to allocate
14495!> \param[out] stat (optional) allocation status result
14496! **************************************************************************************************
14497 SUBROUTINE mp_free_mem_l (DATA, stat)
14498 INTEGER(KIND=int_8), DIMENSION(:), &
14499 POINTER, asynchronous :: data
14500 INTEGER, INTENT(OUT), OPTIONAL :: stat
14501
14502#if defined(__parallel)
14503 INTEGER :: mp_res
14504 CALL mpi_free_mem(DATA, mp_res)
14505 IF (PRESENT(stat)) stat = mp_res
14506#else
14507 DEALLOCATE (data)
14508 IF (PRESENT(stat)) stat = 0
14509#endif
14510 END SUBROUTINE mp_free_mem_l
14511! **************************************************************************************************
14512!> \brief Shift around the data in msg
14513!> \param[in,out] msg Rank-2 data to shift
14514!> \param[in] comm message passing environment identifier
14515!> \param[in] displ_in displacements (?)
14516!> \par Example
14517!> msg will be moved from rank to rank+displ_in (in a circular way)
14518!> \par Limitations
14519!> * displ_in will be 1 by default (others not tested)
14520!> * the message array needs to be the same size on all processes
14521! **************************************************************************************************
14522 SUBROUTINE mp_shift_dm(msg, comm, displ_in)
14523
14524 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
14525 CLASS(mp_comm_type), INTENT(IN) :: comm
14526 INTEGER, INTENT(IN), OPTIONAL :: displ_in
14527
14528 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_dm'
14529
14530 INTEGER :: handle, ierror
14531#if defined(__parallel)
14532 INTEGER :: displ, left, &
14533 msglen, myrank, nprocs, &
14534 right, tag
14535#endif
14536
14537 ierror = 0
14538 CALL mp_timeset(routinen, handle)
14539
14540#if defined(__parallel)
14541 CALL mpi_comm_rank(comm%handle, myrank, ierror)
14542 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
14543 CALL mpi_comm_size(comm%handle, nprocs, ierror)
14544 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
14545 IF (PRESENT(displ_in)) THEN
14546 displ = displ_in
14547 ELSE
14548 displ = 1
14549 END IF
14550 right = modulo(myrank + displ, nprocs)
14551 left = modulo(myrank - displ, nprocs)
14552 tag = 17
14553 msglen = SIZE(msg)
14554 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_precision, right, tag, left, tag, &
14555 comm%handle, mpi_status_ignore, ierror)
14556 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
14557 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_8_size)
14558#else
14559 mark_used(msg)
14560 mark_used(comm)
14561 mark_used(displ_in)
14562#endif
14563 CALL mp_timestop(handle)
14564
14565 END SUBROUTINE mp_shift_dm
14566
14567! **************************************************************************************************
14568!> \brief Shift around the data in msg
14569!> \param[in,out] msg Data to shift
14570!> \param[in] comm message passing environment identifier
14571!> \param[in] displ_in displacements (?)
14572!> \par Example
14573!> msg will be moved from rank to rank+displ_in (in a circular way)
14574!> \par Limitations
14575!> * displ_in will be 1 by default (others not tested)
14576!> * the message array needs to be the same size on all processes
14577! **************************************************************************************************
14578 SUBROUTINE mp_shift_d (msg, comm, displ_in)
14579
14580 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
14581 CLASS(mp_comm_type), INTENT(IN) :: comm
14582 INTEGER, INTENT(IN), OPTIONAL :: displ_in
14583
14584 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_d'
14585
14586 INTEGER :: handle, ierror
14587#if defined(__parallel)
14588 INTEGER :: displ, left, &
14589 msglen, myrank, nprocs, &
14590 right, tag
14591#endif
14592
14593 ierror = 0
14594 CALL mp_timeset(routinen, handle)
14595
14596#if defined(__parallel)
14597 CALL mpi_comm_rank(comm%handle, myrank, ierror)
14598 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
14599 CALL mpi_comm_size(comm%handle, nprocs, ierror)
14600 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
14601 IF (PRESENT(displ_in)) THEN
14602 displ = displ_in
14603 ELSE
14604 displ = 1
14605 END IF
14606 right = modulo(myrank + displ, nprocs)
14607 left = modulo(myrank - displ, nprocs)
14608 tag = 19
14609 msglen = SIZE(msg)
14610 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_precision, right, tag, left, &
14611 tag, comm%handle, mpi_status_ignore, ierror)
14612 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
14613 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_8_size)
14614#else
14615 mark_used(msg)
14616 mark_used(comm)
14617 mark_used(displ_in)
14618#endif
14619 CALL mp_timestop(handle)
14620
14621 END SUBROUTINE mp_shift_d
14622
14623! **************************************************************************************************
14624!> \brief All-to-all data exchange, rank-1 data of different sizes
14625!> \param[in] sb Data to send
14626!> \param[in] scount Data counts for data sent to other processes
14627!> \param[in] sdispl Respective data offsets for data sent to process
14628!> \param[in,out] rb Buffer into which to receive data
14629!> \param[in] rcount Data counts for data received from other
14630!> processes
14631!> \param[in] rdispl Respective data offsets for data received from
14632!> other processes
14633!> \param[in] comm Message passing environment identifier
14634!> \par MPI mapping
14635!> mpi_alltoallv
14636!> \par Array sizes
14637!> The scount, rcount, and the sdispl and rdispl arrays have a
14638!> size equal to the number of processes.
14639!> \par Offsets
14640!> Values in sdispl and rdispl start with 0.
14641! **************************************************************************************************
14642 SUBROUTINE mp_alltoall_d11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
14643
14644 REAL(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
14645 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
14646 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
14647 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
14648 CLASS(mp_comm_type), INTENT(IN) :: comm
14649
14650 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d11v'
14651
14652 INTEGER :: handle
14653#if defined(__parallel)
14654 INTEGER :: ierr, msglen
14655#else
14656 INTEGER :: i
14657#endif
14658
14659 CALL mp_timeset(routinen, handle)
14660
14661#if defined(__parallel)
14662 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_precision, &
14663 rb, rcount, rdispl, mpi_double_precision, comm%handle, ierr)
14664 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
14665 msglen = sum(scount) + sum(rcount)
14666 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14667#else
14668 mark_used(comm)
14669 mark_used(scount)
14670 mark_used(sdispl)
14671 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
14672 DO i = 1, rcount(1)
14673 rb(rdispl(1) + i) = sb(sdispl(1) + i)
14674 END DO
14675#endif
14676 CALL mp_timestop(handle)
14677
14678 END SUBROUTINE mp_alltoall_d11v
14679
14680! **************************************************************************************************
14681!> \brief All-to-all data exchange, rank-2 data of different sizes
14682!> \param sb ...
14683!> \param scount ...
14684!> \param sdispl ...
14685!> \param rb ...
14686!> \param rcount ...
14687!> \param rdispl ...
14688!> \param comm ...
14689!> \par MPI mapping
14690!> mpi_alltoallv
14691!> \note see mp_alltoall_d11v
14692! **************************************************************************************************
14693 SUBROUTINE mp_alltoall_d22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
14694
14695 REAL(kind=real_8), DIMENSION(:, :), &
14696 INTENT(IN), CONTIGUOUS :: sb
14697 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
14698 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, &
14699 INTENT(INOUT) :: rb
14700 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
14701 CLASS(mp_comm_type), INTENT(IN) :: comm
14702
14703 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d22v'
14704
14705 INTEGER :: handle
14706#if defined(__parallel)
14707 INTEGER :: ierr, msglen
14708#endif
14709
14710 CALL mp_timeset(routinen, handle)
14711
14712#if defined(__parallel)
14713 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_precision, &
14714 rb, rcount, rdispl, mpi_double_precision, comm%handle, ierr)
14715 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
14716 msglen = sum(scount) + sum(rcount)
14717 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*real_8_size)
14718#else
14719 mark_used(comm)
14720 mark_used(scount)
14721 mark_used(sdispl)
14722 mark_used(rcount)
14723 mark_used(rdispl)
14724 rb = sb
14725#endif
14726 CALL mp_timestop(handle)
14727
14728 END SUBROUTINE mp_alltoall_d22v
14729
14730! **************************************************************************************************
14731!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
14732!> \param[in] sb array with data to send
14733!> \param[out] rb array into which data is received
14734!> \param[in] count number of elements to send/receive (product of the
14735!> extents of the first two dimensions)
14736!> \param[in] comm Message passing environment identifier
14737!> \par Index meaning
14738!> \par The first two indices specify the data while the last index counts
14739!> the processes
14740!> \par Sizes of ranks
14741!> All processes have the same data size.
14742!> \par MPI mapping
14743!> mpi_alltoall
14744! **************************************************************************************************
14745 SUBROUTINE mp_alltoall_d (sb, rb, count, comm)
14746
14747 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
14748 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
14749 INTEGER, INTENT(IN) :: count
14750 CLASS(mp_comm_type), INTENT(IN) :: comm
14751
14752 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d'
14753
14754 INTEGER :: handle
14755#if defined(__parallel)
14756 INTEGER :: ierr, msglen, np
14757#endif
14758
14759 CALL mp_timeset(routinen, handle)
14760
14761#if defined(__parallel)
14762 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14763 rb, count, mpi_double_precision, comm%handle, ierr)
14764 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14765 CALL mpi_comm_size(comm%handle, np, ierr)
14766 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14767 msglen = 2*count*np
14768 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14769#else
14770 mark_used(count)
14771 mark_used(comm)
14772 rb = sb
14773#endif
14774 CALL mp_timestop(handle)
14775
14776 END SUBROUTINE mp_alltoall_d
14777
14778! **************************************************************************************************
14779!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
14780!> \param sb ...
14781!> \param rb ...
14782!> \param count ...
14783!> \param commp ...
14784!> \note see mp_alltoall_d
14785! **************************************************************************************************
14786 SUBROUTINE mp_alltoall_d22(sb, rb, count, comm)
14787
14788 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
14789 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
14790 INTEGER, INTENT(IN) :: count
14791 CLASS(mp_comm_type), INTENT(IN) :: comm
14792
14793 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d22'
14794
14795 INTEGER :: handle
14796#if defined(__parallel)
14797 INTEGER :: ierr, msglen, np
14798#endif
14799
14800 CALL mp_timeset(routinen, handle)
14801
14802#if defined(__parallel)
14803 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14804 rb, count, mpi_double_precision, comm%handle, ierr)
14805 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14806 CALL mpi_comm_size(comm%handle, np, ierr)
14807 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14808 msglen = 2*SIZE(sb)*np
14809 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14810#else
14811 mark_used(count)
14812 mark_used(comm)
14813 rb = sb
14814#endif
14815 CALL mp_timestop(handle)
14816
14817 END SUBROUTINE mp_alltoall_d22
14818
14819! **************************************************************************************************
14820!> \brief All-to-all data exchange, rank-3 data with equal sizes
14821!> \param sb ...
14822!> \param rb ...
14823!> \param count ...
14824!> \param comm ...
14825!> \note see mp_alltoall_d
14826! **************************************************************************************************
14827 SUBROUTINE mp_alltoall_d33(sb, rb, count, comm)
14828
14829 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
14830 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
14831 INTEGER, INTENT(IN) :: count
14832 CLASS(mp_comm_type), INTENT(IN) :: comm
14833
14834 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d33'
14835
14836 INTEGER :: handle
14837#if defined(__parallel)
14838 INTEGER :: ierr, msglen, np
14839#endif
14840
14841 CALL mp_timeset(routinen, handle)
14842
14843#if defined(__parallel)
14844 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14845 rb, count, mpi_double_precision, comm%handle, ierr)
14846 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14847 CALL mpi_comm_size(comm%handle, np, ierr)
14848 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14849 msglen = 2*count*np
14850 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14851#else
14852 mark_used(count)
14853 mark_used(comm)
14854 rb = sb
14855#endif
14856 CALL mp_timestop(handle)
14857
14858 END SUBROUTINE mp_alltoall_d33
14859
14860! **************************************************************************************************
14861!> \brief All-to-all data exchange, rank 4 data, equal sizes
14862!> \param sb ...
14863!> \param rb ...
14864!> \param count ...
14865!> \param comm ...
14866!> \note see mp_alltoall_d
14867! **************************************************************************************************
14868 SUBROUTINE mp_alltoall_d44(sb, rb, count, comm)
14869
14870 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14871 INTENT(IN) :: sb
14872 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14873 INTENT(OUT) :: rb
14874 INTEGER, INTENT(IN) :: count
14875 CLASS(mp_comm_type), INTENT(IN) :: comm
14876
14877 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d44'
14878
14879 INTEGER :: handle
14880#if defined(__parallel)
14881 INTEGER :: ierr, msglen, np
14882#endif
14883
14884 CALL mp_timeset(routinen, handle)
14885
14886#if defined(__parallel)
14887 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14888 rb, count, mpi_double_precision, comm%handle, ierr)
14889 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14890 CALL mpi_comm_size(comm%handle, np, ierr)
14891 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14892 msglen = 2*count*np
14893 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14894#else
14895 mark_used(count)
14896 mark_used(comm)
14897 rb = sb
14898#endif
14899 CALL mp_timestop(handle)
14900
14901 END SUBROUTINE mp_alltoall_d44
14902
14903! **************************************************************************************************
14904!> \brief All-to-all data exchange, rank 5 data, equal sizes
14905!> \param sb ...
14906!> \param rb ...
14907!> \param count ...
14908!> \param comm ...
14909!> \note see mp_alltoall_d
14910! **************************************************************************************************
14911 SUBROUTINE mp_alltoall_d55(sb, rb, count, comm)
14912
14913 REAL(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
14914 INTENT(IN) :: sb
14915 REAL(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
14916 INTENT(OUT) :: rb
14917 INTEGER, INTENT(IN) :: count
14918 CLASS(mp_comm_type), INTENT(IN) :: comm
14919
14920 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d55'
14921
14922 INTEGER :: handle
14923#if defined(__parallel)
14924 INTEGER :: ierr, msglen, np
14925#endif
14926
14927 CALL mp_timeset(routinen, handle)
14928
14929#if defined(__parallel)
14930 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14931 rb, count, mpi_double_precision, comm%handle, ierr)
14932 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14933 CALL mpi_comm_size(comm%handle, np, ierr)
14934 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14935 msglen = 2*count*np
14936 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14937#else
14938 mark_used(count)
14939 mark_used(comm)
14940 rb = sb
14941#endif
14942 CALL mp_timestop(handle)
14943
14944 END SUBROUTINE mp_alltoall_d55
14945
14946! **************************************************************************************************
14947!> \brief All-to-all data exchange, rank-4 data to rank-5 data
14948!> \param sb ...
14949!> \param rb ...
14950!> \param count ...
14951!> \param comm ...
14952!> \note see mp_alltoall_d
14953!> \note User must ensure size consistency.
14954! **************************************************************************************************
14955 SUBROUTINE mp_alltoall_d45(sb, rb, count, comm)
14956
14957 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14958 INTENT(IN) :: sb
14959 REAL(kind=real_8), &
14960 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
14961 INTEGER, INTENT(IN) :: count
14962 CLASS(mp_comm_type), INTENT(IN) :: comm
14963
14964 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d45'
14965
14966 INTEGER :: handle
14967#if defined(__parallel)
14968 INTEGER :: ierr, msglen, np
14969#endif
14970
14971 CALL mp_timeset(routinen, handle)
14972
14973#if defined(__parallel)
14974 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14975 rb, count, mpi_double_precision, comm%handle, ierr)
14976 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14977 CALL mpi_comm_size(comm%handle, np, ierr)
14978 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14979 msglen = 2*count*np
14980 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14981#else
14982 mark_used(count)
14983 mark_used(comm)
14984 rb = reshape(sb, shape(rb))
14985#endif
14986 CALL mp_timestop(handle)
14987
14988 END SUBROUTINE mp_alltoall_d45
14989
14990! **************************************************************************************************
14991!> \brief All-to-all data exchange, rank-3 data to rank-4 data
14992!> \param sb ...
14993!> \param rb ...
14994!> \param count ...
14995!> \param comm ...
14996!> \note see mp_alltoall_d
14997!> \note User must ensure size consistency.
14998! **************************************************************************************************
14999 SUBROUTINE mp_alltoall_d34(sb, rb, count, comm)
15000
15001 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, &
15002 INTENT(IN) :: sb
15003 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
15004 INTENT(OUT) :: rb
15005 INTEGER, INTENT(IN) :: count
15006 CLASS(mp_comm_type), INTENT(IN) :: comm
15007
15008 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d34'
15009
15010 INTEGER :: handle
15011#if defined(__parallel)
15012 INTEGER :: ierr, msglen, np
15013#endif
15014
15015 CALL mp_timeset(routinen, handle)
15016
15017#if defined(__parallel)
15018 CALL mpi_alltoall(sb, count, mpi_double_precision, &
15019 rb, count, mpi_double_precision, comm%handle, ierr)
15020 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
15021 CALL mpi_comm_size(comm%handle, np, ierr)
15022 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
15023 msglen = 2*count*np
15024 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
15025#else
15026 mark_used(count)
15027 mark_used(comm)
15028 rb = reshape(sb, shape(rb))
15029#endif
15030 CALL mp_timestop(handle)
15031
15032 END SUBROUTINE mp_alltoall_d34
15033
15034! **************************************************************************************************
15035!> \brief All-to-all data exchange, rank-5 data to rank-4 data
15036!> \param sb ...
15037!> \param rb ...
15038!> \param count ...
15039!> \param comm ...
15040!> \note see mp_alltoall_d
15041!> \note User must ensure size consistency.
15042! **************************************************************************************************
15043 SUBROUTINE mp_alltoall_d54(sb, rb, count, comm)
15044
15045 REAL(kind=real_8), &
15046 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
15047 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
15048 INTENT(OUT) :: rb
15049 INTEGER, INTENT(IN) :: count
15050 CLASS(mp_comm_type), INTENT(IN) :: comm
15051
15052 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d54'
15053
15054 INTEGER :: handle
15055#if defined(__parallel)
15056 INTEGER :: ierr, msglen, np
15057#endif
15058
15059 CALL mp_timeset(routinen, handle)
15060
15061#if defined(__parallel)
15062 CALL mpi_alltoall(sb, count, mpi_double_precision, &
15063 rb, count, mpi_double_precision, comm%handle, ierr)
15064 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
15065 CALL mpi_comm_size(comm%handle, np, ierr)
15066 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
15067 msglen = 2*count*np
15068 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
15069#else
15070 mark_used(count)
15071 mark_used(comm)
15072 rb = reshape(sb, shape(rb))
15073#endif
15074 CALL mp_timestop(handle)
15075
15076 END SUBROUTINE mp_alltoall_d54
15077
15078! **************************************************************************************************
15079!> \brief Send one datum to another process
15080!> \param[in] msg Scalar to send
15081!> \param[in] dest Destination process
15082!> \param[in] tag Transfer identifier
15083!> \param[in] comm Message passing environment identifier
15084!> \par MPI mapping
15085!> mpi_send
15086! **************************************************************************************************
15087 SUBROUTINE mp_send_d (msg, dest, tag, comm)
15088 REAL(kind=real_8), INTENT(IN) :: msg
15089 INTEGER, INTENT(IN) :: dest, tag
15090 CLASS(mp_comm_type), INTENT(IN) :: comm
15091
15092 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_d'
15093
15094 INTEGER :: handle
15095#if defined(__parallel)
15096 INTEGER :: ierr, msglen
15097#endif
15098
15099 CALL mp_timeset(routinen, handle)
15100
15101#if defined(__parallel)
15102 msglen = 1
15103 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15104 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15105 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15106#else
15107 mark_used(msg)
15108 mark_used(dest)
15109 mark_used(tag)
15110 mark_used(comm)
15111 ! only defined in parallel
15112 cpabort("not in parallel mode")
15113#endif
15114 CALL mp_timestop(handle)
15115 END SUBROUTINE mp_send_d
15116
15117! **************************************************************************************************
15118!> \brief Send rank-1 data to another process
15119!> \param[in] msg Rank-1 data to send
15120!> \param dest ...
15121!> \param tag ...
15122!> \param comm ...
15123!> \note see mp_send_d
15124! **************************************************************************************************
15125 SUBROUTINE mp_send_dv(msg, dest, tag, comm)
15126 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
15127 INTEGER, INTENT(IN) :: dest, tag
15128 CLASS(mp_comm_type), INTENT(IN) :: comm
15129
15130 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_dv'
15131
15132 INTEGER :: handle
15133#if defined(__parallel)
15134 INTEGER :: ierr, msglen
15135#endif
15136
15137 CALL mp_timeset(routinen, handle)
15138
15139#if defined(__parallel)
15140 msglen = SIZE(msg)
15141 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15142 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15143 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15144#else
15145 mark_used(msg)
15146 mark_used(dest)
15147 mark_used(tag)
15148 mark_used(comm)
15149 ! only defined in parallel
15150 cpabort("not in parallel mode")
15151#endif
15152 CALL mp_timestop(handle)
15153 END SUBROUTINE mp_send_dv
15154
15155! **************************************************************************************************
15156!> \brief Send rank-2 data to another process
15157!> \param[in] msg Rank-2 data to send
15158!> \param dest ...
15159!> \param tag ...
15160!> \param comm ...
15161!> \note see mp_send_d
15162! **************************************************************************************************
15163 SUBROUTINE mp_send_dm2(msg, dest, tag, comm)
15164 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
15165 INTEGER, INTENT(IN) :: dest, tag
15166 CLASS(mp_comm_type), INTENT(IN) :: comm
15167
15168 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_dm2'
15169
15170 INTEGER :: handle
15171#if defined(__parallel)
15172 INTEGER :: ierr, msglen
15173#endif
15174
15175 CALL mp_timeset(routinen, handle)
15176
15177#if defined(__parallel)
15178 msglen = SIZE(msg)
15179 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15180 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15181 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15182#else
15183 mark_used(msg)
15184 mark_used(dest)
15185 mark_used(tag)
15186 mark_used(comm)
15187 ! only defined in parallel
15188 cpabort("not in parallel mode")
15189#endif
15190 CALL mp_timestop(handle)
15191 END SUBROUTINE mp_send_dm2
15192
15193! **************************************************************************************************
15194!> \brief Send rank-3 data to another process
15195!> \param[in] msg Rank-3 data to send
15196!> \param dest ...
15197!> \param tag ...
15198!> \param comm ...
15199!> \note see mp_send_d
15200! **************************************************************************************************
15201 SUBROUTINE mp_send_dm3(msg, dest, tag, comm)
15202 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
15203 INTEGER, INTENT(IN) :: dest, tag
15204 CLASS(mp_comm_type), INTENT(IN) :: comm
15205
15206 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
15207
15208 INTEGER :: handle
15209#if defined(__parallel)
15210 INTEGER :: ierr, msglen
15211#endif
15212
15213 CALL mp_timeset(routinen, handle)
15214
15215#if defined(__parallel)
15216 msglen = SIZE(msg)
15217 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15218 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15219 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15220#else
15221 mark_used(msg)
15222 mark_used(dest)
15223 mark_used(tag)
15224 mark_used(comm)
15225 ! only defined in parallel
15226 cpabort("not in parallel mode")
15227#endif
15228 CALL mp_timestop(handle)
15229 END SUBROUTINE mp_send_dm3
15230
15231! **************************************************************************************************
15232!> \brief Receive one datum from another process
15233!> \param[in,out] msg Place received data into this variable
15234!> \param[in,out] source Process to receive from
15235!> \param[in,out] tag Transfer identifier
15236!> \param[in] comm Message passing environment identifier
15237!> \par MPI mapping
15238!> mpi_send
15239! **************************************************************************************************
15240 SUBROUTINE mp_recv_d (msg, source, tag, comm)
15241 REAL(kind=real_8), INTENT(INOUT) :: msg
15242 INTEGER, INTENT(INOUT) :: source, tag
15243 CLASS(mp_comm_type), INTENT(IN) :: comm
15244
15245 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_d'
15246
15247 INTEGER :: handle
15248#if defined(__parallel)
15249 INTEGER :: ierr, msglen
15250 mpi_status_type :: status
15251#endif
15252
15253 CALL mp_timeset(routinen, handle)
15254
15255#if defined(__parallel)
15256 msglen = 1
15257 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15258 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15259 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15260 ELSE
15261 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15262 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15263 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15264 source = status mpi_status_extract(mpi_source)
15265 tag = status mpi_status_extract(mpi_tag)
15266 END IF
15267#else
15268 mark_used(msg)
15269 mark_used(source)
15270 mark_used(tag)
15271 mark_used(comm)
15272 ! only defined in parallel
15273 cpabort("not in parallel mode")
15274#endif
15275 CALL mp_timestop(handle)
15276 END SUBROUTINE mp_recv_d
15277
15278! **************************************************************************************************
15279!> \brief Receive rank-1 data from another process
15280!> \param[in,out] msg Place received data into this rank-1 array
15281!> \param source ...
15282!> \param tag ...
15283!> \param comm ...
15284!> \note see mp_recv_d
15285! **************************************************************************************************
15286 SUBROUTINE mp_recv_dv(msg, source, tag, comm)
15287 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15288 INTEGER, INTENT(INOUT) :: source, tag
15289 CLASS(mp_comm_type), INTENT(IN) :: comm
15290
15291 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dv'
15292
15293 INTEGER :: handle
15294#if defined(__parallel)
15295 INTEGER :: ierr, msglen
15296 mpi_status_type :: status
15297#endif
15298
15299 CALL mp_timeset(routinen, handle)
15300
15301#if defined(__parallel)
15302 msglen = SIZE(msg)
15303 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15304 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15305 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15306 ELSE
15307 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15308 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15309 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15310 source = status mpi_status_extract(mpi_source)
15311 tag = status mpi_status_extract(mpi_tag)
15312 END IF
15313#else
15314 mark_used(msg)
15315 mark_used(source)
15316 mark_used(tag)
15317 mark_used(comm)
15318 ! only defined in parallel
15319 cpabort("not in parallel mode")
15320#endif
15321 CALL mp_timestop(handle)
15322 END SUBROUTINE mp_recv_dv
15323
15324! **************************************************************************************************
15325!> \brief Receive rank-2 data from another process
15326!> \param[in,out] msg Place received data into this rank-2 array
15327!> \param source ...
15328!> \param tag ...
15329!> \param comm ...
15330!> \note see mp_recv_d
15331! **************************************************************************************************
15332 SUBROUTINE mp_recv_dm2(msg, source, tag, comm)
15333 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15334 INTEGER, INTENT(INOUT) :: source, tag
15335 CLASS(mp_comm_type), INTENT(IN) :: comm
15336
15337 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dm2'
15338
15339 INTEGER :: handle
15340#if defined(__parallel)
15341 INTEGER :: ierr, msglen
15342 mpi_status_type :: status
15343#endif
15344
15345 CALL mp_timeset(routinen, handle)
15346
15347#if defined(__parallel)
15348 msglen = SIZE(msg)
15349 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15350 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15351 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15352 ELSE
15353 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15354 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15355 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15356 source = status mpi_status_extract(mpi_source)
15357 tag = status mpi_status_extract(mpi_tag)
15358 END IF
15359#else
15360 mark_used(msg)
15361 mark_used(source)
15362 mark_used(tag)
15363 mark_used(comm)
15364 ! only defined in parallel
15365 cpabort("not in parallel mode")
15366#endif
15367 CALL mp_timestop(handle)
15368 END SUBROUTINE mp_recv_dm2
15369
15370! **************************************************************************************************
15371!> \brief Receive rank-3 data from another process
15372!> \param[in,out] msg Place received data into this rank-3 array
15373!> \param source ...
15374!> \param tag ...
15375!> \param comm ...
15376!> \note see mp_recv_d
15377! **************************************************************************************************
15378 SUBROUTINE mp_recv_dm3(msg, source, tag, comm)
15379 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
15380 INTEGER, INTENT(INOUT) :: source, tag
15381 CLASS(mp_comm_type), INTENT(IN) :: comm
15382
15383 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dm3'
15384
15385 INTEGER :: handle
15386#if defined(__parallel)
15387 INTEGER :: ierr, msglen
15388 mpi_status_type :: status
15389#endif
15390
15391 CALL mp_timeset(routinen, handle)
15392
15393#if defined(__parallel)
15394 msglen = SIZE(msg)
15395 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15396 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15397 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15398 ELSE
15399 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15400 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15401 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15402 source = status mpi_status_extract(mpi_source)
15403 tag = status mpi_status_extract(mpi_tag)
15404 END IF
15405#else
15406 mark_used(msg)
15407 mark_used(source)
15408 mark_used(tag)
15409 mark_used(comm)
15410 ! only defined in parallel
15411 cpabort("not in parallel mode")
15412#endif
15413 CALL mp_timestop(handle)
15414 END SUBROUTINE mp_recv_dm3
15415
15416! **************************************************************************************************
15417!> \brief Broadcasts a datum to all processes.
15418!> \param[in] msg Datum to broadcast
15419!> \param[in] source Processes which broadcasts
15420!> \param[in] comm Message passing environment identifier
15421!> \par MPI mapping
15422!> mpi_bcast
15423! **************************************************************************************************
15424 SUBROUTINE mp_bcast_d (msg, source, comm)
15425 REAL(kind=real_8), INTENT(INOUT) :: msg
15426 INTEGER, INTENT(IN) :: source
15427 CLASS(mp_comm_type), INTENT(IN) :: comm
15428
15429 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d'
15430
15431 INTEGER :: handle
15432#if defined(__parallel)
15433 INTEGER :: ierr, msglen
15434#endif
15435
15436 CALL mp_timeset(routinen, handle)
15437
15438#if defined(__parallel)
15439 msglen = 1
15440 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15441 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15442 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15443#else
15444 mark_used(msg)
15445 mark_used(source)
15446 mark_used(comm)
15447#endif
15448 CALL mp_timestop(handle)
15449 END SUBROUTINE mp_bcast_d
15450
15451! **************************************************************************************************
15452!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
15453!> \param[in] msg Datum to broadcast
15454!> \param[in] comm Message passing environment identifier
15455!> \par MPI mapping
15456!> mpi_bcast
15457! **************************************************************************************************
15458 SUBROUTINE mp_bcast_d_src(msg, comm)
15459 REAL(kind=real_8), INTENT(INOUT) :: msg
15460 CLASS(mp_comm_type), INTENT(IN) :: comm
15461
15462 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d_src'
15463
15464 INTEGER :: handle
15465#if defined(__parallel)
15466 INTEGER :: ierr, msglen
15467#endif
15468
15469 CALL mp_timeset(routinen, handle)
15470
15471#if defined(__parallel)
15472 msglen = 1
15473 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15474 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15475 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15476#else
15477 mark_used(msg)
15478 mark_used(comm)
15479#endif
15480 CALL mp_timestop(handle)
15481 END SUBROUTINE mp_bcast_d_src
15482
15483! **************************************************************************************************
15484!> \brief Broadcasts a datum to all processes.
15485!> \param[in] msg Datum to broadcast
15486!> \param[in] source Processes which broadcasts
15487!> \param[in] comm Message passing environment identifier
15488!> \par MPI mapping
15489!> mpi_bcast
15490! **************************************************************************************************
15491 SUBROUTINE mp_ibcast_d (msg, source, comm, request)
15492 REAL(kind=real_8), INTENT(INOUT) :: msg
15493 INTEGER, INTENT(IN) :: source
15494 CLASS(mp_comm_type), INTENT(IN) :: comm
15495 TYPE(mp_request_type), INTENT(OUT) :: request
15496
15497 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_d'
15498
15499 INTEGER :: handle
15500#if defined(__parallel)
15501 INTEGER :: ierr, msglen
15502#endif
15503
15504 CALL mp_timeset(routinen, handle)
15505
15506#if defined(__parallel)
15507 msglen = 1
15508 CALL mpi_ibcast(msg, msglen, mpi_double_precision, source, comm%handle, request%handle, ierr)
15509 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
15510 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_8_size)
15511#else
15512 mark_used(msg)
15513 mark_used(source)
15514 mark_used(comm)
15515 request = mp_request_null
15516#endif
15517 CALL mp_timestop(handle)
15518 END SUBROUTINE mp_ibcast_d
15519
15520! **************************************************************************************************
15521!> \brief Broadcasts rank-1 data to all processes
15522!> \param[in] msg Data to broadcast
15523!> \param source ...
15524!> \param comm ...
15525!> \note see mp_bcast_d1
15526! **************************************************************************************************
15527 SUBROUTINE mp_bcast_dv(msg, source, comm)
15528 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15529 INTEGER, INTENT(IN) :: source
15530 CLASS(mp_comm_type), INTENT(IN) :: comm
15531
15532 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dv'
15533
15534 INTEGER :: handle
15535#if defined(__parallel)
15536 INTEGER :: ierr, msglen
15537#endif
15538
15539 CALL mp_timeset(routinen, handle)
15540
15541#if defined(__parallel)
15542 msglen = SIZE(msg)
15543 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15544 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15545 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15546#else
15547 mark_used(msg)
15548 mark_used(source)
15549 mark_used(comm)
15550#endif
15551 CALL mp_timestop(handle)
15552 END SUBROUTINE mp_bcast_dv
15553
15554! **************************************************************************************************
15555!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
15556!> \param[in] msg Data to broadcast
15557!> \param comm ...
15558!> \note see mp_bcast_d1
15559! **************************************************************************************************
15560 SUBROUTINE mp_bcast_dv_src(msg, comm)
15561 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15562 CLASS(mp_comm_type), INTENT(IN) :: comm
15563
15564 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dv_src'
15565
15566 INTEGER :: handle
15567#if defined(__parallel)
15568 INTEGER :: ierr, msglen
15569#endif
15570
15571 CALL mp_timeset(routinen, handle)
15572
15573#if defined(__parallel)
15574 msglen = SIZE(msg)
15575 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15576 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15577 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15578#else
15579 mark_used(msg)
15580 mark_used(comm)
15581#endif
15582 CALL mp_timestop(handle)
15583 END SUBROUTINE mp_bcast_dv_src
15584
15585! **************************************************************************************************
15586!> \brief Broadcasts rank-1 data to all processes
15587!> \param[in] msg Data to broadcast
15588!> \param source ...
15589!> \param comm ...
15590!> \note see mp_bcast_d1
15591! **************************************************************************************************
15592 SUBROUTINE mp_ibcast_dv(msg, source, comm, request)
15593 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
15594 INTEGER, INTENT(IN) :: source
15595 CLASS(mp_comm_type), INTENT(IN) :: comm
15596 TYPE(mp_request_type) :: request
15597
15598 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_dv'
15599
15600 INTEGER :: handle
15601#if defined(__parallel)
15602 INTEGER :: ierr, msglen
15603#endif
15604
15605 CALL mp_timeset(routinen, handle)
15606
15607#if defined(__parallel)
15608#if !defined(__GNUC__) || __GNUC__ >= 9
15609 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
15610#endif
15611 msglen = SIZE(msg)
15612 CALL mpi_ibcast(msg, msglen, mpi_double_precision, source, comm%handle, request%handle, ierr)
15613 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
15614 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_8_size)
15615#else
15616 mark_used(msg)
15617 mark_used(source)
15618 mark_used(comm)
15619 request = mp_request_null
15620#endif
15621 CALL mp_timestop(handle)
15622 END SUBROUTINE mp_ibcast_dv
15623
15624! **************************************************************************************************
15625!> \brief Broadcasts rank-2 data to all processes
15626!> \param[in] msg Data to broadcast
15627!> \param source ...
15628!> \param comm ...
15629!> \note see mp_bcast_d1
15630! **************************************************************************************************
15631 SUBROUTINE mp_bcast_dm(msg, source, comm)
15632 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15633 INTEGER, INTENT(IN) :: source
15634 CLASS(mp_comm_type), INTENT(IN) :: comm
15635
15636 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dm'
15637
15638 INTEGER :: handle
15639#if defined(__parallel)
15640 INTEGER :: ierr, msglen
15641#endif
15642
15643 CALL mp_timeset(routinen, handle)
15644
15645#if defined(__parallel)
15646 msglen = SIZE(msg)
15647 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15648 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15649 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15650#else
15651 mark_used(msg)
15652 mark_used(source)
15653 mark_used(comm)
15654#endif
15655 CALL mp_timestop(handle)
15656 END SUBROUTINE mp_bcast_dm
15657
15658! **************************************************************************************************
15659!> \brief Broadcasts rank-2 data to all processes
15660!> \param[in] msg Data to broadcast
15661!> \param source ...
15662!> \param comm ...
15663!> \note see mp_bcast_d1
15664! **************************************************************************************************
15665 SUBROUTINE mp_bcast_dm_src(msg, comm)
15666 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15667 CLASS(mp_comm_type), INTENT(IN) :: comm
15668
15669 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dm_src'
15670
15671 INTEGER :: handle
15672#if defined(__parallel)
15673 INTEGER :: ierr, msglen
15674#endif
15675
15676 CALL mp_timeset(routinen, handle)
15677
15678#if defined(__parallel)
15679 msglen = SIZE(msg)
15680 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15681 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15682 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15683#else
15684 mark_used(msg)
15685 mark_used(comm)
15686#endif
15687 CALL mp_timestop(handle)
15688 END SUBROUTINE mp_bcast_dm_src
15689
15690! **************************************************************************************************
15691!> \brief Broadcasts rank-3 data to all processes
15692!> \param[in] msg Data to broadcast
15693!> \param source ...
15694!> \param comm ...
15695!> \note see mp_bcast_d1
15696! **************************************************************************************************
15697 SUBROUTINE mp_bcast_d3(msg, source, comm)
15698 REAL(kind=real_8), CONTIGUOUS :: msg(:, :, :)
15699 INTEGER, INTENT(IN) :: source
15700 CLASS(mp_comm_type), INTENT(IN) :: comm
15701
15702 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d3'
15703
15704 INTEGER :: handle
15705#if defined(__parallel)
15706 INTEGER :: ierr, msglen
15707#endif
15708
15709 CALL mp_timeset(routinen, handle)
15710
15711#if defined(__parallel)
15712 msglen = SIZE(msg)
15713 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15714 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15715 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15716#else
15717 mark_used(msg)
15718 mark_used(source)
15719 mark_used(comm)
15720#endif
15721 CALL mp_timestop(handle)
15722 END SUBROUTINE mp_bcast_d3
15723
15724! **************************************************************************************************
15725!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
15726!> \param[in] msg Data to broadcast
15727!> \param source ...
15728!> \param comm ...
15729!> \note see mp_bcast_d1
15730! **************************************************************************************************
15731 SUBROUTINE mp_bcast_d3_src(msg, comm)
15732 REAL(kind=real_8), CONTIGUOUS :: msg(:, :, :)
15733 CLASS(mp_comm_type), INTENT(IN) :: comm
15734
15735 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d3_src'
15736
15737 INTEGER :: handle
15738#if defined(__parallel)
15739 INTEGER :: ierr, msglen
15740#endif
15741
15742 CALL mp_timeset(routinen, handle)
15743
15744#if defined(__parallel)
15745 msglen = SIZE(msg)
15746 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15747 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15748 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15749#else
15750 mark_used(msg)
15751 mark_used(comm)
15752#endif
15753 CALL mp_timestop(handle)
15754 END SUBROUTINE mp_bcast_d3_src
15755
15756! **************************************************************************************************
15757!> \brief Sums a datum from all processes with result left on all processes.
15758!> \param[in,out] msg Datum to sum (input) and result (output)
15759!> \param[in] comm Message passing environment identifier
15760!> \par MPI mapping
15761!> mpi_allreduce
15762! **************************************************************************************************
15763 SUBROUTINE mp_sum_d (msg, comm)
15764 REAL(kind=real_8), INTENT(INOUT) :: msg
15765 CLASS(mp_comm_type), INTENT(IN) :: comm
15766
15767 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_d'
15768
15769 INTEGER :: handle
15770#if defined(__parallel)
15771 INTEGER :: ierr, msglen
15772 REAL(kind=real_8) :: res
15773#endif
15774
15775 CALL mp_timeset(routinen, handle)
15776
15777#if defined(__parallel)
15778 msglen = 1
15779 IF (comm%num_pe > 1) THEN
15780 CALL mpi_allreduce(msg, res, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15781 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15782 msg = res
15783 END IF
15784 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15785#else
15786 mark_used(msg)
15787 mark_used(comm)
15788#endif
15789 CALL mp_timestop(handle)
15790 END SUBROUTINE mp_sum_d
15791
15792! **************************************************************************************************
15793!> \brief Element-wise sum of a rank-1 array on all processes.
15794!> \param[in,out] msg Vector to sum and result
15795!> \param comm ...
15796!> \note see mp_sum_d
15797! **************************************************************************************************
15798 SUBROUTINE mp_sum_dv(msg, comm)
15799 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15800 CLASS(mp_comm_type), INTENT(IN) :: comm
15801
15802 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dv'
15803
15804 INTEGER :: handle
15805#if defined(__parallel)
15806 INTEGER :: ierr, msglen
15807 REAL(kind=real_8), ALLOCATABLE :: msgbuf(:)
15808#endif
15809
15810 CALL mp_timeset(routinen, handle)
15811
15812#if defined(__parallel)
15813 msglen = SIZE(msg)
15814 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
15815 ALLOCATE (msgbuf(msglen))
15816 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15817 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15818 msg = msgbuf
15819 END IF
15820 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15821#else
15822 mark_used(msg)
15823 mark_used(comm)
15824#endif
15825 CALL mp_timestop(handle)
15826 END SUBROUTINE mp_sum_dv
15827
15828! **************************************************************************************************
15829!> \brief Element-wise sum of a rank-1 array on all processes.
15830!> \param[in,out] msg Vector to sum and result
15831!> \param comm ...
15832!> \note see mp_sum_d
15833! **************************************************************************************************
15834 SUBROUTINE mp_isum_dv(msg, comm, request)
15835 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
15836 CLASS(mp_comm_type), INTENT(IN) :: comm
15837 TYPE(mp_request_type), INTENT(OUT) :: request
15838
15839 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_dv'
15840
15841 INTEGER :: handle
15842#if defined(__parallel)
15843 INTEGER :: ierr, msglen
15844#endif
15845
15846 CALL mp_timeset(routinen, handle)
15847
15848#if defined(__parallel)
15849#if !defined(__GNUC__) || __GNUC__ >= 9
15850 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
15851#endif
15852 msglen = SIZE(msg)
15853 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
15854 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, request%handle, ierr)
15855 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
15856 ELSE
15857 request = mp_request_null
15858 END IF
15859 CALL add_perf(perf_id=23, count=1, msg_size=msglen*real_8_size)
15860#else
15861 mark_used(msg)
15862 mark_used(comm)
15863 request = mp_request_null
15864#endif
15865 CALL mp_timestop(handle)
15866 END SUBROUTINE mp_isum_dv
15867
15868! **************************************************************************************************
15869!> \brief Element-wise sum of a rank-2 array on all processes.
15870!> \param[in] msg Matrix to sum and result
15871!> \param comm ...
15872!> \note see mp_sum_d
15873! **************************************************************************************************
15874 SUBROUTINE mp_sum_dm(msg, comm)
15875 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15876 CLASS(mp_comm_type), INTENT(IN) :: comm
15877
15878 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm'
15879
15880 INTEGER :: handle
15881#if defined(__parallel)
15882 INTEGER, PARAMETER :: max_msg = 2**25
15883 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
15884 REAL(kind=real_8), ALLOCATABLE :: msgbuf(:)
15885#endif
15886
15887 CALL mp_timeset(routinen, handle)
15888
15889#if defined(__parallel)
15890 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
15891 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
15892 msglensum = 0
15893 DO m1 = lbound(msg, 2), ubound(msg, 2), step
15894 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
15895 msglensum = msglensum + msglen
15896 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
15897 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
15898 ALLOCATE (msgbuf(msglen))
15899 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15900 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15901 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
15902 DEALLOCATE (msgbuf)
15903 END IF
15904 END DO
15905 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_8_size)
15906#else
15907 mark_used(msg)
15908 mark_used(comm)
15909#endif
15910 CALL mp_timestop(handle)
15911 END SUBROUTINE mp_sum_dm
15912
15913! **************************************************************************************************
15914!> \brief Element-wise sum of a rank-3 array on all processes.
15915!> \param[in] msg Array to sum and result
15916!> \param comm ...
15917!> \note see mp_sum_d
15918! **************************************************************************************************
15919 SUBROUTINE mp_sum_dm3(msg, comm)
15920 REAL(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
15921 CLASS(mp_comm_type), INTENT(IN) :: comm
15922
15923 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm3'
15924
15925 INTEGER :: handle
15926#if defined(__parallel)
15927 INTEGER :: ierr, msglen
15928 REAL(kind=real_8), ALLOCATABLE :: msgbuf(:)
15929#endif
15930
15931 CALL mp_timeset(routinen, handle)
15932
15933#if defined(__parallel)
15934 msglen = SIZE(msg)
15935 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
15936 ALLOCATE (msgbuf(msglen))
15937 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15938 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15939 msg = reshape(msgbuf, shape(msg))
15940 END IF
15941 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15942#else
15943 mark_used(msg)
15944 mark_used(comm)
15945#endif
15946 CALL mp_timestop(handle)
15947 END SUBROUTINE mp_sum_dm3
15948
15949! **************************************************************************************************
15950!> \brief Element-wise sum of a rank-4 array on all processes.
15951!> \param[in] msg Array to sum and result
15952!> \param comm ...
15953!> \note see mp_sum_d
15954! **************************************************************************************************
15955 SUBROUTINE mp_sum_dm4(msg, comm)
15956 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
15957 CLASS(mp_comm_type), INTENT(IN) :: comm
15958
15959 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm4'
15960
15961 INTEGER :: handle
15962#if defined(__parallel)
15963 INTEGER :: ierr, msglen
15964 REAL(kind=real_8), ALLOCATABLE :: msgbuf(:)
15965#endif
15966
15967 CALL mp_timeset(routinen, handle)
15968
15969#if defined(__parallel)
15970 msglen = SIZE(msg)
15971 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
15972 ALLOCATE (msgbuf(msglen))
15973 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15974 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15975 msg = reshape(msgbuf, shape(msg))
15976 END IF
15977 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15978#else
15979 mark_used(msg)
15980 mark_used(comm)
15981#endif
15982 CALL mp_timestop(handle)
15983 END SUBROUTINE mp_sum_dm4
15984
15985! **************************************************************************************************
15986!> \brief Element-wise sum of data from all processes with result left only on
15987!> one.
15988!> \param[in,out] msg Vector to sum (input) and (only on process root)
15989!> result (output)
15990!> \param root ...
15991!> \param[in] comm Message passing environment identifier
15992!> \par MPI mapping
15993!> mpi_reduce
15994! **************************************************************************************************
15995 SUBROUTINE mp_sum_root_dv(msg, root, comm)
15996 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15997 INTEGER, INTENT(IN) :: root
15998 CLASS(mp_comm_type), INTENT(IN) :: comm
15999
16000 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_dv'
16001
16002 INTEGER :: handle
16003#if defined(__parallel)
16004 INTEGER :: ierr, m1, msglen, taskid
16005 REAL(kind=real_8), ALLOCATABLE :: res(:)
16006#endif
16007
16008 CALL mp_timeset(routinen, handle)
16009
16010#if defined(__parallel)
16011 msglen = SIZE(msg)
16012 CALL mpi_comm_rank(comm%handle, taskid, ierr)
16013 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
16014 IF (msglen > 0) THEN
16015 m1 = SIZE(msg, 1)
16016 ALLOCATE (res(m1))
16017 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_sum, &
16018 root, comm%handle, ierr)
16019 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
16020 IF (taskid == root) THEN
16021 msg = res
16022 END IF
16023 DEALLOCATE (res)
16024 END IF
16025 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16026#else
16027 mark_used(msg)
16028 mark_used(root)
16029 mark_used(comm)
16030#endif
16031 CALL mp_timestop(handle)
16032 END SUBROUTINE mp_sum_root_dv
16033
16034! **************************************************************************************************
16035!> \brief Element-wise sum of data from all processes with result left only on
16036!> one.
16037!> \param[in,out] msg Matrix to sum (input) and (only on process root)
16038!> result (output)
16039!> \param root ...
16040!> \param comm ...
16041!> \note see mp_sum_root_dv
16042! **************************************************************************************************
16043 SUBROUTINE mp_sum_root_dm(msg, root, comm)
16044 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
16045 INTEGER, INTENT(IN) :: root
16046 CLASS(mp_comm_type), INTENT(IN) :: comm
16047
16048 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
16049
16050 INTEGER :: handle
16051#if defined(__parallel)
16052 INTEGER :: ierr, m1, m2, msglen, taskid
16053 REAL(kind=real_8), ALLOCATABLE :: res(:, :)
16054#endif
16055
16056 CALL mp_timeset(routinen, handle)
16057
16058#if defined(__parallel)
16059 msglen = SIZE(msg)
16060 CALL mpi_comm_rank(comm%handle, taskid, ierr)
16061 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
16062 IF (msglen > 0) THEN
16063 m1 = SIZE(msg, 1)
16064 m2 = SIZE(msg, 2)
16065 ALLOCATE (res(m1, m2))
16066 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_sum, root, comm%handle, ierr)
16067 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
16068 IF (taskid == root) THEN
16069 msg = res
16070 END IF
16071 DEALLOCATE (res)
16072 END IF
16073 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16074#else
16075 mark_used(root)
16076 mark_used(msg)
16077 mark_used(comm)
16078#endif
16079 CALL mp_timestop(handle)
16080 END SUBROUTINE mp_sum_root_dm
16081
16082! **************************************************************************************************
16083!> \brief Partial sum of data from all processes with result on each process.
16084!> \param[in] msg Matrix to sum (input)
16085!> \param[out] res Matrix containing result (output)
16086!> \param[in] comm Message passing environment identifier
16087! **************************************************************************************************
16088 SUBROUTINE mp_sum_partial_dm(msg, res, comm)
16089 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16090 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
16091 CLASS(mp_comm_type), INTENT(IN) :: comm
16092
16093 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_dm'
16094
16095 INTEGER :: handle
16096#if defined(__parallel)
16097 INTEGER :: ierr, msglen, taskid
16098#endif
16099
16100 CALL mp_timeset(routinen, handle)
16101
16102#if defined(__parallel)
16103 msglen = SIZE(msg)
16104 CALL mpi_comm_rank(comm%handle, taskid, ierr)
16105 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
16106 IF (msglen > 0) THEN
16107 CALL mpi_scan(msg, res, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
16108 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
16109 END IF
16110 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16111 ! perf_id is same as for other summation routines
16112#else
16113 res = msg
16114 mark_used(comm)
16115#endif
16116 CALL mp_timestop(handle)
16117 END SUBROUTINE mp_sum_partial_dm
16118
16119! **************************************************************************************************
16120!> \brief Finds the maximum of a datum with the result left on all processes.
16121!> \param[in,out] msg Find maximum among these data (input) and
16122!> maximum (output)
16123!> \param[in] comm Message passing environment identifier
16124!> \par MPI mapping
16125!> mpi_allreduce
16126! **************************************************************************************************
16127 SUBROUTINE mp_max_d (msg, comm)
16128 REAL(kind=real_8), INTENT(INOUT) :: msg
16129 CLASS(mp_comm_type), INTENT(IN) :: comm
16130
16131 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_d'
16132
16133 INTEGER :: handle
16134#if defined(__parallel)
16135 INTEGER :: ierr, msglen
16136 REAL(kind=real_8) :: res
16137#endif
16138
16139 CALL mp_timeset(routinen, handle)
16140
16141#if defined(__parallel)
16142 msglen = 1
16143 IF (comm%num_pe > 1) THEN
16144 CALL mpi_allreduce(msg, res, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
16145 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16146 msg = res
16147 END IF
16148 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16149#else
16150 mark_used(msg)
16151 mark_used(comm)
16152#endif
16153 CALL mp_timestop(handle)
16154 END SUBROUTINE mp_max_d
16155
16156! **************************************************************************************************
16157!> \brief Finds the maximum of a datum with the result left on all processes.
16158!> \param[in,out] msg Find maximum among these data (input) and
16159!> maximum (output)
16160!> \param[in] comm Message passing environment identifier
16161!> \par MPI mapping
16162!> mpi_allreduce
16163! **************************************************************************************************
16164 SUBROUTINE mp_max_root_d (msg, root, comm)
16165 REAL(kind=real_8), INTENT(INOUT) :: msg
16166 INTEGER, INTENT(IN) :: root
16167 CLASS(mp_comm_type), INTENT(IN) :: comm
16168
16169 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_d'
16170
16171 INTEGER :: handle
16172#if defined(__parallel)
16173 INTEGER :: ierr, msglen
16174 REAL(kind=real_8) :: res
16175#endif
16176
16177 CALL mp_timeset(routinen, handle)
16178
16179#if defined(__parallel)
16180 msglen = 1
16181 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_max, root, comm%handle, ierr)
16182 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
16183 IF (root == comm%mepos) msg = res
16184 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16185#else
16186 mark_used(msg)
16187 mark_used(comm)
16188 mark_used(root)
16189#endif
16190 CALL mp_timestop(handle)
16191 END SUBROUTINE mp_max_root_d
16192
16193! **************************************************************************************************
16194!> \brief Finds the element-wise maximum of a vector with the result left on
16195!> all processes.
16196!> \param[in,out] msg Find maximum among these data (input) and
16197!> maximum (output)
16198!> \param comm ...
16199!> \note see mp_max_d
16200! **************************************************************************************************
16201 SUBROUTINE mp_max_dv(msg, comm)
16202 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
16203 CLASS(mp_comm_type), INTENT(IN) :: comm
16204
16205 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_dv'
16206
16207 INTEGER :: handle
16208#if defined(__parallel)
16209 INTEGER :: ierr, msglen
16210 REAL(kind=real_8), ALLOCATABLE :: msgbuf(:)
16211#endif
16212
16213 CALL mp_timeset(routinen, handle)
16214
16215#if defined(__parallel)
16216 msglen = SIZE(msg)
16217 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
16218 ALLOCATE (msgbuf(msglen))
16219 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
16220 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16221 msg = msgbuf
16222 END IF
16223 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16224#else
16225 mark_used(msg)
16226 mark_used(comm)
16227#endif
16228 CALL mp_timestop(handle)
16229 END SUBROUTINE mp_max_dv
16230
16231! **************************************************************************************************
16232!> \brief Finds the element-wise maximum of a rank2-array with the result left on
16233!> all processes.
16234!> \param[in] msg Matrix - Find maximum among these data (input) and
16235!> maximum (output)
16236!> \param comm ...
16237!> \note see mp_max_d
16238! **************************************************************************************************
16239 SUBROUTINE mp_max_dm(msg, comm)
16240 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
16241 CLASS(mp_comm_type), INTENT(IN) :: comm
16242
16243 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_dm'
16244
16245 INTEGER :: handle
16246#if defined(__parallel)
16247 INTEGER, PARAMETER :: max_msg = 2**25
16248 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
16249 REAL(kind=real_8), ALLOCATABLE :: msgbuf(:)
16250#endif
16251
16252 CALL mp_timeset(routinen, handle)
16253
16254#if defined(__parallel)
16255 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
16256 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
16257 msglensum = 0
16258 DO m1 = lbound(msg, 2), ubound(msg, 2), step
16259 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
16260 msglensum = msglensum + msglen
16261 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
16262 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
16263 ALLOCATE (msgbuf(msglen))
16264 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
16265 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16266 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
16267 DEALLOCATE (msgbuf)
16268 END IF
16269 END DO
16270 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_8_size)
16271#else
16272 mark_used(msg)
16273 mark_used(comm)
16274#endif
16275 CALL mp_timestop(handle)
16276 END SUBROUTINE mp_max_dm
16277
16278! **************************************************************************************************
16279!> \brief Finds the element-wise maximum of a vector with the result left on
16280!> all processes.
16281!> \param[in,out] msg Find maximum among these data (input) and
16282!> maximum (output)
16283!> \param comm ...
16284!> \note see mp_max_d
16285! **************************************************************************************************
16286 SUBROUTINE mp_max_root_dm(msg, root, comm)
16287 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
16288 INTEGER :: root
16289 CLASS(mp_comm_type), INTENT(IN) :: comm
16290
16291 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_dm'
16292
16293 INTEGER :: handle
16294#if defined(__parallel)
16295 INTEGER :: ierr, msglen
16296 REAL(kind=real_8) :: res(SIZE(msg, 1), SIZE(msg, 2))
16297#endif
16298
16299 CALL mp_timeset(routinen, handle)
16300
16301#if defined(__parallel)
16302 msglen = SIZE(msg)
16303 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_max, root, comm%handle, ierr)
16304 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16305 IF (root == comm%mepos) msg = res
16306 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16307#else
16308 mark_used(msg)
16309 mark_used(comm)
16310 mark_used(root)
16311#endif
16312 CALL mp_timestop(handle)
16313 END SUBROUTINE mp_max_root_dm
16314
16315! **************************************************************************************************
16316!> \brief Finds the minimum of a datum with the result left on all processes.
16317!> \param[in,out] msg Find minimum among these data (input) and
16318!> maximum (output)
16319!> \param[in] comm Message passing environment identifier
16320!> \par MPI mapping
16321!> mpi_allreduce
16322! **************************************************************************************************
16323 SUBROUTINE mp_min_d (msg, comm)
16324 REAL(kind=real_8), INTENT(INOUT) :: msg
16325 CLASS(mp_comm_type), INTENT(IN) :: comm
16326
16327 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_d'
16328
16329 INTEGER :: handle
16330#if defined(__parallel)
16331 INTEGER :: ierr, msglen
16332 REAL(kind=real_8) :: res
16333#endif
16334
16335 CALL mp_timeset(routinen, handle)
16336
16337#if defined(__parallel)
16338 msglen = 1
16339 IF (comm%num_pe > 1) THEN
16340 CALL mpi_allreduce(msg, res, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
16341 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16342 msg = res
16343 END IF
16344 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16345#else
16346 mark_used(msg)
16347 mark_used(comm)
16348#endif
16349 CALL mp_timestop(handle)
16350 END SUBROUTINE mp_min_d
16351
16352! **************************************************************************************************
16353!> \brief Finds the element-wise minimum of vector with the result left on
16354!> all processes.
16355!> \param[in,out] msg Find minimum among these data (input) and
16356!> maximum (output)
16357!> \param comm ...
16358!> \par MPI mapping
16359!> mpi_allreduce
16360!> \note see mp_min_d
16361! **************************************************************************************************
16362 SUBROUTINE mp_min_dv(msg, comm)
16363 REAL(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
16364 CLASS(mp_comm_type), INTENT(IN) :: comm
16365
16366 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_dv'
16367
16368 INTEGER :: handle
16369#if defined(__parallel)
16370 INTEGER :: ierr, msglen
16371 REAL(kind=real_8), ALLOCATABLE :: msgbuf(:)
16372#endif
16373
16374 CALL mp_timeset(routinen, handle)
16375
16376#if defined(__parallel)
16377 msglen = SIZE(msg)
16378 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
16379 ALLOCATE (msgbuf(msglen))
16380 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
16381 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16382 msg = msgbuf
16383 END IF
16384 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16385#else
16386 mark_used(msg)
16387 mark_used(comm)
16388#endif
16389 CALL mp_timestop(handle)
16390 END SUBROUTINE mp_min_dv
16391
16392! **************************************************************************************************
16393!> \brief Finds the element-wise minimum of a rank2-array with the result left on
16394!> all processes.
16395!> \param[in] msg Matrix - Find maximum among these data (input) and
16396!> minimum (output)
16397!> \param comm ...
16398!> \note see mp_min_d
16399! **************************************************************************************************
16400 SUBROUTINE mp_min_dm(msg, comm)
16401 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
16402 CLASS(mp_comm_type), INTENT(IN) :: comm
16403
16404 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_dm'
16405
16406 INTEGER :: handle
16407#if defined(__parallel)
16408 INTEGER, PARAMETER :: max_msg = 2**25
16409 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
16410 REAL(kind=real_8), ALLOCATABLE :: msgbuf(:)
16411#endif
16412
16413 CALL mp_timeset(routinen, handle)
16414
16415#if defined(__parallel)
16416 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
16417 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
16418 msglensum = 0
16419 DO m1 = lbound(msg, 2), ubound(msg, 2), step
16420 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
16421 msglensum = msglensum + msglen
16422 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
16423 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
16424 ALLOCATE (msgbuf(msglen))
16425 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
16426 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16427 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
16428 DEALLOCATE (msgbuf)
16429 END IF
16430 END DO
16431 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_8_size)
16432#else
16433 mark_used(msg)
16434 mark_used(comm)
16435#endif
16436 CALL mp_timestop(handle)
16437 END SUBROUTINE mp_min_dm
16438
16439! **************************************************************************************************
16440!> \brief Multiplies a set of numbers scattered across a number of processes,
16441!> then replicates the result.
16442!> \param[in,out] msg a number to multiply (input) and result (output)
16443!> \param[in] comm message passing environment identifier
16444!> \par MPI mapping
16445!> mpi_allreduce
16446! **************************************************************************************************
16447 SUBROUTINE mp_prod_d (msg, comm)
16448 REAL(kind=real_8), INTENT(INOUT) :: msg
16449 CLASS(mp_comm_type), INTENT(IN) :: comm
16450
16451 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_d'
16452
16453 INTEGER :: handle
16454#if defined(__parallel)
16455 INTEGER :: ierr, msglen
16456 REAL(kind=real_8) :: res
16457#endif
16458
16459 CALL mp_timeset(routinen, handle)
16460
16461#if defined(__parallel)
16462 msglen = 1
16463 IF (comm%num_pe > 1) THEN
16464 CALL mpi_allreduce(msg, res, msglen, mpi_double_precision, mpi_prod, comm%handle, ierr)
16465 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16466 msg = res
16467 END IF
16468 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16469#else
16470 mark_used(msg)
16471 mark_used(comm)
16472#endif
16473 CALL mp_timestop(handle)
16474 END SUBROUTINE mp_prod_d
16475
16476! **************************************************************************************************
16477!> \brief Scatters data from one processes to all others
16478!> \param[in] msg_scatter Data to scatter (for root process)
16479!> \param[out] msg Received data
16480!> \param[in] root Process which scatters data
16481!> \param[in] comm Message passing environment identifier
16482!> \par MPI mapping
16483!> mpi_scatter
16484! **************************************************************************************************
16485 SUBROUTINE mp_scatter_dv(msg_scatter, msg, root, comm)
16486 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
16487 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
16488 INTEGER, INTENT(IN) :: root
16489 CLASS(mp_comm_type), INTENT(IN) :: comm
16490
16491 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_dv'
16492
16493 INTEGER :: handle
16494#if defined(__parallel)
16495 INTEGER :: ierr, msglen
16496#endif
16497
16498 CALL mp_timeset(routinen, handle)
16499
16500#if defined(__parallel)
16501 msglen = SIZE(msg)
16502 CALL mpi_scatter(msg_scatter, msglen, mpi_double_precision, msg, &
16503 msglen, mpi_double_precision, root, comm%handle, ierr)
16504 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
16505 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16506#else
16507 mark_used(root)
16508 mark_used(comm)
16509 msg = msg_scatter
16510#endif
16511 CALL mp_timestop(handle)
16512 END SUBROUTINE mp_scatter_dv
16513
16514! **************************************************************************************************
16515!> \brief Scatters data from one processes to all others
16516!> \param[in] msg_scatter Data to scatter (for root process)
16517!> \param[in] root Process which scatters data
16518!> \param[in] comm Message passing environment identifier
16519!> \par MPI mapping
16520!> mpi_scatter
16521! **************************************************************************************************
16522 SUBROUTINE mp_iscatter_d (msg_scatter, msg, root, comm, request)
16523 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:)
16524 REAL(kind=real_8), INTENT(INOUT) :: msg
16525 INTEGER, INTENT(IN) :: root
16526 CLASS(mp_comm_type), INTENT(IN) :: comm
16527 TYPE(mp_request_type), INTENT(OUT) :: request
16528
16529 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_d'
16530
16531 INTEGER :: handle
16532#if defined(__parallel)
16533 INTEGER :: ierr, msglen
16534#endif
16535
16536 CALL mp_timeset(routinen, handle)
16537
16538#if defined(__parallel)
16539#if !defined(__GNUC__) || __GNUC__ >= 9
16540 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
16541#endif
16542 msglen = 1
16543 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_precision, msg, &
16544 msglen, mpi_double_precision, root, comm%handle, request%handle, ierr)
16545 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
16546 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16547#else
16548 mark_used(root)
16549 mark_used(comm)
16550 msg = msg_scatter(1)
16551 request = mp_request_null
16552#endif
16553 CALL mp_timestop(handle)
16554 END SUBROUTINE mp_iscatter_d
16555
16556! **************************************************************************************************
16557!> \brief Scatters data from one processes to all others
16558!> \param[in] msg_scatter Data to scatter (for root process)
16559!> \param[in] root Process which scatters data
16560!> \param[in] comm Message passing environment identifier
16561!> \par MPI mapping
16562!> mpi_scatter
16563! **************************************************************************************************
16564 SUBROUTINE mp_iscatter_dv2(msg_scatter, msg, root, comm, request)
16565 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:, :)
16566 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
16567 INTEGER, INTENT(IN) :: root
16568 CLASS(mp_comm_type), INTENT(IN) :: comm
16569 TYPE(mp_request_type), INTENT(OUT) :: request
16570
16571 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_dv2'
16572
16573 INTEGER :: handle
16574#if defined(__parallel)
16575 INTEGER :: ierr, msglen
16576#endif
16577
16578 CALL mp_timeset(routinen, handle)
16579
16580#if defined(__parallel)
16581#if !defined(__GNUC__) || __GNUC__ >= 9
16582 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
16583#endif
16584 msglen = SIZE(msg)
16585 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_precision, msg, &
16586 msglen, mpi_double_precision, root, comm%handle, request%handle, ierr)
16587 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
16588 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16589#else
16590 mark_used(root)
16591 mark_used(comm)
16592 msg(:) = msg_scatter(:, 1)
16593 request = mp_request_null
16594#endif
16595 CALL mp_timestop(handle)
16596 END SUBROUTINE mp_iscatter_dv2
16597
16598! **************************************************************************************************
16599!> \brief Scatters data from one processes to all others
16600!> \param[in] msg_scatter Data to scatter (for root process)
16601!> \param[in] root Process which scatters data
16602!> \param[in] comm Message passing environment identifier
16603!> \par MPI mapping
16604!> mpi_scatter
16605! **************************************************************************************************
16606 SUBROUTINE mp_iscatterv_dv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
16607 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:)
16608 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
16609 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
16610 INTEGER, INTENT(IN) :: recvcount, root
16611 CLASS(mp_comm_type), INTENT(IN) :: comm
16612 TYPE(mp_request_type), INTENT(OUT) :: request
16613
16614 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_dv'
16615
16616 INTEGER :: handle
16617#if defined(__parallel)
16618 INTEGER :: ierr
16619#endif
16620
16621 CALL mp_timeset(routinen, handle)
16622
16623#if defined(__parallel)
16624#if !defined(__GNUC__) || __GNUC__ >= 9
16625 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
16626 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
16627 cpassert(is_contiguous(sendcounts) .OR. SIZE(sendcounts) == 0)
16628 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
16629#endif
16630 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_double_precision, msg, &
16631 recvcount, mpi_double_precision, root, comm%handle, request%handle, ierr)
16632 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
16633 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16634#else
16635 mark_used(sendcounts)
16636 mark_used(displs)
16637 mark_used(recvcount)
16638 mark_used(root)
16639 mark_used(comm)
16640 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
16641 request = mp_request_null
16642#endif
16643 CALL mp_timestop(handle)
16644 END SUBROUTINE mp_iscatterv_dv
16645
16646! **************************************************************************************************
16647!> \brief Gathers a datum from all processes to one
16648!> \param[in] msg Datum to send to root
16649!> \param[out] msg_gather Received data (on root)
16650!> \param[in] root Process which gathers the data
16651!> \param[in] comm Message passing environment identifier
16652!> \par MPI mapping
16653!> mpi_gather
16654! **************************************************************************************************
16655 SUBROUTINE mp_gather_d (msg, msg_gather, root, comm)
16656 REAL(kind=real_8), INTENT(IN) :: msg
16657 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16658 INTEGER, INTENT(IN) :: root
16659 CLASS(mp_comm_type), INTENT(IN) :: comm
16660
16661 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_d'
16662
16663 INTEGER :: handle
16664#if defined(__parallel)
16665 INTEGER :: ierr, msglen
16666#endif
16667
16668 CALL mp_timeset(routinen, handle)
16669
16670#if defined(__parallel)
16671 msglen = 1
16672 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16673 msglen, mpi_double_precision, root, comm%handle, ierr)
16674 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16675 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16676#else
16677 mark_used(root)
16678 mark_used(comm)
16679 msg_gather(1) = msg
16680#endif
16681 CALL mp_timestop(handle)
16682 END SUBROUTINE mp_gather_d
16683
16684! **************************************************************************************************
16685!> \brief Gathers a datum from all processes to one, uses the source process of comm
16686!> \param[in] msg Datum to send to root
16687!> \param[out] msg_gather Received data (on root)
16688!> \param[in] comm Message passing environment identifier
16689!> \par MPI mapping
16690!> mpi_gather
16691! **************************************************************************************************
16692 SUBROUTINE mp_gather_d_src(msg, msg_gather, comm)
16693 REAL(kind=real_8), INTENT(IN) :: msg
16694 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16695 CLASS(mp_comm_type), INTENT(IN) :: comm
16696
16697 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_d_src'
16698
16699 INTEGER :: handle
16700#if defined(__parallel)
16701 INTEGER :: ierr, msglen
16702#endif
16703
16704 CALL mp_timeset(routinen, handle)
16705
16706#if defined(__parallel)
16707 msglen = 1
16708 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16709 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16710 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16711 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16712#else
16713 mark_used(comm)
16714 msg_gather(1) = msg
16715#endif
16716 CALL mp_timestop(handle)
16717 END SUBROUTINE mp_gather_d_src
16718
16719! **************************************************************************************************
16720!> \brief Gathers data from all processes to one
16721!> \param[in] msg Datum to send to root
16722!> \param msg_gather ...
16723!> \param root ...
16724!> \param comm ...
16725!> \par Data length
16726!> All data (msg) is equal-sized
16727!> \par MPI mapping
16728!> mpi_gather
16729!> \note see mp_gather_d
16730! **************************************************************************************************
16731 SUBROUTINE mp_gather_dv(msg, msg_gather, root, comm)
16732 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
16733 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16734 INTEGER, INTENT(IN) :: root
16735 CLASS(mp_comm_type), INTENT(IN) :: comm
16736
16737 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dv'
16738
16739 INTEGER :: handle
16740#if defined(__parallel)
16741 INTEGER :: ierr, msglen
16742#endif
16743
16744 CALL mp_timeset(routinen, handle)
16745
16746#if defined(__parallel)
16747 msglen = SIZE(msg)
16748 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16749 msglen, mpi_double_precision, root, comm%handle, ierr)
16750 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16751 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16752#else
16753 mark_used(root)
16754 mark_used(comm)
16755 msg_gather = msg
16756#endif
16757 CALL mp_timestop(handle)
16758 END SUBROUTINE mp_gather_dv
16759
16760! **************************************************************************************************
16761!> \brief Gathers data from all processes to one. Gathers from comm%source
16762!> \param[in] msg Datum to send to root
16763!> \param msg_gather ...
16764!> \param comm ...
16765!> \par Data length
16766!> All data (msg) is equal-sized
16767!> \par MPI mapping
16768!> mpi_gather
16769!> \note see mp_gather_d
16770! **************************************************************************************************
16771 SUBROUTINE mp_gather_dv_src(msg, msg_gather, comm)
16772 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
16773 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16774 CLASS(mp_comm_type), INTENT(IN) :: comm
16775
16776 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dv_src'
16777
16778 INTEGER :: handle
16779#if defined(__parallel)
16780 INTEGER :: ierr, msglen
16781#endif
16782
16783 CALL mp_timeset(routinen, handle)
16784
16785#if defined(__parallel)
16786 msglen = SIZE(msg)
16787 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16788 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16789 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16790 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16791#else
16792 mark_used(comm)
16793 msg_gather = msg
16794#endif
16795 CALL mp_timestop(handle)
16796 END SUBROUTINE mp_gather_dv_src
16797
16798! **************************************************************************************************
16799!> \brief Gathers data from all processes to one
16800!> \param[in] msg Datum to send to root
16801!> \param msg_gather ...
16802!> \param root ...
16803!> \param comm ...
16804!> \par Data length
16805!> All data (msg) is equal-sized
16806!> \par MPI mapping
16807!> mpi_gather
16808!> \note see mp_gather_d
16809! **************************************************************************************************
16810 SUBROUTINE mp_gather_dm(msg, msg_gather, root, comm)
16811 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16812 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
16813 INTEGER, INTENT(IN) :: root
16814 CLASS(mp_comm_type), INTENT(IN) :: comm
16815
16816 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dm'
16817
16818 INTEGER :: handle
16819#if defined(__parallel)
16820 INTEGER :: ierr, msglen
16821#endif
16822
16823 CALL mp_timeset(routinen, handle)
16824
16825#if defined(__parallel)
16826 msglen = SIZE(msg)
16827 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16828 msglen, mpi_double_precision, root, comm%handle, ierr)
16829 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16830 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16831#else
16832 mark_used(root)
16833 mark_used(comm)
16834 msg_gather = msg
16835#endif
16836 CALL mp_timestop(handle)
16837 END SUBROUTINE mp_gather_dm
16838
16839! **************************************************************************************************
16840!> \brief Gathers data from all processes to one. Gathers from comm%source
16841!> \param[in] msg Datum to send to root
16842!> \param msg_gather ...
16843!> \param comm ...
16844!> \par Data length
16845!> All data (msg) is equal-sized
16846!> \par MPI mapping
16847!> mpi_gather
16848!> \note see mp_gather_d
16849! **************************************************************************************************
16850 SUBROUTINE mp_gather_dm_src(msg, msg_gather, comm)
16851 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16852 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
16853 CLASS(mp_comm_type), INTENT(IN) :: comm
16854
16855 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dm_src'
16856
16857 INTEGER :: handle
16858#if defined(__parallel)
16859 INTEGER :: ierr, msglen
16860#endif
16861
16862 CALL mp_timeset(routinen, handle)
16863
16864#if defined(__parallel)
16865 msglen = SIZE(msg)
16866 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16867 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16868 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16869 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16870#else
16871 mark_used(comm)
16872 msg_gather = msg
16873#endif
16874 CALL mp_timestop(handle)
16875 END SUBROUTINE mp_gather_dm_src
16876
16877! **************************************************************************************************
16878!> \brief Gathers data from all processes to one.
16879!> \param[in] sendbuf Data to send to root
16880!> \param[out] recvbuf Received data (on root)
16881!> \param[in] recvcounts Sizes of data received from processes
16882!> \param[in] displs Offsets of data received from processes
16883!> \param[in] root Process which gathers the data
16884!> \param[in] comm Message passing environment identifier
16885!> \par Data length
16886!> Data can have different lengths
16887!> \par Offsets
16888!> Offsets start at 0
16889!> \par MPI mapping
16890!> mpi_gather
16891! **************************************************************************************************
16892 SUBROUTINE mp_gatherv_dv(sendbuf, recvbuf, recvcounts, displs, root, comm)
16893
16894 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
16895 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
16896 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16897 INTEGER, INTENT(IN) :: root
16898 CLASS(mp_comm_type), INTENT(IN) :: comm
16899
16900 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dv'
16901
16902 INTEGER :: handle
16903#if defined(__parallel)
16904 INTEGER :: ierr, sendcount
16905#endif
16906
16907 CALL mp_timeset(routinen, handle)
16908
16909#if defined(__parallel)
16910 sendcount = SIZE(sendbuf)
16911 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16912 recvbuf, recvcounts, displs, mpi_double_precision, &
16913 root, comm%handle, ierr)
16914 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16915 CALL add_perf(perf_id=4, &
16916 count=1, &
16917 msg_size=sendcount*real_8_size)
16918#else
16919 mark_used(recvcounts)
16920 mark_used(root)
16921 mark_used(comm)
16922 recvbuf(1 + displs(1):) = sendbuf
16923#endif
16924 CALL mp_timestop(handle)
16925 END SUBROUTINE mp_gatherv_dv
16926
16927! **************************************************************************************************
16928!> \brief Gathers data from all processes to one. Gathers from comm%source
16929!> \param[in] sendbuf Data to send to root
16930!> \param[out] recvbuf Received data (on root)
16931!> \param[in] recvcounts Sizes of data received from processes
16932!> \param[in] displs Offsets of data received from processes
16933!> \param[in] comm Message passing environment identifier
16934!> \par Data length
16935!> Data can have different lengths
16936!> \par Offsets
16937!> Offsets start at 0
16938!> \par MPI mapping
16939!> mpi_gather
16940! **************************************************************************************************
16941 SUBROUTINE mp_gatherv_dv_src(sendbuf, recvbuf, recvcounts, displs, comm)
16942
16943 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
16944 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
16945 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16946 CLASS(mp_comm_type), INTENT(IN) :: comm
16947
16948 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dv_src'
16949
16950 INTEGER :: handle
16951#if defined(__parallel)
16952 INTEGER :: ierr, sendcount
16953#endif
16954
16955 CALL mp_timeset(routinen, handle)
16956
16957#if defined(__parallel)
16958 sendcount = SIZE(sendbuf)
16959 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16960 recvbuf, recvcounts, displs, mpi_double_precision, &
16961 comm%source, comm%handle, ierr)
16962 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16963 CALL add_perf(perf_id=4, &
16964 count=1, &
16965 msg_size=sendcount*real_8_size)
16966#else
16967 mark_used(recvcounts)
16968 mark_used(comm)
16969 recvbuf(1 + displs(1):) = sendbuf
16970#endif
16971 CALL mp_timestop(handle)
16972 END SUBROUTINE mp_gatherv_dv_src
16973
16974! **************************************************************************************************
16975!> \brief Gathers data from all processes to one.
16976!> \param[in] sendbuf Data to send to root
16977!> \param[out] recvbuf Received data (on root)
16978!> \param[in] recvcounts Sizes of data received from processes
16979!> \param[in] displs Offsets of data received from processes
16980!> \param[in] root Process which gathers the data
16981!> \param[in] comm Message passing environment identifier
16982!> \par Data length
16983!> Data can have different lengths
16984!> \par Offsets
16985!> Offsets start at 0
16986!> \par MPI mapping
16987!> mpi_gather
16988! **************************************************************************************************
16989 SUBROUTINE mp_gatherv_dm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
16990
16991 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
16992 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
16993 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16994 INTEGER, INTENT(IN) :: root
16995 CLASS(mp_comm_type), INTENT(IN) :: comm
16996
16997 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dm2'
16998
16999 INTEGER :: handle
17000#if defined(__parallel)
17001 INTEGER :: ierr, sendcount
17002#endif
17003
17004 CALL mp_timeset(routinen, handle)
17005
17006#if defined(__parallel)
17007 sendcount = SIZE(sendbuf)
17008 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
17009 recvbuf, recvcounts, displs, mpi_double_precision, &
17010 root, comm%handle, ierr)
17011 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
17012 CALL add_perf(perf_id=4, &
17013 count=1, &
17014 msg_size=sendcount*real_8_size)
17015#else
17016 mark_used(recvcounts)
17017 mark_used(root)
17018 mark_used(comm)
17019 recvbuf(:, 1 + displs(1):) = sendbuf
17020#endif
17021 CALL mp_timestop(handle)
17022 END SUBROUTINE mp_gatherv_dm2
17023
17024! **************************************************************************************************
17025!> \brief Gathers data from all processes to one.
17026!> \param[in] sendbuf Data to send to root
17027!> \param[out] recvbuf Received data (on root)
17028!> \param[in] recvcounts Sizes of data received from processes
17029!> \param[in] displs Offsets of data received from processes
17030!> \param[in] comm Message passing environment identifier
17031!> \par Data length
17032!> Data can have different lengths
17033!> \par Offsets
17034!> Offsets start at 0
17035!> \par MPI mapping
17036!> mpi_gather
17037! **************************************************************************************************
17038 SUBROUTINE mp_gatherv_dm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
17039
17040 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
17041 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
17042 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
17043 CLASS(mp_comm_type), INTENT(IN) :: comm
17044
17045 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dm2_src'
17046
17047 INTEGER :: handle
17048#if defined(__parallel)
17049 INTEGER :: ierr, sendcount
17050#endif
17051
17052 CALL mp_timeset(routinen, handle)
17053
17054#if defined(__parallel)
17055 sendcount = SIZE(sendbuf)
17056 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
17057 recvbuf, recvcounts, displs, mpi_double_precision, &
17058 comm%source, comm%handle, ierr)
17059 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
17060 CALL add_perf(perf_id=4, &
17061 count=1, &
17062 msg_size=sendcount*real_8_size)
17063#else
17064 mark_used(recvcounts)
17065 mark_used(comm)
17066 recvbuf(:, 1 + displs(1):) = sendbuf
17067#endif
17068 CALL mp_timestop(handle)
17069 END SUBROUTINE mp_gatherv_dm2_src
17070
17071! **************************************************************************************************
17072!> \brief Gathers data from all processes to one.
17073!> \param[in] sendbuf Data to send to root
17074!> \param[out] recvbuf Received data (on root)
17075!> \param[in] recvcounts Sizes of data received from processes
17076!> \param[in] displs Offsets of data received from processes
17077!> \param[in] root Process which gathers the data
17078!> \param[in] comm Message passing environment identifier
17079!> \par Data length
17080!> Data can have different lengths
17081!> \par Offsets
17082!> Offsets start at 0
17083!> \par MPI mapping
17084!> mpi_gather
17085! **************************************************************************************************
17086 SUBROUTINE mp_igatherv_dv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
17087 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: sendbuf
17088 REAL(kind=real_8), DIMENSION(:), INTENT(OUT) :: recvbuf
17089 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
17090 INTEGER, INTENT(IN) :: sendcount, root
17091 CLASS(mp_comm_type), INTENT(IN) :: comm
17092 TYPE(mp_request_type), INTENT(OUT) :: request
17093
17094 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_dv'
17095
17096 INTEGER :: handle
17097#if defined(__parallel)
17098 INTEGER :: ierr
17099#endif
17100
17101 CALL mp_timeset(routinen, handle)
17102
17103#if defined(__parallel)
17104#if !defined(__GNUC__) || __GNUC__ >= 9
17105 cpassert(is_contiguous(sendbuf) .OR. SIZE(sendbuf) == 0)
17106 cpassert(is_contiguous(recvbuf) .OR. SIZE(recvbuf) == 0)
17107 cpassert(is_contiguous(recvcounts) .OR. SIZE(recvcounts) == 0)
17108 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
17109#endif
17110 CALL mpi_igatherv(sendbuf, sendcount, mpi_double_precision, &
17111 recvbuf, recvcounts, displs, mpi_double_precision, &
17112 root, comm%handle, request%handle, ierr)
17113 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
17114 CALL add_perf(perf_id=24, &
17115 count=1, &
17116 msg_size=sendcount*real_8_size)
17117#else
17118 mark_used(sendcount)
17119 mark_used(recvcounts)
17120 mark_used(root)
17121 mark_used(comm)
17122 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
17123 request = mp_request_null
17124#endif
17125 CALL mp_timestop(handle)
17126 END SUBROUTINE mp_igatherv_dv
17127
17128! **************************************************************************************************
17129!> \brief Gathers a datum from all processes and all processes receive the
17130!> same data
17131!> \param[in] msgout Datum to send
17132!> \param[out] msgin Received data
17133!> \param[in] comm Message passing environment identifier
17134!> \par Data size
17135!> All processes send equal-sized data
17136!> \par MPI mapping
17137!> mpi_allgather
17138! **************************************************************************************************
17139 SUBROUTINE mp_allgather_d (msgout, msgin, comm)
17140 REAL(kind=real_8), INTENT(IN) :: msgout
17141 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
17142 CLASS(mp_comm_type), INTENT(IN) :: comm
17143
17144 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d'
17145
17146 INTEGER :: handle
17147#if defined(__parallel)
17148 INTEGER :: ierr, rcount, scount
17149#endif
17150
17151 CALL mp_timeset(routinen, handle)
17152
17153#if defined(__parallel)
17154 scount = 1
17155 rcount = 1
17156 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17157 msgin, rcount, mpi_double_precision, &
17158 comm%handle, ierr)
17159 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17160#else
17161 mark_used(comm)
17162 msgin = msgout
17163#endif
17164 CALL mp_timestop(handle)
17165 END SUBROUTINE mp_allgather_d
17166
17167! **************************************************************************************************
17168!> \brief Gathers a datum from all processes and all processes receive the
17169!> same data
17170!> \param[in] msgout Datum to send
17171!> \param[out] msgin Received data
17172!> \param[in] comm Message passing environment identifier
17173!> \par Data size
17174!> All processes send equal-sized data
17175!> \par MPI mapping
17176!> mpi_allgather
17177! **************************************************************************************************
17178 SUBROUTINE mp_allgather_d2(msgout, msgin, comm)
17179 REAL(kind=real_8), INTENT(IN) :: msgout
17180 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
17181 CLASS(mp_comm_type), INTENT(IN) :: comm
17182
17183 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d2'
17184
17185 INTEGER :: handle
17186#if defined(__parallel)
17187 INTEGER :: ierr, rcount, scount
17188#endif
17189
17190 CALL mp_timeset(routinen, handle)
17191
17192#if defined(__parallel)
17193 scount = 1
17194 rcount = 1
17195 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17196 msgin, rcount, mpi_double_precision, &
17197 comm%handle, ierr)
17198 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17199#else
17200 mark_used(comm)
17201 msgin = msgout
17202#endif
17203 CALL mp_timestop(handle)
17204 END SUBROUTINE mp_allgather_d2
17205
17206! **************************************************************************************************
17207!> \brief Gathers a datum from all processes and all processes receive the
17208!> same data
17209!> \param[in] msgout Datum to send
17210!> \param[out] msgin Received data
17211!> \param[in] comm Message passing environment identifier
17212!> \par Data size
17213!> All processes send equal-sized data
17214!> \par MPI mapping
17215!> mpi_allgather
17216! **************************************************************************************************
17217 SUBROUTINE mp_iallgather_d (msgout, msgin, comm, request)
17218 REAL(kind=real_8), INTENT(IN) :: msgout
17219 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17220 CLASS(mp_comm_type), INTENT(IN) :: comm
17221 TYPE(mp_request_type), INTENT(OUT) :: request
17222
17223 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d'
17224
17225 INTEGER :: handle
17226#if defined(__parallel)
17227 INTEGER :: ierr, rcount, scount
17228#endif
17229
17230 CALL mp_timeset(routinen, handle)
17231
17232#if defined(__parallel)
17233#if !defined(__GNUC__) || __GNUC__ >= 9
17234 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
17235#endif
17236 scount = 1
17237 rcount = 1
17238 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17239 msgin, rcount, mpi_double_precision, &
17240 comm%handle, request%handle, ierr)
17241 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17242#else
17243 mark_used(comm)
17244 msgin = msgout
17245 request = mp_request_null
17246#endif
17247 CALL mp_timestop(handle)
17248 END SUBROUTINE mp_iallgather_d
17249
17250! **************************************************************************************************
17251!> \brief Gathers vector data from all processes and all processes receive the
17252!> same data
17253!> \param[in] msgout Rank-1 data to send
17254!> \param[out] msgin Received data
17255!> \param[in] comm Message passing environment identifier
17256!> \par Data size
17257!> All processes send equal-sized data
17258!> \par Ranks
17259!> The last rank counts the processes
17260!> \par MPI mapping
17261!> mpi_allgather
17262! **************************************************************************************************
17263 SUBROUTINE mp_allgather_d12(msgout, msgin, comm)
17264 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:)
17265 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
17266 CLASS(mp_comm_type), INTENT(IN) :: comm
17267
17268 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d12'
17269
17270 INTEGER :: handle
17271#if defined(__parallel)
17272 INTEGER :: ierr, rcount, scount
17273#endif
17274
17275 CALL mp_timeset(routinen, handle)
17276
17277#if defined(__parallel)
17278 scount = SIZE(msgout(:))
17279 rcount = scount
17280 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17281 msgin, rcount, mpi_double_precision, &
17282 comm%handle, ierr)
17283 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17284#else
17285 mark_used(comm)
17286 msgin(:, 1) = msgout(:)
17287#endif
17288 CALL mp_timestop(handle)
17289 END SUBROUTINE mp_allgather_d12
17290
17291! **************************************************************************************************
17292!> \brief Gathers matrix data from all processes and all processes receive the
17293!> same data
17294!> \param[in] msgout Rank-2 data to send
17295!> \param msgin ...
17296!> \param comm ...
17297!> \note see mp_allgather_d12
17298! **************************************************************************************************
17299 SUBROUTINE mp_allgather_d23(msgout, msgin, comm)
17300 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
17301 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
17302 CLASS(mp_comm_type), INTENT(IN) :: comm
17303
17304 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d23'
17305
17306 INTEGER :: handle
17307#if defined(__parallel)
17308 INTEGER :: ierr, rcount, scount
17309#endif
17310
17311 CALL mp_timeset(routinen, handle)
17312
17313#if defined(__parallel)
17314 scount = SIZE(msgout(:, :))
17315 rcount = scount
17316 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17317 msgin, rcount, mpi_double_precision, &
17318 comm%handle, ierr)
17319 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17320#else
17321 mark_used(comm)
17322 msgin(:, :, 1) = msgout(:, :)
17323#endif
17324 CALL mp_timestop(handle)
17325 END SUBROUTINE mp_allgather_d23
17326
17327! **************************************************************************************************
17328!> \brief Gathers rank-3 data from all processes and all processes receive the
17329!> same data
17330!> \param[in] msgout Rank-3 data to send
17331!> \param msgin ...
17332!> \param comm ...
17333!> \note see mp_allgather_d12
17334! **************************************************************************************************
17335 SUBROUTINE mp_allgather_d34(msgout, msgin, comm)
17336 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
17337 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
17338 CLASS(mp_comm_type), INTENT(IN) :: comm
17339
17340 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d34'
17341
17342 INTEGER :: handle
17343#if defined(__parallel)
17344 INTEGER :: ierr, rcount, scount
17345#endif
17346
17347 CALL mp_timeset(routinen, handle)
17348
17349#if defined(__parallel)
17350 scount = SIZE(msgout(:, :, :))
17351 rcount = scount
17352 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17353 msgin, rcount, mpi_double_precision, &
17354 comm%handle, ierr)
17355 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17356#else
17357 mark_used(comm)
17358 msgin(:, :, :, 1) = msgout(:, :, :)
17359#endif
17360 CALL mp_timestop(handle)
17361 END SUBROUTINE mp_allgather_d34
17362
17363! **************************************************************************************************
17364!> \brief Gathers rank-2 data from all processes and all processes receive the
17365!> same data
17366!> \param[in] msgout Rank-2 data to send
17367!> \param msgin ...
17368!> \param comm ...
17369!> \note see mp_allgather_d12
17370! **************************************************************************************************
17371 SUBROUTINE mp_allgather_d22(msgout, msgin, comm)
17372 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
17373 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
17374 CLASS(mp_comm_type), INTENT(IN) :: comm
17375
17376 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d22'
17377
17378 INTEGER :: handle
17379#if defined(__parallel)
17380 INTEGER :: ierr, rcount, scount
17381#endif
17382
17383 CALL mp_timeset(routinen, handle)
17384
17385#if defined(__parallel)
17386 scount = SIZE(msgout(:, :))
17387 rcount = scount
17388 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17389 msgin, rcount, mpi_double_precision, &
17390 comm%handle, ierr)
17391 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17392#else
17393 mark_used(comm)
17394 msgin(:, :) = msgout(:, :)
17395#endif
17396 CALL mp_timestop(handle)
17397 END SUBROUTINE mp_allgather_d22
17398
17399! **************************************************************************************************
17400!> \brief Gathers rank-1 data from all processes and all processes receive the
17401!> same data
17402!> \param[in] msgout Rank-1 data to send
17403!> \param msgin ...
17404!> \param comm ...
17405!> \param request ...
17406!> \note see mp_allgather_d11
17407! **************************************************************************************************
17408 SUBROUTINE mp_iallgather_d11(msgout, msgin, comm, request)
17409 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17410 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17411 CLASS(mp_comm_type), INTENT(IN) :: comm
17412 TYPE(mp_request_type), INTENT(OUT) :: request
17413
17414 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d11'
17415
17416 INTEGER :: handle
17417#if defined(__parallel)
17418 INTEGER :: ierr, rcount, scount
17419#endif
17420
17421 CALL mp_timeset(routinen, handle)
17422
17423#if defined(__parallel)
17424#if !defined(__GNUC__) || __GNUC__ >= 9
17425 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
17426 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
17427#endif
17428 scount = SIZE(msgout(:))
17429 rcount = scount
17430 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17431 msgin, rcount, mpi_double_precision, &
17432 comm%handle, request%handle, ierr)
17433 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17434#else
17435 mark_used(comm)
17436 msgin = msgout
17437 request = mp_request_null
17438#endif
17439 CALL mp_timestop(handle)
17440 END SUBROUTINE mp_iallgather_d11
17441
17442! **************************************************************************************************
17443!> \brief Gathers rank-2 data from all processes and all processes receive the
17444!> same data
17445!> \param[in] msgout Rank-2 data to send
17446!> \param msgin ...
17447!> \param comm ...
17448!> \param request ...
17449!> \note see mp_allgather_d12
17450! **************************************************************************************************
17451 SUBROUTINE mp_iallgather_d13(msgout, msgin, comm, request)
17452 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17453 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
17454 CLASS(mp_comm_type), INTENT(IN) :: comm
17455 TYPE(mp_request_type), INTENT(OUT) :: request
17456
17457 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d13'
17458
17459 INTEGER :: handle
17460#if defined(__parallel)
17461 INTEGER :: ierr, rcount, scount
17462#endif
17463
17464 CALL mp_timeset(routinen, handle)
17465
17466#if defined(__parallel)
17467#if !defined(__GNUC__) || __GNUC__ >= 9
17468 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
17469 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
17470#endif
17471
17472 scount = SIZE(msgout(:))
17473 rcount = scount
17474 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17475 msgin, rcount, mpi_double_precision, &
17476 comm%handle, request%handle, ierr)
17477 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17478#else
17479 mark_used(comm)
17480 msgin(:, 1, 1) = msgout(:)
17481 request = mp_request_null
17482#endif
17483 CALL mp_timestop(handle)
17484 END SUBROUTINE mp_iallgather_d13
17485
17486! **************************************************************************************************
17487!> \brief Gathers rank-2 data from all processes and all processes receive the
17488!> same data
17489!> \param[in] msgout Rank-2 data to send
17490!> \param msgin ...
17491!> \param comm ...
17492!> \param request ...
17493!> \note see mp_allgather_d12
17494! **************************************************************************************************
17495 SUBROUTINE mp_iallgather_d22(msgout, msgin, comm, request)
17496 REAL(kind=real_8), INTENT(IN) :: msgout(:, :)
17497 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :)
17498 CLASS(mp_comm_type), INTENT(IN) :: comm
17499 TYPE(mp_request_type), INTENT(OUT) :: request
17500
17501 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d22'
17502
17503 INTEGER :: handle
17504#if defined(__parallel)
17505 INTEGER :: ierr, rcount, scount
17506#endif
17507
17508 CALL mp_timeset(routinen, handle)
17509
17510#if defined(__parallel)
17511#if !defined(__GNUC__) || __GNUC__ >= 9
17512 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
17513 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
17514#endif
17515
17516 scount = SIZE(msgout(:, :))
17517 rcount = scount
17518 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17519 msgin, rcount, mpi_double_precision, &
17520 comm%handle, request%handle, ierr)
17521 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17522#else
17523 mark_used(comm)
17524 msgin(:, :) = msgout(:, :)
17525 request = mp_request_null
17526#endif
17527 CALL mp_timestop(handle)
17528 END SUBROUTINE mp_iallgather_d22
17529
17530! **************************************************************************************************
17531!> \brief Gathers rank-2 data from all processes and all processes receive the
17532!> same data
17533!> \param[in] msgout Rank-2 data to send
17534!> \param msgin ...
17535!> \param comm ...
17536!> \param request ...
17537!> \note see mp_allgather_d12
17538! **************************************************************************************************
17539 SUBROUTINE mp_iallgather_d24(msgout, msgin, comm, request)
17540 REAL(kind=real_8), INTENT(IN) :: msgout(:, :)
17541 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :, :)
17542 CLASS(mp_comm_type), INTENT(IN) :: comm
17543 TYPE(mp_request_type), INTENT(OUT) :: request
17544
17545 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d24'
17546
17547 INTEGER :: handle
17548#if defined(__parallel)
17549 INTEGER :: ierr, rcount, scount
17550#endif
17551
17552 CALL mp_timeset(routinen, handle)
17553
17554#if defined(__parallel)
17555#if !defined(__GNUC__) || __GNUC__ >= 9
17556 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
17557 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
17558#endif
17559
17560 scount = SIZE(msgout(:, :))
17561 rcount = scount
17562 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17563 msgin, rcount, mpi_double_precision, &
17564 comm%handle, request%handle, ierr)
17565 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17566#else
17567 mark_used(comm)
17568 msgin(:, :, 1, 1) = msgout(:, :)
17569 request = mp_request_null
17570#endif
17571 CALL mp_timestop(handle)
17572 END SUBROUTINE mp_iallgather_d24
17573
17574! **************************************************************************************************
17575!> \brief Gathers rank-3 data from all processes and all processes receive the
17576!> same data
17577!> \param[in] msgout Rank-3 data to send
17578!> \param msgin ...
17579!> \param comm ...
17580!> \param request ...
17581!> \note see mp_allgather_d12
17582! **************************************************************************************************
17583 SUBROUTINE mp_iallgather_d33(msgout, msgin, comm, request)
17584 REAL(kind=real_8), INTENT(IN) :: msgout(:, :, :)
17585 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
17586 CLASS(mp_comm_type), INTENT(IN) :: comm
17587 TYPE(mp_request_type), INTENT(OUT) :: request
17588
17589 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d33'
17590
17591 INTEGER :: handle
17592#if defined(__parallel)
17593 INTEGER :: ierr, rcount, scount
17594#endif
17595
17596 CALL mp_timeset(routinen, handle)
17597
17598#if defined(__parallel)
17599#if !defined(__GNUC__) || __GNUC__ >= 9
17600 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
17601 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
17602#endif
17603
17604 scount = SIZE(msgout(:, :, :))
17605 rcount = scount
17606 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17607 msgin, rcount, mpi_double_precision, &
17608 comm%handle, request%handle, ierr)
17609 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17610#else
17611 mark_used(comm)
17612 msgin(:, :, :) = msgout(:, :, :)
17613 request = mp_request_null
17614#endif
17615 CALL mp_timestop(handle)
17616 END SUBROUTINE mp_iallgather_d33
17617
17618! **************************************************************************************************
17619!> \brief Gathers vector data from all processes and all processes receive the
17620!> same data
17621!> \param[in] msgout Rank-1 data to send
17622!> \param[out] msgin Received data
17623!> \param[in] rcount Size of sent data for every process
17624!> \param[in] rdispl Offset of sent data for every process
17625!> \param[in] comm Message passing environment identifier
17626!> \par Data size
17627!> Processes can send different-sized data
17628!> \par Ranks
17629!> The last rank counts the processes
17630!> \par Offsets
17631!> Offsets are from 0
17632!> \par MPI mapping
17633!> mpi_allgather
17634! **************************************************************************************************
17635 SUBROUTINE mp_allgatherv_dv(msgout, msgin, rcount, rdispl, comm)
17636 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
17637 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17638 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17639 CLASS(mp_comm_type), INTENT(IN) :: comm
17640
17641 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_dv'
17642
17643 INTEGER :: handle
17644#if defined(__parallel)
17645 INTEGER :: ierr, scount
17646#endif
17647
17648 CALL mp_timeset(routinen, handle)
17649
17650#if defined(__parallel)
17651 scount = SIZE(msgout)
17652 CALL mpi_allgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17653 rdispl, mpi_double_precision, comm%handle, ierr)
17654 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
17655#else
17656 mark_used(rcount)
17657 mark_used(rdispl)
17658 mark_used(comm)
17659 msgin = msgout
17660#endif
17661 CALL mp_timestop(handle)
17662 END SUBROUTINE mp_allgatherv_dv
17663
17664! **************************************************************************************************
17665!> \brief Gathers vector data from all processes and all processes receive the
17666!> same data
17667!> \param[in] msgout Rank-1 data to send
17668!> \param[out] msgin Received data
17669!> \param[in] rcount Size of sent data for every process
17670!> \param[in] rdispl Offset of sent data for every process
17671!> \param[in] comm Message passing environment identifier
17672!> \par Data size
17673!> Processes can send different-sized data
17674!> \par Ranks
17675!> The last rank counts the processes
17676!> \par Offsets
17677!> Offsets are from 0
17678!> \par MPI mapping
17679!> mpi_allgather
17680! **************************************************************************************************
17681 SUBROUTINE mp_allgatherv_dm2(msgout, msgin, rcount, rdispl, comm)
17682 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
17683 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
17684 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17685 CLASS(mp_comm_type), INTENT(IN) :: comm
17686
17687 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_dv'
17688
17689 INTEGER :: handle
17690#if defined(__parallel)
17691 INTEGER :: ierr, scount
17692#endif
17693
17694 CALL mp_timeset(routinen, handle)
17695
17696#if defined(__parallel)
17697 scount = SIZE(msgout)
17698 CALL mpi_allgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17699 rdispl, mpi_double_precision, comm%handle, ierr)
17700 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
17701#else
17702 mark_used(rcount)
17703 mark_used(rdispl)
17704 mark_used(comm)
17705 msgin = msgout
17706#endif
17707 CALL mp_timestop(handle)
17708 END SUBROUTINE mp_allgatherv_dm2
17709
17710! **************************************************************************************************
17711!> \brief Gathers vector data from all processes and all processes receive the
17712!> same data
17713!> \param[in] msgout Rank-1 data to send
17714!> \param[out] msgin Received data
17715!> \param[in] rcount Size of sent data for every process
17716!> \param[in] rdispl Offset of sent data for every process
17717!> \param[in] comm Message passing environment identifier
17718!> \par Data size
17719!> Processes can send different-sized data
17720!> \par Ranks
17721!> The last rank counts the processes
17722!> \par Offsets
17723!> Offsets are from 0
17724!> \par MPI mapping
17725!> mpi_allgather
17726! **************************************************************************************************
17727 SUBROUTINE mp_iallgatherv_dv(msgout, msgin, rcount, rdispl, comm, request)
17728 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17729 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17730 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17731 CLASS(mp_comm_type), INTENT(IN) :: comm
17732 TYPE(mp_request_type), INTENT(OUT) :: request
17733
17734 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_dv'
17735
17736 INTEGER :: handle
17737#if defined(__parallel)
17738 INTEGER :: ierr, scount, rsize
17739#endif
17740
17741 CALL mp_timeset(routinen, handle)
17742
17743#if defined(__parallel)
17744#if !defined(__GNUC__) || __GNUC__ >= 9
17745 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
17746 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
17747 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
17748 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
17749#endif
17750
17751 scount = SIZE(msgout)
17752 rsize = SIZE(rcount)
17753 CALL mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, &
17754 rdispl, comm, request, ierr)
17755 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
17756#else
17757 mark_used(rcount)
17758 mark_used(rdispl)
17759 mark_used(comm)
17760 msgin = msgout
17761 request = mp_request_null
17762#endif
17763 CALL mp_timestop(handle)
17764 END SUBROUTINE mp_iallgatherv_dv
17765
17766! **************************************************************************************************
17767!> \brief Gathers vector data from all processes and all processes receive the
17768!> same data
17769!> \param[in] msgout Rank-1 data to send
17770!> \param[out] msgin Received data
17771!> \param[in] rcount Size of sent data for every process
17772!> \param[in] rdispl Offset of sent data for every process
17773!> \param[in] comm Message passing environment identifier
17774!> \par Data size
17775!> Processes can send different-sized data
17776!> \par Ranks
17777!> The last rank counts the processes
17778!> \par Offsets
17779!> Offsets are from 0
17780!> \par MPI mapping
17781!> mpi_allgather
17782! **************************************************************************************************
17783 SUBROUTINE mp_iallgatherv_dv2(msgout, msgin, rcount, rdispl, comm, request)
17784 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17785 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17786 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
17787 CLASS(mp_comm_type), INTENT(IN) :: comm
17788 TYPE(mp_request_type), INTENT(OUT) :: request
17789
17790 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_dv2'
17791
17792 INTEGER :: handle
17793#if defined(__parallel)
17794 INTEGER :: ierr, scount, rsize
17795#endif
17796
17797 CALL mp_timeset(routinen, handle)
17798
17799#if defined(__parallel)
17800#if !defined(__GNUC__) || __GNUC__ >= 9
17801 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
17802 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
17803 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
17804 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
17805#endif
17806
17807 scount = SIZE(msgout)
17808 rsize = SIZE(rcount)
17809 CALL mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, &
17810 rdispl, comm, request, ierr)
17811 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
17812#else
17813 mark_used(rcount)
17814 mark_used(rdispl)
17815 mark_used(comm)
17816 msgin = msgout
17817 request = mp_request_null
17818#endif
17819 CALL mp_timestop(handle)
17820 END SUBROUTINE mp_iallgatherv_dv2
17821
17822! **************************************************************************************************
17823!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
17824!> the issue is with the rank of rcount and rdispl
17825!> \param count ...
17826!> \param array_of_requests ...
17827!> \param array_of_statuses ...
17828!> \param ierr ...
17829!> \author Alfio Lazzaro
17830! **************************************************************************************************
17831#if defined(__parallel)
17832 SUBROUTINE mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
17833 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
17834 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17835 INTEGER, INTENT(IN) :: rsize
17836 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
17837 CLASS(mp_comm_type), INTENT(IN) :: comm
17838 TYPE(mp_request_type), INTENT(OUT) :: request
17839 INTEGER, INTENT(INOUT) :: ierr
17840
17841 CALL mpi_iallgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17842 rdispl, mpi_double_precision, comm%handle, request%handle, ierr)
17843
17844 END SUBROUTINE mp_iallgatherv_dv_internal
17845#endif
17846
17847! **************************************************************************************************
17848!> \brief Sums a vector and partitions the result among processes
17849!> \param[in] msgout Data to sum
17850!> \param[out] msgin Received portion of summed data
17851!> \param[in] rcount Partition sizes of the summed data for
17852!> every process
17853!> \param[in] comm Message passing environment identifier
17854! **************************************************************************************************
17855 SUBROUTINE mp_sum_scatter_dv(msgout, msgin, rcount, comm)
17856 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
17857 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17858 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
17859 CLASS(mp_comm_type), INTENT(IN) :: comm
17860
17861 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_dv'
17862
17863 INTEGER :: handle
17864#if defined(__parallel)
17865 INTEGER :: ierr
17866#endif
17867
17868 CALL mp_timeset(routinen, handle)
17869
17870#if defined(__parallel)
17871 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_double_precision, mpi_sum, &
17872 comm%handle, ierr)
17873 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
17874
17875 CALL add_perf(perf_id=3, count=1, &
17876 msg_size=rcount(1)*2*real_8_size)
17877#else
17878 mark_used(rcount)
17879 mark_used(comm)
17880 msgin = msgout(:, 1)
17881#endif
17882 CALL mp_timestop(handle)
17883 END SUBROUTINE mp_sum_scatter_dv
17884
17885! **************************************************************************************************
17886!> \brief Sends and receives vector data
17887!> \param[in] msgin Data to send
17888!> \param[in] dest Process to send data to
17889!> \param[out] msgout Received data
17890!> \param[in] source Process from which to receive
17891!> \param[in] comm Message passing environment identifier
17892!> \param[in] tag Send and recv tag (default: 0)
17893! **************************************************************************************************
17894 SUBROUTINE mp_sendrecv_d (msgin, dest, msgout, source, comm, tag)
17895 REAL(kind=real_8), INTENT(IN) :: msgin
17896 INTEGER, INTENT(IN) :: dest
17897 REAL(kind=real_8), INTENT(OUT) :: msgout
17898 INTEGER, INTENT(IN) :: source
17899 CLASS(mp_comm_type), INTENT(IN) :: comm
17900 INTEGER, INTENT(IN), OPTIONAL :: tag
17901
17902 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_d'
17903
17904 INTEGER :: handle
17905#if defined(__parallel)
17906 INTEGER :: ierr, msglen_in, msglen_out, &
17907 recv_tag, send_tag
17908#endif
17909
17910 CALL mp_timeset(routinen, handle)
17911
17912#if defined(__parallel)
17913 msglen_in = 1
17914 msglen_out = 1
17915 send_tag = 0 ! cannot think of something better here, this might be dangerous
17916 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17917 IF (PRESENT(tag)) THEN
17918 send_tag = tag
17919 recv_tag = tag
17920 END IF
17921 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17922 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17923 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17924 CALL add_perf(perf_id=7, count=1, &
17925 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17926#else
17927 mark_used(dest)
17928 mark_used(source)
17929 mark_used(comm)
17930 mark_used(tag)
17931 msgout = msgin
17932#endif
17933 CALL mp_timestop(handle)
17934 END SUBROUTINE mp_sendrecv_d
17935
17936! **************************************************************************************************
17937!> \brief Sends and receives vector data
17938!> \param[in] msgin Data to send
17939!> \param[in] dest Process to send data to
17940!> \param[out] msgout Received data
17941!> \param[in] source Process from which to receive
17942!> \param[in] comm Message passing environment identifier
17943!> \param[in] tag Send and recv tag (default: 0)
17944! **************************************************************************************************
17945 SUBROUTINE mp_sendrecv_dv(msgin, dest, msgout, source, comm, tag)
17946 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
17947 INTEGER, INTENT(IN) :: dest
17948 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
17949 INTEGER, INTENT(IN) :: source
17950 CLASS(mp_comm_type), INTENT(IN) :: comm
17951 INTEGER, INTENT(IN), OPTIONAL :: tag
17952
17953 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dv'
17954
17955 INTEGER :: handle
17956#if defined(__parallel)
17957 INTEGER :: ierr, msglen_in, msglen_out, &
17958 recv_tag, send_tag
17959#endif
17960
17961 CALL mp_timeset(routinen, handle)
17962
17963#if defined(__parallel)
17964 msglen_in = SIZE(msgin)
17965 msglen_out = SIZE(msgout)
17966 send_tag = 0 ! cannot think of something better here, this might be dangerous
17967 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17968 IF (PRESENT(tag)) THEN
17969 send_tag = tag
17970 recv_tag = tag
17971 END IF
17972 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17973 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17974 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17975 CALL add_perf(perf_id=7, count=1, &
17976 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17977#else
17978 mark_used(dest)
17979 mark_used(source)
17980 mark_used(comm)
17981 mark_used(tag)
17982 msgout = msgin
17983#endif
17984 CALL mp_timestop(handle)
17985 END SUBROUTINE mp_sendrecv_dv
17986
17987! **************************************************************************************************
17988!> \brief Sends and receives matrix data
17989!> \param msgin ...
17990!> \param dest ...
17991!> \param msgout ...
17992!> \param source ...
17993!> \param comm ...
17994!> \param tag ...
17995!> \note see mp_sendrecv_dv
17996! **************************************************************************************************
17997 SUBROUTINE mp_sendrecv_dm2(msgin, dest, msgout, source, comm, tag)
17998 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
17999 INTEGER, INTENT(IN) :: dest
18000 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
18001 INTEGER, INTENT(IN) :: source
18002 CLASS(mp_comm_type), INTENT(IN) :: comm
18003 INTEGER, INTENT(IN), OPTIONAL :: tag
18004
18005 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm2'
18006
18007 INTEGER :: handle
18008#if defined(__parallel)
18009 INTEGER :: ierr, msglen_in, msglen_out, &
18010 recv_tag, send_tag
18011#endif
18012
18013 CALL mp_timeset(routinen, handle)
18014
18015#if defined(__parallel)
18016 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
18017 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
18018 send_tag = 0 ! cannot think of something better here, this might be dangerous
18019 recv_tag = 0 ! cannot think of something better here, this might be dangerous
18020 IF (PRESENT(tag)) THEN
18021 send_tag = tag
18022 recv_tag = tag
18023 END IF
18024 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
18025 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
18026 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
18027 CALL add_perf(perf_id=7, count=1, &
18028 msg_size=(msglen_in + msglen_out)*real_8_size/2)
18029#else
18030 mark_used(dest)
18031 mark_used(source)
18032 mark_used(comm)
18033 mark_used(tag)
18034 msgout = msgin
18035#endif
18036 CALL mp_timestop(handle)
18037 END SUBROUTINE mp_sendrecv_dm2
18038
18039! **************************************************************************************************
18040!> \brief Sends and receives rank-3 data
18041!> \param msgin ...
18042!> \param dest ...
18043!> \param msgout ...
18044!> \param source ...
18045!> \param comm ...
18046!> \note see mp_sendrecv_dv
18047! **************************************************************************************************
18048 SUBROUTINE mp_sendrecv_dm3(msgin, dest, msgout, source, comm, tag)
18049 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
18050 INTEGER, INTENT(IN) :: dest
18051 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
18052 INTEGER, INTENT(IN) :: source
18053 CLASS(mp_comm_type), INTENT(IN) :: comm
18054 INTEGER, INTENT(IN), OPTIONAL :: tag
18055
18056 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm3'
18057
18058 INTEGER :: handle
18059#if defined(__parallel)
18060 INTEGER :: ierr, msglen_in, msglen_out, &
18061 recv_tag, send_tag
18062#endif
18063
18064 CALL mp_timeset(routinen, handle)
18065
18066#if defined(__parallel)
18067 msglen_in = SIZE(msgin)
18068 msglen_out = SIZE(msgout)
18069 send_tag = 0 ! cannot think of something better here, this might be dangerous
18070 recv_tag = 0 ! cannot think of something better here, this might be dangerous
18071 IF (PRESENT(tag)) THEN
18072 send_tag = tag
18073 recv_tag = tag
18074 END IF
18075 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
18076 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
18077 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
18078 CALL add_perf(perf_id=7, count=1, &
18079 msg_size=(msglen_in + msglen_out)*real_8_size/2)
18080#else
18081 mark_used(dest)
18082 mark_used(source)
18083 mark_used(comm)
18084 mark_used(tag)
18085 msgout = msgin
18086#endif
18087 CALL mp_timestop(handle)
18088 END SUBROUTINE mp_sendrecv_dm3
18089
18090! **************************************************************************************************
18091!> \brief Sends and receives rank-4 data
18092!> \param msgin ...
18093!> \param dest ...
18094!> \param msgout ...
18095!> \param source ...
18096!> \param comm ...
18097!> \note see mp_sendrecv_dv
18098! **************************************************************************************************
18099 SUBROUTINE mp_sendrecv_dm4(msgin, dest, msgout, source, comm, tag)
18100 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
18101 INTEGER, INTENT(IN) :: dest
18102 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
18103 INTEGER, INTENT(IN) :: source
18104 CLASS(mp_comm_type), INTENT(IN) :: comm
18105 INTEGER, INTENT(IN), OPTIONAL :: tag
18106
18107 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm4'
18108
18109 INTEGER :: handle
18110#if defined(__parallel)
18111 INTEGER :: ierr, msglen_in, msglen_out, &
18112 recv_tag, send_tag
18113#endif
18114
18115 CALL mp_timeset(routinen, handle)
18116
18117#if defined(__parallel)
18118 msglen_in = SIZE(msgin)
18119 msglen_out = SIZE(msgout)
18120 send_tag = 0 ! cannot think of something better here, this might be dangerous
18121 recv_tag = 0 ! cannot think of something better here, this might be dangerous
18122 IF (PRESENT(tag)) THEN
18123 send_tag = tag
18124 recv_tag = tag
18125 END IF
18126 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
18127 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
18128 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
18129 CALL add_perf(perf_id=7, count=1, &
18130 msg_size=(msglen_in + msglen_out)*real_8_size/2)
18131#else
18132 mark_used(dest)
18133 mark_used(source)
18134 mark_used(comm)
18135 mark_used(tag)
18136 msgout = msgin
18137#endif
18138 CALL mp_timestop(handle)
18139 END SUBROUTINE mp_sendrecv_dm4
18140
18141! **************************************************************************************************
18142!> \brief Non-blocking send and receive of a scalar
18143!> \param[in] msgin Scalar data to send
18144!> \param[in] dest Which process to send to
18145!> \param[out] msgout Receive data into this pointer
18146!> \param[in] source Process to receive from
18147!> \param[in] comm Message passing environment identifier
18148!> \param[out] send_request Request handle for the send
18149!> \param[out] recv_request Request handle for the receive
18150!> \param[in] tag (optional) tag to differentiate requests
18151!> \par Implementation
18152!> Calls mpi_isend and mpi_irecv.
18153!> \par History
18154!> 02.2005 created [Alfio Lazzaro]
18155! **************************************************************************************************
18156 SUBROUTINE mp_isendrecv_d (msgin, dest, msgout, source, comm, send_request, &
18157 recv_request, tag)
18158 REAL(kind=real_8), INTENT(IN) :: msgin
18159 INTEGER, INTENT(IN) :: dest
18160 REAL(kind=real_8), INTENT(INOUT) :: msgout
18161 INTEGER, INTENT(IN) :: source
18162 CLASS(mp_comm_type), INTENT(IN) :: comm
18163 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
18164 INTEGER, INTENT(in), OPTIONAL :: tag
18165
18166 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_d'
18167
18168 INTEGER :: handle
18169#if defined(__parallel)
18170 INTEGER :: ierr, my_tag
18171#endif
18172
18173 CALL mp_timeset(routinen, handle)
18174
18175#if defined(__parallel)
18176 my_tag = 0
18177 IF (PRESENT(tag)) my_tag = tag
18178
18179 CALL mpi_irecv(msgout, 1, mpi_double_precision, source, my_tag, &
18180 comm%handle, recv_request%handle, ierr)
18181 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18182
18183 CALL mpi_isend(msgin, 1, mpi_double_precision, dest, my_tag, &
18184 comm%handle, send_request%handle, ierr)
18185 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18186
18187 CALL add_perf(perf_id=8, count=1, msg_size=2*real_8_size)
18188#else
18189 mark_used(dest)
18190 mark_used(source)
18191 mark_used(comm)
18192 mark_used(tag)
18193 send_request = mp_request_null
18194 recv_request = mp_request_null
18195 msgout = msgin
18196#endif
18197 CALL mp_timestop(handle)
18198 END SUBROUTINE mp_isendrecv_d
18199
18200! **************************************************************************************************
18201!> \brief Non-blocking send and receive of a vector
18202!> \param[in] msgin Vector data to send
18203!> \param[in] dest Which process to send to
18204!> \param[out] msgout Receive data into this pointer
18205!> \param[in] source Process to receive from
18206!> \param[in] comm Message passing environment identifier
18207!> \param[out] send_request Request handle for the send
18208!> \param[out] recv_request Request handle for the receive
18209!> \param[in] tag (optional) tag to differentiate requests
18210!> \par Implementation
18211!> Calls mpi_isend and mpi_irecv.
18212!> \par History
18213!> 11.2004 created [Joost VandeVondele]
18214!> \note
18215!> arrays can be pointers or assumed shape, but they must be contiguous!
18216! **************************************************************************************************
18217 SUBROUTINE mp_isendrecv_dv(msgin, dest, msgout, source, comm, send_request, &
18218 recv_request, tag)
18219 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
18220 INTEGER, INTENT(IN) :: dest
18221 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
18222 INTEGER, INTENT(IN) :: source
18223 CLASS(mp_comm_type), INTENT(IN) :: comm
18224 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
18225 INTEGER, INTENT(in), OPTIONAL :: tag
18226
18227 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_dv'
18228
18229 INTEGER :: handle
18230#if defined(__parallel)
18231 INTEGER :: ierr, msglen, my_tag
18232 REAL(kind=real_8) :: foo
18233#endif
18234
18235 CALL mp_timeset(routinen, handle)
18236
18237#if defined(__parallel)
18238#if !defined(__GNUC__) || __GNUC__ >= 9
18239 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
18240 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
18241#endif
18242
18243 my_tag = 0
18244 IF (PRESENT(tag)) my_tag = tag
18245
18246 msglen = SIZE(msgout, 1)
18247 IF (msglen > 0) THEN
18248 CALL mpi_irecv(msgout(1), msglen, mpi_double_precision, source, my_tag, &
18249 comm%handle, recv_request%handle, ierr)
18250 ELSE
18251 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18252 comm%handle, recv_request%handle, ierr)
18253 END IF
18254 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18255
18256 msglen = SIZE(msgin, 1)
18257 IF (msglen > 0) THEN
18258 CALL mpi_isend(msgin(1), msglen, mpi_double_precision, dest, my_tag, &
18259 comm%handle, send_request%handle, ierr)
18260 ELSE
18261 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18262 comm%handle, send_request%handle, ierr)
18263 END IF
18264 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18265
18266 msglen = (msglen + SIZE(msgout, 1) + 1)/2
18267 CALL add_perf(perf_id=8, count=1, msg_size=msglen*real_8_size)
18268#else
18269 mark_used(dest)
18270 mark_used(source)
18271 mark_used(comm)
18272 mark_used(tag)
18273 send_request = mp_request_null
18274 recv_request = mp_request_null
18275 msgout = msgin
18276#endif
18277 CALL mp_timestop(handle)
18278 END SUBROUTINE mp_isendrecv_dv
18279
18280! **************************************************************************************************
18281!> \brief Non-blocking send of vector data
18282!> \param msgin ...
18283!> \param dest ...
18284!> \param comm ...
18285!> \param request ...
18286!> \param tag ...
18287!> \par History
18288!> 08.2003 created [f&j]
18289!> \note see mp_isendrecv_dv
18290!> \note
18291!> arrays can be pointers or assumed shape, but they must be contiguous!
18292! **************************************************************************************************
18293 SUBROUTINE mp_isend_dv(msgin, dest, comm, request, tag)
18294 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
18295 INTEGER, INTENT(IN) :: dest
18296 CLASS(mp_comm_type), INTENT(IN) :: comm
18297 TYPE(mp_request_type), INTENT(out) :: request
18298 INTEGER, INTENT(in), OPTIONAL :: tag
18299
18300 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dv'
18301
18302 INTEGER :: handle, ierr
18303#if defined(__parallel)
18304 INTEGER :: msglen, my_tag
18305 REAL(kind=real_8) :: foo(1)
18306#endif
18307
18308 CALL mp_timeset(routinen, handle)
18309
18310#if defined(__parallel)
18311#if !defined(__GNUC__) || __GNUC__ >= 9
18312 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
18313#endif
18314 my_tag = 0
18315 IF (PRESENT(tag)) my_tag = tag
18316
18317 msglen = SIZE(msgin)
18318 IF (msglen > 0) THEN
18319 CALL mpi_isend(msgin(1), msglen, mpi_double_precision, dest, my_tag, &
18320 comm%handle, request%handle, ierr)
18321 ELSE
18322 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18323 comm%handle, request%handle, ierr)
18324 END IF
18325 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18326
18327 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18328#else
18329 mark_used(msgin)
18330 mark_used(dest)
18331 mark_used(comm)
18332 mark_used(request)
18333 mark_used(tag)
18334 ierr = 1
18335 request = mp_request_null
18336 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18337#endif
18338 CALL mp_timestop(handle)
18339 END SUBROUTINE mp_isend_dv
18340
18341! **************************************************************************************************
18342!> \brief Non-blocking send of matrix data
18343!> \param msgin ...
18344!> \param dest ...
18345!> \param comm ...
18346!> \param request ...
18347!> \param tag ...
18348!> \par History
18349!> 2009-11-25 [UB] Made type-generic for templates
18350!> \author fawzi
18351!> \note see mp_isendrecv_dv
18352!> \note see mp_isend_dv
18353!> \note
18354!> arrays can be pointers or assumed shape, but they must be contiguous!
18355! **************************************************************************************************
18356 SUBROUTINE mp_isend_dm2(msgin, dest, comm, request, tag)
18357 REAL(kind=real_8), DIMENSION(:, :), INTENT(IN) :: msgin
18358 INTEGER, INTENT(IN) :: dest
18359 CLASS(mp_comm_type), INTENT(IN) :: comm
18360 TYPE(mp_request_type), INTENT(out) :: request
18361 INTEGER, INTENT(in), OPTIONAL :: tag
18362
18363 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm2'
18364
18365 INTEGER :: handle, ierr
18366#if defined(__parallel)
18367 INTEGER :: msglen, my_tag
18368 REAL(kind=real_8) :: foo(1)
18369#endif
18370
18371 CALL mp_timeset(routinen, handle)
18372
18373#if defined(__parallel)
18374#if !defined(__GNUC__) || __GNUC__ >= 9
18375 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
18376#endif
18377
18378 my_tag = 0
18379 IF (PRESENT(tag)) my_tag = tag
18380
18381 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
18382 IF (msglen > 0) THEN
18383 CALL mpi_isend(msgin(1, 1), msglen, mpi_double_precision, dest, my_tag, &
18384 comm%handle, request%handle, ierr)
18385 ELSE
18386 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18387 comm%handle, request%handle, ierr)
18388 END IF
18389 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18390
18391 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18392#else
18393 mark_used(msgin)
18394 mark_used(dest)
18395 mark_used(comm)
18396 mark_used(request)
18397 mark_used(tag)
18398 ierr = 1
18399 request = mp_request_null
18400 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18401#endif
18402 CALL mp_timestop(handle)
18403 END SUBROUTINE mp_isend_dm2
18404
18405! **************************************************************************************************
18406!> \brief Non-blocking send of rank-3 data
18407!> \param msgin ...
18408!> \param dest ...
18409!> \param comm ...
18410!> \param request ...
18411!> \param tag ...
18412!> \par History
18413!> 9.2008 added _rm3 subroutine [Iain Bethune]
18414!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
18415!> 2009-11-25 [UB] Made type-generic for templates
18416!> \author fawzi
18417!> \note see mp_isendrecv_dv
18418!> \note see mp_isend_dv
18419!> \note
18420!> arrays can be pointers or assumed shape, but they must be contiguous!
18421! **************************************************************************************************
18422 SUBROUTINE mp_isend_dm3(msgin, dest, comm, request, tag)
18423 REAL(kind=real_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
18424 INTEGER, INTENT(IN) :: dest
18425 CLASS(mp_comm_type), INTENT(IN) :: comm
18426 TYPE(mp_request_type), INTENT(out) :: request
18427 INTEGER, INTENT(in), OPTIONAL :: tag
18428
18429 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm3'
18430
18431 INTEGER :: handle, ierr
18432#if defined(__parallel)
18433 INTEGER :: msglen, my_tag
18434 REAL(kind=real_8) :: foo(1)
18435#endif
18436
18437 CALL mp_timeset(routinen, handle)
18438
18439#if defined(__parallel)
18440#if !defined(__GNUC__) || __GNUC__ >= 9
18441 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
18442#endif
18443
18444 my_tag = 0
18445 IF (PRESENT(tag)) my_tag = tag
18446
18447 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
18448 IF (msglen > 0) THEN
18449 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_double_precision, dest, my_tag, &
18450 comm%handle, request%handle, ierr)
18451 ELSE
18452 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18453 comm%handle, request%handle, ierr)
18454 END IF
18455 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18456
18457 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18458#else
18459 mark_used(msgin)
18460 mark_used(dest)
18461 mark_used(comm)
18462 mark_used(request)
18463 mark_used(tag)
18464 ierr = 1
18465 request = mp_request_null
18466 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18467#endif
18468 CALL mp_timestop(handle)
18469 END SUBROUTINE mp_isend_dm3
18470
18471! **************************************************************************************************
18472!> \brief Non-blocking send of rank-4 data
18473!> \param msgin the input message
18474!> \param dest the destination processor
18475!> \param comm the communicator object
18476!> \param request the communication request id
18477!> \param tag the message tag
18478!> \par History
18479!> 2.2016 added _dm4 subroutine [Nico Holmberg]
18480!> \author fawzi
18481!> \note see mp_isend_dv
18482!> \note
18483!> arrays can be pointers or assumed shape, but they must be contiguous!
18484! **************************************************************************************************
18485 SUBROUTINE mp_isend_dm4(msgin, dest, comm, request, tag)
18486 REAL(kind=real_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
18487 INTEGER, INTENT(IN) :: dest
18488 CLASS(mp_comm_type), INTENT(IN) :: comm
18489 TYPE(mp_request_type), INTENT(out) :: request
18490 INTEGER, INTENT(in), OPTIONAL :: tag
18491
18492 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm4'
18493
18494 INTEGER :: handle, ierr
18495#if defined(__parallel)
18496 INTEGER :: msglen, my_tag
18497 REAL(kind=real_8) :: foo(1)
18498#endif
18499
18500 CALL mp_timeset(routinen, handle)
18501
18502#if defined(__parallel)
18503#if !defined(__GNUC__) || __GNUC__ >= 9
18504 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
18505#endif
18506
18507 my_tag = 0
18508 IF (PRESENT(tag)) my_tag = tag
18509
18510 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
18511 IF (msglen > 0) THEN
18512 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_double_precision, dest, my_tag, &
18513 comm%handle, request%handle, ierr)
18514 ELSE
18515 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18516 comm%handle, request%handle, ierr)
18517 END IF
18518 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18519
18520 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18521#else
18522 mark_used(msgin)
18523 mark_used(dest)
18524 mark_used(comm)
18525 mark_used(request)
18526 mark_used(tag)
18527 ierr = 1
18528 request = mp_request_null
18529 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18530#endif
18531 CALL mp_timestop(handle)
18532 END SUBROUTINE mp_isend_dm4
18533
18534! **************************************************************************************************
18535!> \brief Non-blocking receive of vector data
18536!> \param msgout ...
18537!> \param source ...
18538!> \param comm ...
18539!> \param request ...
18540!> \param tag ...
18541!> \par History
18542!> 08.2003 created [f&j]
18543!> 2009-11-25 [UB] Made type-generic for templates
18544!> \note see mp_isendrecv_dv
18545!> \note
18546!> arrays can be pointers or assumed shape, but they must be contiguous!
18547! **************************************************************************************************
18548 SUBROUTINE mp_irecv_dv(msgout, source, comm, request, tag)
18549 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
18550 INTEGER, INTENT(IN) :: source
18551 CLASS(mp_comm_type), INTENT(IN) :: comm
18552 TYPE(mp_request_type), INTENT(out) :: request
18553 INTEGER, INTENT(in), OPTIONAL :: tag
18554
18555 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dv'
18556
18557 INTEGER :: handle
18558#if defined(__parallel)
18559 INTEGER :: ierr, msglen, my_tag
18560 REAL(kind=real_8) :: foo(1)
18561#endif
18562
18563 CALL mp_timeset(routinen, handle)
18564
18565#if defined(__parallel)
18566#if !defined(__GNUC__) || __GNUC__ >= 9
18567 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
18568#endif
18569
18570 my_tag = 0
18571 IF (PRESENT(tag)) my_tag = tag
18572
18573 msglen = SIZE(msgout)
18574 IF (msglen > 0) THEN
18575 CALL mpi_irecv(msgout(1), msglen, mpi_double_precision, source, my_tag, &
18576 comm%handle, request%handle, ierr)
18577 ELSE
18578 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18579 comm%handle, request%handle, ierr)
18580 END IF
18581 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18582
18583 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18584#else
18585 cpabort("mp_irecv called in non parallel case")
18586 mark_used(msgout)
18587 mark_used(source)
18588 mark_used(comm)
18589 mark_used(tag)
18590 request = mp_request_null
18591#endif
18592 CALL mp_timestop(handle)
18593 END SUBROUTINE mp_irecv_dv
18594
18595! **************************************************************************************************
18596!> \brief Non-blocking receive of matrix data
18597!> \param msgout ...
18598!> \param source ...
18599!> \param comm ...
18600!> \param request ...
18601!> \param tag ...
18602!> \par History
18603!> 2009-11-25 [UB] Made type-generic for templates
18604!> \author fawzi
18605!> \note see mp_isendrecv_dv
18606!> \note see mp_irecv_dv
18607!> \note
18608!> arrays can be pointers or assumed shape, but they must be contiguous!
18609! **************************************************************************************************
18610 SUBROUTINE mp_irecv_dm2(msgout, source, comm, request, tag)
18611 REAL(kind=real_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
18612 INTEGER, INTENT(IN) :: source
18613 CLASS(mp_comm_type), INTENT(IN) :: comm
18614 TYPE(mp_request_type), INTENT(out) :: request
18615 INTEGER, INTENT(in), OPTIONAL :: tag
18616
18617 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm2'
18618
18619 INTEGER :: handle
18620#if defined(__parallel)
18621 INTEGER :: ierr, msglen, my_tag
18622 REAL(kind=real_8) :: foo(1)
18623#endif
18624
18625 CALL mp_timeset(routinen, handle)
18626
18627#if defined(__parallel)
18628#if !defined(__GNUC__) || __GNUC__ >= 9
18629 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
18630#endif
18631
18632 my_tag = 0
18633 IF (PRESENT(tag)) my_tag = tag
18634
18635 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
18636 IF (msglen > 0) THEN
18637 CALL mpi_irecv(msgout(1, 1), msglen, mpi_double_precision, source, my_tag, &
18638 comm%handle, request%handle, ierr)
18639 ELSE
18640 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18641 comm%handle, request%handle, ierr)
18642 END IF
18643 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18644
18645 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18646#else
18647 mark_used(msgout)
18648 mark_used(source)
18649 mark_used(comm)
18650 mark_used(tag)
18651 request = mp_request_null
18652 cpabort("mp_irecv called in non parallel case")
18653#endif
18654 CALL mp_timestop(handle)
18655 END SUBROUTINE mp_irecv_dm2
18656
18657! **************************************************************************************************
18658!> \brief Non-blocking send of rank-3 data
18659!> \param msgout ...
18660!> \param source ...
18661!> \param comm ...
18662!> \param request ...
18663!> \param tag ...
18664!> \par History
18665!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
18666!> 2009-11-25 [UB] Made type-generic for templates
18667!> \author fawzi
18668!> \note see mp_isendrecv_dv
18669!> \note see mp_irecv_dv
18670!> \note
18671!> arrays can be pointers or assumed shape, but they must be contiguous!
18672! **************************************************************************************************
18673 SUBROUTINE mp_irecv_dm3(msgout, source, comm, request, tag)
18674 REAL(kind=real_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
18675 INTEGER, INTENT(IN) :: source
18676 CLASS(mp_comm_type), INTENT(IN) :: comm
18677 TYPE(mp_request_type), INTENT(out) :: request
18678 INTEGER, INTENT(in), OPTIONAL :: tag
18679
18680 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm3'
18681
18682 INTEGER :: handle
18683#if defined(__parallel)
18684 INTEGER :: ierr, msglen, my_tag
18685 REAL(kind=real_8) :: foo(1)
18686#endif
18687
18688 CALL mp_timeset(routinen, handle)
18689
18690#if defined(__parallel)
18691#if !defined(__GNUC__) || __GNUC__ >= 9
18692 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
18693#endif
18694
18695 my_tag = 0
18696 IF (PRESENT(tag)) my_tag = tag
18697
18698 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
18699 IF (msglen > 0) THEN
18700 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_double_precision, source, my_tag, &
18701 comm%handle, request%handle, ierr)
18702 ELSE
18703 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18704 comm%handle, request%handle, ierr)
18705 END IF
18706 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
18707
18708 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18709#else
18710 mark_used(msgout)
18711 mark_used(source)
18712 mark_used(comm)
18713 mark_used(tag)
18714 request = mp_request_null
18715 cpabort("mp_irecv called in non parallel case")
18716#endif
18717 CALL mp_timestop(handle)
18718 END SUBROUTINE mp_irecv_dm3
18719
18720! **************************************************************************************************
18721!> \brief Non-blocking receive of rank-4 data
18722!> \param msgout the output message
18723!> \param source the source processor
18724!> \param comm the communicator object
18725!> \param request the communication request id
18726!> \param tag the message tag
18727!> \par History
18728!> 2.2016 added _dm4 subroutine [Nico Holmberg]
18729!> \author fawzi
18730!> \note see mp_irecv_dv
18731!> \note
18732!> arrays can be pointers or assumed shape, but they must be contiguous!
18733! **************************************************************************************************
18734 SUBROUTINE mp_irecv_dm4(msgout, source, comm, request, tag)
18735 REAL(kind=real_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
18736 INTEGER, INTENT(IN) :: source
18737 CLASS(mp_comm_type), INTENT(IN) :: comm
18738 TYPE(mp_request_type), INTENT(out) :: request
18739 INTEGER, INTENT(in), OPTIONAL :: tag
18740
18741 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm4'
18742
18743 INTEGER :: handle
18744#if defined(__parallel)
18745 INTEGER :: ierr, msglen, my_tag
18746 REAL(kind=real_8) :: foo(1)
18747#endif
18748
18749 CALL mp_timeset(routinen, handle)
18750
18751#if defined(__parallel)
18752#if !defined(__GNUC__) || __GNUC__ >= 9
18753 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
18754#endif
18755
18756 my_tag = 0
18757 IF (PRESENT(tag)) my_tag = tag
18758
18759 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
18760 IF (msglen > 0) THEN
18761 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_double_precision, source, my_tag, &
18762 comm%handle, request%handle, ierr)
18763 ELSE
18764 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18765 comm%handle, request%handle, ierr)
18766 END IF
18767 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
18768
18769 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18770#else
18771 mark_used(msgout)
18772 mark_used(source)
18773 mark_used(comm)
18774 mark_used(tag)
18775 request = mp_request_null
18776 cpabort("mp_irecv called in non parallel case")
18777#endif
18778 CALL mp_timestop(handle)
18779 END SUBROUTINE mp_irecv_dm4
18780
18781! **************************************************************************************************
18782!> \brief Window initialization function for vector data
18783!> \param base ...
18784!> \param comm ...
18785!> \param win ...
18786!> \par History
18787!> 02.2015 created [Alfio Lazzaro]
18788!> \note
18789!> arrays can be pointers or assumed shape, but they must be contiguous!
18790! **************************************************************************************************
18791 SUBROUTINE mp_win_create_dv(base, comm, win)
18792 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
18793 TYPE(mp_comm_type), INTENT(IN) :: comm
18794 CLASS(mp_win_type), INTENT(INOUT) :: win
18795
18796 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_dv'
18797
18798 INTEGER :: handle
18799#if defined(__parallel)
18800 INTEGER :: ierr
18801 INTEGER(kind=mpi_address_kind) :: len
18802 REAL(kind=real_8) :: foo(1)
18803#endif
18804
18805 CALL mp_timeset(routinen, handle)
18806
18807#if defined(__parallel)
18808
18809 len = SIZE(base)*real_8_size
18810 IF (len > 0) THEN
18811 CALL mpi_win_create(base(1), len, real_8_size, mpi_info_null, comm%handle, win%handle, ierr)
18812 ELSE
18813 CALL mpi_win_create(foo, len, real_8_size, mpi_info_null, comm%handle, win%handle, ierr)
18814 END IF
18815 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
18816
18817 CALL add_perf(perf_id=20, count=1)
18818#else
18819 mark_used(base)
18820 mark_used(comm)
18821 win%handle = mp_win_null_handle
18822#endif
18823 CALL mp_timestop(handle)
18824 END SUBROUTINE mp_win_create_dv
18825
18826! **************************************************************************************************
18827!> \brief Single-sided get function for vector data
18828!> \param base ...
18829!> \param comm ...
18830!> \param win ...
18831!> \par History
18832!> 02.2015 created [Alfio Lazzaro]
18833!> \note
18834!> arrays can be pointers or assumed shape, but they must be contiguous!
18835! **************************************************************************************************
18836 SUBROUTINE mp_rget_dv(base, source, win, win_data, myproc, disp, request, &
18837 origin_datatype, target_datatype)
18838 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
18839 INTEGER, INTENT(IN) :: source
18840 CLASS(mp_win_type), INTENT(IN) :: win
18841 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: win_data
18842 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
18843 TYPE(mp_request_type), INTENT(OUT) :: request
18844 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
18845
18846 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_dv'
18847
18848 INTEGER :: handle
18849#if defined(__parallel)
18850 INTEGER :: ierr, len, &
18851 origin_len, target_len
18852 LOGICAL :: do_local_copy
18853 INTEGER(kind=mpi_address_kind) :: disp_aint
18854 mpi_data_type :: handle_origin_datatype, handle_target_datatype
18855#endif
18856
18857 CALL mp_timeset(routinen, handle)
18858
18859#if defined(__parallel)
18860 len = SIZE(base)
18861 disp_aint = 0
18862 IF (PRESENT(disp)) THEN
18863 disp_aint = int(disp, kind=mpi_address_kind)
18864 END IF
18865 handle_origin_datatype = mpi_double_precision
18866 origin_len = len
18867 IF (PRESENT(origin_datatype)) THEN
18868 handle_origin_datatype = origin_datatype%type_handle
18869 origin_len = 1
18870 END IF
18871 handle_target_datatype = mpi_double_precision
18872 target_len = len
18873 IF (PRESENT(target_datatype)) THEN
18874 handle_target_datatype = target_datatype%type_handle
18875 target_len = 1
18876 END IF
18877 IF (len > 0) THEN
18878 do_local_copy = .false.
18879 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
18880 IF (myproc .EQ. source) do_local_copy = .true.
18881 END IF
18882 IF (do_local_copy) THEN
18883 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
18884 base(:) = win_data(disp_aint + 1:disp_aint + len)
18885 !$OMP END PARALLEL WORKSHARE
18886 request = mp_request_null
18887 ierr = 0
18888 ELSE
18889 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
18890 target_len, handle_target_datatype, win%handle, request%handle, ierr)
18891 END IF
18892 ELSE
18893 request = mp_request_null
18894 ierr = 0
18895 END IF
18896 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
18897
18898 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*real_8_size)
18899#else
18900 mark_used(source)
18901 mark_used(win)
18902 mark_used(myproc)
18903 mark_used(origin_datatype)
18904 mark_used(target_datatype)
18905
18906 request = mp_request_null
18907 !
18908 IF (PRESENT(disp)) THEN
18909 base(:) = win_data(disp + 1:disp + SIZE(base))
18910 ELSE
18911 base(:) = win_data(:SIZE(base))
18912 END IF
18913
18914#endif
18915 CALL mp_timestop(handle)
18916 END SUBROUTINE mp_rget_dv
18917
18918! **************************************************************************************************
18919!> \brief ...
18920!> \param count ...
18921!> \param lengths ...
18922!> \param displs ...
18923!> \return ...
18924! ***************************************************************************
18925 FUNCTION mp_type_indexed_make_d (count, lengths, displs) &
18926 result(type_descriptor)
18927 INTEGER, INTENT(IN) :: count
18928 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
18929 TYPE(mp_type_descriptor_type) :: type_descriptor
18930
18931 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_d'
18932
18933 INTEGER :: handle
18934#if defined(__parallel)
18935 INTEGER :: ierr
18936#endif
18937
18938 CALL mp_timeset(routinen, handle)
18939
18940#if defined(__parallel)
18941 CALL mpi_type_indexed(count, lengths, displs, mpi_double_precision, &
18942 type_descriptor%type_handle, ierr)
18943 IF (ierr /= 0) &
18944 cpabort("MPI_Type_Indexed @ "//routinen)
18945 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
18946 IF (ierr /= 0) &
18947 cpabort("MPI_Type_commit @ "//routinen)
18948#else
18949 type_descriptor%type_handle = 3
18950#endif
18951 type_descriptor%length = count
18952 NULLIFY (type_descriptor%subtype)
18953 type_descriptor%vector_descriptor(1:2) = 1
18954 type_descriptor%has_indexing = .true.
18955 type_descriptor%index_descriptor%index => lengths
18956 type_descriptor%index_descriptor%chunks => displs
18957
18958 CALL mp_timestop(handle)
18959
18960 END FUNCTION mp_type_indexed_make_d
18961
18962! **************************************************************************************************
18963!> \brief Allocates special parallel memory
18964!> \param[in] DATA pointer to integer array to allocate
18965!> \param[in] len number of integers to allocate
18966!> \param[out] stat (optional) allocation status result
18967!> \author UB
18968! **************************************************************************************************
18969 SUBROUTINE mp_allocate_d (DATA, len, stat)
18970 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
18971 INTEGER, INTENT(IN) :: len
18972 INTEGER, INTENT(OUT), OPTIONAL :: stat
18973
18974 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_d'
18975
18976 INTEGER :: handle, ierr
18977
18978 CALL mp_timeset(routinen, handle)
18979
18980#if defined(__parallel)
18981 NULLIFY (data)
18982 CALL mp_alloc_mem(DATA, len, stat=ierr)
18983 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
18984 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
18985 CALL add_perf(perf_id=15, count=1)
18986#else
18987 ALLOCATE (DATA(len), stat=ierr)
18988 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
18989 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
18990#endif
18991 IF (PRESENT(stat)) stat = ierr
18992 CALL mp_timestop(handle)
18993 END SUBROUTINE mp_allocate_d
18994
18995! **************************************************************************************************
18996!> \brief Deallocates special parallel memory
18997!> \param[in] DATA pointer to special memory to deallocate
18998!> \param stat ...
18999!> \author UB
19000! **************************************************************************************************
19001 SUBROUTINE mp_deallocate_d (DATA, stat)
19002 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
19003 INTEGER, INTENT(OUT), OPTIONAL :: stat
19004
19005 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_d'
19006
19007 INTEGER :: handle
19008#if defined(__parallel)
19009 INTEGER :: ierr
19010#endif
19011
19012 CALL mp_timeset(routinen, handle)
19013
19014#if defined(__parallel)
19015 CALL mp_free_mem(DATA, ierr)
19016 IF (PRESENT(stat)) THEN
19017 stat = ierr
19018 ELSE
19019 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
19020 END IF
19021 NULLIFY (data)
19022 CALL add_perf(perf_id=15, count=1)
19023#else
19024 DEALLOCATE (data)
19025 IF (PRESENT(stat)) stat = 0
19026#endif
19027 CALL mp_timestop(handle)
19028 END SUBROUTINE mp_deallocate_d
19029
19030! **************************************************************************************************
19031!> \brief (parallel) Blocking individual file write using explicit offsets
19032!> (serial) Unformatted stream write
19033!> \param[in] fh file handle (file storage unit)
19034!> \param[in] offset file offset (position)
19035!> \param[in] msg data to be written to the file
19036!> \param msglen ...
19037!> \par MPI-I/O mapping mpi_file_write_at
19038!> \par STREAM-I/O mapping WRITE
19039!> \param[in](optional) msglen number of the elements of data
19040! **************************************************************************************************
19041 SUBROUTINE mp_file_write_at_dv(fh, offset, msg, msglen)
19042 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
19043 CLASS(mp_file_type), INTENT(IN) :: fh
19044 INTEGER, INTENT(IN), OPTIONAL :: msglen
19045 INTEGER(kind=file_offset), INTENT(IN) :: offset
19046
19047 INTEGER :: msg_len
19048#if defined(__parallel)
19049 INTEGER :: ierr
19050#endif
19051
19052 msg_len = SIZE(msg)
19053 IF (PRESENT(msglen)) msg_len = msglen
19054#if defined(__parallel)
19055 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
19056 IF (ierr .NE. 0) &
19057 cpabort("mpi_file_write_at_dv @ mp_file_write_at_dv")
19058#else
19059 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
19060#endif
19061 END SUBROUTINE mp_file_write_at_dv
19062
19063! **************************************************************************************************
19064!> \brief ...
19065!> \param fh ...
19066!> \param offset ...
19067!> \param msg ...
19068! **************************************************************************************************
19069 SUBROUTINE mp_file_write_at_d (fh, offset, msg)
19070 REAL(kind=real_8), INTENT(IN) :: msg
19071 CLASS(mp_file_type), INTENT(IN) :: fh
19072 INTEGER(kind=file_offset), INTENT(IN) :: offset
19073
19074#if defined(__parallel)
19075 INTEGER :: ierr
19076
19077 ierr = 0
19078 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
19079 IF (ierr .NE. 0) &
19080 cpabort("mpi_file_write_at_d @ mp_file_write_at_d")
19081#else
19082 WRITE (unit=fh%handle, pos=offset + 1) msg
19083#endif
19084 END SUBROUTINE mp_file_write_at_d
19085
19086! **************************************************************************************************
19087!> \brief (parallel) Blocking collective file write using explicit offsets
19088!> (serial) Unformatted stream write
19089!> \param fh ...
19090!> \param offset ...
19091!> \param msg ...
19092!> \param msglen ...
19093!> \par MPI-I/O mapping mpi_file_write_at_all
19094!> \par STREAM-I/O mapping WRITE
19095! **************************************************************************************************
19096 SUBROUTINE mp_file_write_at_all_dv(fh, offset, msg, msglen)
19097 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
19098 CLASS(mp_file_type), INTENT(IN) :: fh
19099 INTEGER, INTENT(IN), OPTIONAL :: msglen
19100 INTEGER(kind=file_offset), INTENT(IN) :: offset
19101
19102 INTEGER :: msg_len
19103#if defined(__parallel)
19104 INTEGER :: ierr
19105#endif
19106
19107 msg_len = SIZE(msg)
19108 IF (PRESENT(msglen)) msg_len = msglen
19109#if defined(__parallel)
19110 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
19111 IF (ierr .NE. 0) &
19112 cpabort("mpi_file_write_at_all_dv @ mp_file_write_at_all_dv")
19113#else
19114 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
19115#endif
19116 END SUBROUTINE mp_file_write_at_all_dv
19117
19118! **************************************************************************************************
19119!> \brief ...
19120!> \param fh ...
19121!> \param offset ...
19122!> \param msg ...
19123! **************************************************************************************************
19124 SUBROUTINE mp_file_write_at_all_d (fh, offset, msg)
19125 REAL(kind=real_8), INTENT(IN) :: msg
19126 CLASS(mp_file_type), INTENT(IN) :: fh
19127 INTEGER(kind=file_offset), INTENT(IN) :: offset
19128
19129#if defined(__parallel)
19130 INTEGER :: ierr
19131
19132 ierr = 0
19133 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
19134 IF (ierr .NE. 0) &
19135 cpabort("mpi_file_write_at_all_d @ mp_file_write_at_all_d")
19136#else
19137 WRITE (unit=fh%handle, pos=offset + 1) msg
19138#endif
19139 END SUBROUTINE mp_file_write_at_all_d
19140
19141! **************************************************************************************************
19142!> \brief (parallel) Blocking individual file read using explicit offsets
19143!> (serial) Unformatted stream read
19144!> \param[in] fh file handle (file storage unit)
19145!> \param[in] offset file offset (position)
19146!> \param[out] msg data to be read from the file
19147!> \param msglen ...
19148!> \par MPI-I/O mapping mpi_file_read_at
19149!> \par STREAM-I/O mapping READ
19150!> \param[in](optional) msglen number of elements of data
19151! **************************************************************************************************
19152 SUBROUTINE mp_file_read_at_dv(fh, offset, msg, msglen)
19153 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
19154 CLASS(mp_file_type), INTENT(IN) :: fh
19155 INTEGER, INTENT(IN), OPTIONAL :: msglen
19156 INTEGER(kind=file_offset), INTENT(IN) :: offset
19157
19158 INTEGER :: msg_len
19159#if defined(__parallel)
19160 INTEGER :: ierr
19161#endif
19162
19163 msg_len = SIZE(msg)
19164 IF (PRESENT(msglen)) msg_len = msglen
19165#if defined(__parallel)
19166 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
19167 IF (ierr .NE. 0) &
19168 cpabort("mpi_file_read_at_dv @ mp_file_read_at_dv")
19169#else
19170 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
19171#endif
19172 END SUBROUTINE mp_file_read_at_dv
19173
19174! **************************************************************************************************
19175!> \brief ...
19176!> \param fh ...
19177!> \param offset ...
19178!> \param msg ...
19179! **************************************************************************************************
19180 SUBROUTINE mp_file_read_at_d (fh, offset, msg)
19181 REAL(kind=real_8), INTENT(OUT) :: msg
19182 CLASS(mp_file_type), INTENT(IN) :: fh
19183 INTEGER(kind=file_offset), INTENT(IN) :: offset
19184
19185#if defined(__parallel)
19186 INTEGER :: ierr
19187
19188 ierr = 0
19189 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
19190 IF (ierr .NE. 0) &
19191 cpabort("mpi_file_read_at_d @ mp_file_read_at_d")
19192#else
19193 READ (unit=fh%handle, pos=offset + 1) msg
19194#endif
19195 END SUBROUTINE mp_file_read_at_d
19196
19197! **************************************************************************************************
19198!> \brief (parallel) Blocking collective file read using explicit offsets
19199!> (serial) Unformatted stream read
19200!> \param fh ...
19201!> \param offset ...
19202!> \param msg ...
19203!> \param msglen ...
19204!> \par MPI-I/O mapping mpi_file_read_at_all
19205!> \par STREAM-I/O mapping READ
19206! **************************************************************************************************
19207 SUBROUTINE mp_file_read_at_all_dv(fh, offset, msg, msglen)
19208 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
19209 CLASS(mp_file_type), INTENT(IN) :: fh
19210 INTEGER, INTENT(IN), OPTIONAL :: msglen
19211 INTEGER(kind=file_offset), INTENT(IN) :: offset
19212
19213 INTEGER :: msg_len
19214#if defined(__parallel)
19215 INTEGER :: ierr
19216#endif
19217
19218 msg_len = SIZE(msg)
19219 IF (PRESENT(msglen)) msg_len = msglen
19220#if defined(__parallel)
19221 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
19222 IF (ierr .NE. 0) &
19223 cpabort("mpi_file_read_at_all_dv @ mp_file_read_at_all_dv")
19224#else
19225 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
19226#endif
19227 END SUBROUTINE mp_file_read_at_all_dv
19228
19229! **************************************************************************************************
19230!> \brief ...
19231!> \param fh ...
19232!> \param offset ...
19233!> \param msg ...
19234! **************************************************************************************************
19235 SUBROUTINE mp_file_read_at_all_d (fh, offset, msg)
19236 REAL(kind=real_8), INTENT(OUT) :: msg
19237 CLASS(mp_file_type), INTENT(IN) :: fh
19238 INTEGER(kind=file_offset), INTENT(IN) :: offset
19239
19240#if defined(__parallel)
19241 INTEGER :: ierr
19242
19243 ierr = 0
19244 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
19245 IF (ierr .NE. 0) &
19246 cpabort("mpi_file_read_at_all_d @ mp_file_read_at_all_d")
19247#else
19248 READ (unit=fh%handle, pos=offset + 1) msg
19249#endif
19250 END SUBROUTINE mp_file_read_at_all_d
19251
19252! **************************************************************************************************
19253!> \brief ...
19254!> \param ptr ...
19255!> \param vector_descriptor ...
19256!> \param index_descriptor ...
19257!> \return ...
19258! **************************************************************************************************
19259 FUNCTION mp_type_make_d (ptr, &
19260 vector_descriptor, index_descriptor) &
19261 result(type_descriptor)
19262 REAL(kind=real_8), DIMENSION(:), TARGET, asynchronous :: ptr
19263 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
19264 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
19265 TYPE(mp_type_descriptor_type) :: type_descriptor
19266
19267 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_d'
19268
19269#if defined(__parallel)
19270 INTEGER :: ierr
19271#if defined(__MPI_F08)
19272 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
19273 EXTERNAL :: mpi_get_address
19274#endif
19275#endif
19276
19277 NULLIFY (type_descriptor%subtype)
19278 type_descriptor%length = SIZE(ptr)
19279#if defined(__parallel)
19280 type_descriptor%type_handle = mpi_double_precision
19281 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
19282 IF (ierr /= 0) &
19283 cpabort("MPI_Get_address @ "//routinen)
19284#else
19285 type_descriptor%type_handle = 3
19286#endif
19287 type_descriptor%vector_descriptor(1:2) = 1
19288 type_descriptor%has_indexing = .false.
19289 type_descriptor%data_d => ptr
19290 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
19291 cpabort(routinen//": Vectors and indices NYI")
19292 END IF
19293 END FUNCTION mp_type_make_d
19294
19295! **************************************************************************************************
19296!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
19297!> as the Fortran version returns an integer, which we take to be a C_PTR
19298!> \param DATA data array to allocate
19299!> \param[in] len length (in data elements) of data array allocation
19300!> \param[out] stat (optional) allocation status result
19301! **************************************************************************************************
19302 SUBROUTINE mp_alloc_mem_d (DATA, len, stat)
19303 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
19304 INTEGER, INTENT(IN) :: len
19305 INTEGER, INTENT(OUT), OPTIONAL :: stat
19306
19307#if defined(__parallel)
19308 INTEGER :: size, ierr, length, &
19309 mp_res
19310 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
19311 TYPE(c_ptr) :: mp_baseptr
19312 mpi_info_type :: mp_info
19313
19314 length = max(len, 1)
19315 CALL mpi_type_size(mpi_double_precision, size, ierr)
19316 mp_size = int(length, kind=mpi_address_kind)*size
19317 IF (mp_size .GT. mp_max_memory_size) THEN
19318 cpabort("MPI cannot allocate more than 2 GiByte")
19319 END IF
19320 mp_info = mpi_info_null
19321 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
19322 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
19323 IF (PRESENT(stat)) stat = mp_res
19324#else
19325 INTEGER :: length, mystat
19326 length = max(len, 1)
19327 IF (PRESENT(stat)) THEN
19328 ALLOCATE (DATA(length), stat=mystat)
19329 stat = mystat ! show to convention checker that stat is used
19330 ELSE
19331 ALLOCATE (DATA(length))
19332 END IF
19333#endif
19334 END SUBROUTINE mp_alloc_mem_d
19335
19336! **************************************************************************************************
19337!> \brief Deallocates am array, ... this is hackish
19338!> as the Fortran version takes an integer, which we hope to get by reference
19339!> \param DATA data array to allocate
19340!> \param[out] stat (optional) allocation status result
19341! **************************************************************************************************
19342 SUBROUTINE mp_free_mem_d (DATA, stat)
19343 REAL(kind=real_8), DIMENSION(:), &
19344 POINTER, asynchronous :: DATA
19345 INTEGER, INTENT(OUT), OPTIONAL :: stat
19346
19347#if defined(__parallel)
19348 INTEGER :: mp_res
19349 CALL mpi_free_mem(DATA, mp_res)
19350 IF (PRESENT(stat)) stat = mp_res
19351#else
19352 DEALLOCATE (data)
19353 IF (PRESENT(stat)) stat = 0
19354#endif
19355 END SUBROUTINE mp_free_mem_d
19356! **************************************************************************************************
19357!> \brief Shift around the data in msg
19358!> \param[in,out] msg Rank-2 data to shift
19359!> \param[in] comm message passing environment identifier
19360!> \param[in] displ_in displacements (?)
19361!> \par Example
19362!> msg will be moved from rank to rank+displ_in (in a circular way)
19363!> \par Limitations
19364!> * displ_in will be 1 by default (others not tested)
19365!> * the message array needs to be the same size on all processes
19366! **************************************************************************************************
19367 SUBROUTINE mp_shift_rm(msg, comm, displ_in)
19368
19369 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
19370 CLASS(mp_comm_type), INTENT(IN) :: comm
19371 INTEGER, INTENT(IN), OPTIONAL :: displ_in
19372
19373 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_rm'
19374
19375 INTEGER :: handle, ierror
19376#if defined(__parallel)
19377 INTEGER :: displ, left, &
19378 msglen, myrank, nprocs, &
19379 right, tag
19380#endif
19381
19382 ierror = 0
19383 CALL mp_timeset(routinen, handle)
19384
19385#if defined(__parallel)
19386 CALL mpi_comm_rank(comm%handle, myrank, ierror)
19387 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
19388 CALL mpi_comm_size(comm%handle, nprocs, ierror)
19389 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
19390 IF (PRESENT(displ_in)) THEN
19391 displ = displ_in
19392 ELSE
19393 displ = 1
19394 END IF
19395 right = modulo(myrank + displ, nprocs)
19396 left = modulo(myrank - displ, nprocs)
19397 tag = 17
19398 msglen = SIZE(msg)
19399 CALL mpi_sendrecv_replace(msg, msglen, mpi_real, right, tag, left, tag, &
19400 comm%handle, mpi_status_ignore, ierror)
19401 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
19402 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_4_size)
19403#else
19404 mark_used(msg)
19405 mark_used(comm)
19406 mark_used(displ_in)
19407#endif
19408 CALL mp_timestop(handle)
19409
19410 END SUBROUTINE mp_shift_rm
19411
19412! **************************************************************************************************
19413!> \brief Shift around the data in msg
19414!> \param[in,out] msg Data to shift
19415!> \param[in] comm message passing environment identifier
19416!> \param[in] displ_in displacements (?)
19417!> \par Example
19418!> msg will be moved from rank to rank+displ_in (in a circular way)
19419!> \par Limitations
19420!> * displ_in will be 1 by default (others not tested)
19421!> * the message array needs to be the same size on all processes
19422! **************************************************************************************************
19423 SUBROUTINE mp_shift_r (msg, comm, displ_in)
19424
19425 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19426 CLASS(mp_comm_type), INTENT(IN) :: comm
19427 INTEGER, INTENT(IN), OPTIONAL :: displ_in
19428
19429 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_r'
19430
19431 INTEGER :: handle, ierror
19432#if defined(__parallel)
19433 INTEGER :: displ, left, &
19434 msglen, myrank, nprocs, &
19435 right, tag
19436#endif
19437
19438 ierror = 0
19439 CALL mp_timeset(routinen, handle)
19440
19441#if defined(__parallel)
19442 CALL mpi_comm_rank(comm%handle, myrank, ierror)
19443 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
19444 CALL mpi_comm_size(comm%handle, nprocs, ierror)
19445 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
19446 IF (PRESENT(displ_in)) THEN
19447 displ = displ_in
19448 ELSE
19449 displ = 1
19450 END IF
19451 right = modulo(myrank + displ, nprocs)
19452 left = modulo(myrank - displ, nprocs)
19453 tag = 19
19454 msglen = SIZE(msg)
19455 CALL mpi_sendrecv_replace(msg, msglen, mpi_real, right, tag, left, &
19456 tag, comm%handle, mpi_status_ignore, ierror)
19457 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
19458 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_4_size)
19459#else
19460 mark_used(msg)
19461 mark_used(comm)
19462 mark_used(displ_in)
19463#endif
19464 CALL mp_timestop(handle)
19465
19466 END SUBROUTINE mp_shift_r
19467
19468! **************************************************************************************************
19469!> \brief All-to-all data exchange, rank-1 data of different sizes
19470!> \param[in] sb Data to send
19471!> \param[in] scount Data counts for data sent to other processes
19472!> \param[in] sdispl Respective data offsets for data sent to process
19473!> \param[in,out] rb Buffer into which to receive data
19474!> \param[in] rcount Data counts for data received from other
19475!> processes
19476!> \param[in] rdispl Respective data offsets for data received from
19477!> other processes
19478!> \param[in] comm Message passing environment identifier
19479!> \par MPI mapping
19480!> mpi_alltoallv
19481!> \par Array sizes
19482!> The scount, rcount, and the sdispl and rdispl arrays have a
19483!> size equal to the number of processes.
19484!> \par Offsets
19485!> Values in sdispl and rdispl start with 0.
19486! **************************************************************************************************
19487 SUBROUTINE mp_alltoall_r11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
19488
19489 REAL(kind=real_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
19490 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
19491 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
19492 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
19493 CLASS(mp_comm_type), INTENT(IN) :: comm
19494
19495 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r11v'
19496
19497 INTEGER :: handle
19498#if defined(__parallel)
19499 INTEGER :: ierr, msglen
19500#else
19501 INTEGER :: i
19502#endif
19503
19504 CALL mp_timeset(routinen, handle)
19505
19506#if defined(__parallel)
19507 CALL mpi_alltoallv(sb, scount, sdispl, mpi_real, &
19508 rb, rcount, rdispl, mpi_real, comm%handle, ierr)
19509 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
19510 msglen = sum(scount) + sum(rcount)
19511 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19512#else
19513 mark_used(comm)
19514 mark_used(scount)
19515 mark_used(sdispl)
19516 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
19517 DO i = 1, rcount(1)
19518 rb(rdispl(1) + i) = sb(sdispl(1) + i)
19519 END DO
19520#endif
19521 CALL mp_timestop(handle)
19522
19523 END SUBROUTINE mp_alltoall_r11v
19524
19525! **************************************************************************************************
19526!> \brief All-to-all data exchange, rank-2 data of different sizes
19527!> \param sb ...
19528!> \param scount ...
19529!> \param sdispl ...
19530!> \param rb ...
19531!> \param rcount ...
19532!> \param rdispl ...
19533!> \param comm ...
19534!> \par MPI mapping
19535!> mpi_alltoallv
19536!> \note see mp_alltoall_r11v
19537! **************************************************************************************************
19538 SUBROUTINE mp_alltoall_r22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
19539
19540 REAL(kind=real_4), DIMENSION(:, :), &
19541 INTENT(IN), CONTIGUOUS :: sb
19542 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
19543 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, &
19544 INTENT(INOUT) :: rb
19545 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
19546 CLASS(mp_comm_type), INTENT(IN) :: comm
19547
19548 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r22v'
19549
19550 INTEGER :: handle
19551#if defined(__parallel)
19552 INTEGER :: ierr, msglen
19553#endif
19554
19555 CALL mp_timeset(routinen, handle)
19556
19557#if defined(__parallel)
19558 CALL mpi_alltoallv(sb, scount, sdispl, mpi_real, &
19559 rb, rcount, rdispl, mpi_real, comm%handle, ierr)
19560 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
19561 msglen = sum(scount) + sum(rcount)
19562 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*real_4_size)
19563#else
19564 mark_used(comm)
19565 mark_used(scount)
19566 mark_used(sdispl)
19567 mark_used(rcount)
19568 mark_used(rdispl)
19569 rb = sb
19570#endif
19571 CALL mp_timestop(handle)
19572
19573 END SUBROUTINE mp_alltoall_r22v
19574
19575! **************************************************************************************************
19576!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
19577!> \param[in] sb array with data to send
19578!> \param[out] rb array into which data is received
19579!> \param[in] count number of elements to send/receive (product of the
19580!> extents of the first two dimensions)
19581!> \param[in] comm Message passing environment identifier
19582!> \par Index meaning
19583!> \par The first two indices specify the data while the last index counts
19584!> the processes
19585!> \par Sizes of ranks
19586!> All processes have the same data size.
19587!> \par MPI mapping
19588!> mpi_alltoall
19589! **************************************************************************************************
19590 SUBROUTINE mp_alltoall_r (sb, rb, count, comm)
19591
19592 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
19593 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
19594 INTEGER, INTENT(IN) :: count
19595 CLASS(mp_comm_type), INTENT(IN) :: comm
19596
19597 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r'
19598
19599 INTEGER :: handle
19600#if defined(__parallel)
19601 INTEGER :: ierr, msglen, np
19602#endif
19603
19604 CALL mp_timeset(routinen, handle)
19605
19606#if defined(__parallel)
19607 CALL mpi_alltoall(sb, count, mpi_real, &
19608 rb, count, mpi_real, comm%handle, ierr)
19609 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19610 CALL mpi_comm_size(comm%handle, np, ierr)
19611 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19612 msglen = 2*count*np
19613 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19614#else
19615 mark_used(count)
19616 mark_used(comm)
19617 rb = sb
19618#endif
19619 CALL mp_timestop(handle)
19620
19621 END SUBROUTINE mp_alltoall_r
19622
19623! **************************************************************************************************
19624!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
19625!> \param sb ...
19626!> \param rb ...
19627!> \param count ...
19628!> \param commp ...
19629!> \note see mp_alltoall_r
19630! **************************************************************************************************
19631 SUBROUTINE mp_alltoall_r22(sb, rb, count, comm)
19632
19633 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
19634 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
19635 INTEGER, INTENT(IN) :: count
19636 CLASS(mp_comm_type), INTENT(IN) :: comm
19637
19638 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r22'
19639
19640 INTEGER :: handle
19641#if defined(__parallel)
19642 INTEGER :: ierr, msglen, np
19643#endif
19644
19645 CALL mp_timeset(routinen, handle)
19646
19647#if defined(__parallel)
19648 CALL mpi_alltoall(sb, count, mpi_real, &
19649 rb, count, mpi_real, comm%handle, ierr)
19650 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19651 CALL mpi_comm_size(comm%handle, np, ierr)
19652 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19653 msglen = 2*SIZE(sb)*np
19654 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19655#else
19656 mark_used(count)
19657 mark_used(comm)
19658 rb = sb
19659#endif
19660 CALL mp_timestop(handle)
19661
19662 END SUBROUTINE mp_alltoall_r22
19663
19664! **************************************************************************************************
19665!> \brief All-to-all data exchange, rank-3 data with equal sizes
19666!> \param sb ...
19667!> \param rb ...
19668!> \param count ...
19669!> \param comm ...
19670!> \note see mp_alltoall_r
19671! **************************************************************************************************
19672 SUBROUTINE mp_alltoall_r33(sb, rb, count, comm)
19673
19674 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
19675 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
19676 INTEGER, INTENT(IN) :: count
19677 CLASS(mp_comm_type), INTENT(IN) :: comm
19678
19679 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r33'
19680
19681 INTEGER :: handle
19682#if defined(__parallel)
19683 INTEGER :: ierr, msglen, np
19684#endif
19685
19686 CALL mp_timeset(routinen, handle)
19687
19688#if defined(__parallel)
19689 CALL mpi_alltoall(sb, count, mpi_real, &
19690 rb, count, mpi_real, comm%handle, ierr)
19691 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19692 CALL mpi_comm_size(comm%handle, np, ierr)
19693 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19694 msglen = 2*count*np
19695 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19696#else
19697 mark_used(count)
19698 mark_used(comm)
19699 rb = sb
19700#endif
19701 CALL mp_timestop(handle)
19702
19703 END SUBROUTINE mp_alltoall_r33
19704
19705! **************************************************************************************************
19706!> \brief All-to-all data exchange, rank 4 data, equal sizes
19707!> \param sb ...
19708!> \param rb ...
19709!> \param count ...
19710!> \param comm ...
19711!> \note see mp_alltoall_r
19712! **************************************************************************************************
19713 SUBROUTINE mp_alltoall_r44(sb, rb, count, comm)
19714
19715 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19716 INTENT(IN) :: sb
19717 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19718 INTENT(OUT) :: rb
19719 INTEGER, INTENT(IN) :: count
19720 CLASS(mp_comm_type), INTENT(IN) :: comm
19721
19722 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r44'
19723
19724 INTEGER :: handle
19725#if defined(__parallel)
19726 INTEGER :: ierr, msglen, np
19727#endif
19728
19729 CALL mp_timeset(routinen, handle)
19730
19731#if defined(__parallel)
19732 CALL mpi_alltoall(sb, count, mpi_real, &
19733 rb, count, mpi_real, comm%handle, ierr)
19734 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19735 CALL mpi_comm_size(comm%handle, np, ierr)
19736 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19737 msglen = 2*count*np
19738 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19739#else
19740 mark_used(count)
19741 mark_used(comm)
19742 rb = sb
19743#endif
19744 CALL mp_timestop(handle)
19745
19746 END SUBROUTINE mp_alltoall_r44
19747
19748! **************************************************************************************************
19749!> \brief All-to-all data exchange, rank 5 data, equal sizes
19750!> \param sb ...
19751!> \param rb ...
19752!> \param count ...
19753!> \param comm ...
19754!> \note see mp_alltoall_r
19755! **************************************************************************************************
19756 SUBROUTINE mp_alltoall_r55(sb, rb, count, comm)
19757
19758 REAL(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
19759 INTENT(IN) :: sb
19760 REAL(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
19761 INTENT(OUT) :: rb
19762 INTEGER, INTENT(IN) :: count
19763 CLASS(mp_comm_type), INTENT(IN) :: comm
19764
19765 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r55'
19766
19767 INTEGER :: handle
19768#if defined(__parallel)
19769 INTEGER :: ierr, msglen, np
19770#endif
19771
19772 CALL mp_timeset(routinen, handle)
19773
19774#if defined(__parallel)
19775 CALL mpi_alltoall(sb, count, mpi_real, &
19776 rb, count, mpi_real, comm%handle, ierr)
19777 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19778 CALL mpi_comm_size(comm%handle, np, ierr)
19779 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19780 msglen = 2*count*np
19781 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19782#else
19783 mark_used(count)
19784 mark_used(comm)
19785 rb = sb
19786#endif
19787 CALL mp_timestop(handle)
19788
19789 END SUBROUTINE mp_alltoall_r55
19790
19791! **************************************************************************************************
19792!> \brief All-to-all data exchange, rank-4 data to rank-5 data
19793!> \param sb ...
19794!> \param rb ...
19795!> \param count ...
19796!> \param comm ...
19797!> \note see mp_alltoall_r
19798!> \note User must ensure size consistency.
19799! **************************************************************************************************
19800 SUBROUTINE mp_alltoall_r45(sb, rb, count, comm)
19801
19802 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19803 INTENT(IN) :: sb
19804 REAL(kind=real_4), &
19805 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
19806 INTEGER, INTENT(IN) :: count
19807 CLASS(mp_comm_type), INTENT(IN) :: comm
19808
19809 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r45'
19810
19811 INTEGER :: handle
19812#if defined(__parallel)
19813 INTEGER :: ierr, msglen, np
19814#endif
19815
19816 CALL mp_timeset(routinen, handle)
19817
19818#if defined(__parallel)
19819 CALL mpi_alltoall(sb, count, mpi_real, &
19820 rb, count, mpi_real, comm%handle, ierr)
19821 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19822 CALL mpi_comm_size(comm%handle, np, ierr)
19823 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19824 msglen = 2*count*np
19825 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19826#else
19827 mark_used(count)
19828 mark_used(comm)
19829 rb = reshape(sb, shape(rb))
19830#endif
19831 CALL mp_timestop(handle)
19832
19833 END SUBROUTINE mp_alltoall_r45
19834
19835! **************************************************************************************************
19836!> \brief All-to-all data exchange, rank-3 data to rank-4 data
19837!> \param sb ...
19838!> \param rb ...
19839!> \param count ...
19840!> \param comm ...
19841!> \note see mp_alltoall_r
19842!> \note User must ensure size consistency.
19843! **************************************************************************************************
19844 SUBROUTINE mp_alltoall_r34(sb, rb, count, comm)
19845
19846 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, &
19847 INTENT(IN) :: sb
19848 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19849 INTENT(OUT) :: rb
19850 INTEGER, INTENT(IN) :: count
19851 CLASS(mp_comm_type), INTENT(IN) :: comm
19852
19853 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r34'
19854
19855 INTEGER :: handle
19856#if defined(__parallel)
19857 INTEGER :: ierr, msglen, np
19858#endif
19859
19860 CALL mp_timeset(routinen, handle)
19861
19862#if defined(__parallel)
19863 CALL mpi_alltoall(sb, count, mpi_real, &
19864 rb, count, mpi_real, comm%handle, ierr)
19865 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19866 CALL mpi_comm_size(comm%handle, np, ierr)
19867 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19868 msglen = 2*count*np
19869 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19870#else
19871 mark_used(count)
19872 mark_used(comm)
19873 rb = reshape(sb, shape(rb))
19874#endif
19875 CALL mp_timestop(handle)
19876
19877 END SUBROUTINE mp_alltoall_r34
19878
19879! **************************************************************************************************
19880!> \brief All-to-all data exchange, rank-5 data to rank-4 data
19881!> \param sb ...
19882!> \param rb ...
19883!> \param count ...
19884!> \param comm ...
19885!> \note see mp_alltoall_r
19886!> \note User must ensure size consistency.
19887! **************************************************************************************************
19888 SUBROUTINE mp_alltoall_r54(sb, rb, count, comm)
19889
19890 REAL(kind=real_4), &
19891 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
19892 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19893 INTENT(OUT) :: rb
19894 INTEGER, INTENT(IN) :: count
19895 CLASS(mp_comm_type), INTENT(IN) :: comm
19896
19897 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r54'
19898
19899 INTEGER :: handle
19900#if defined(__parallel)
19901 INTEGER :: ierr, msglen, np
19902#endif
19903
19904 CALL mp_timeset(routinen, handle)
19905
19906#if defined(__parallel)
19907 CALL mpi_alltoall(sb, count, mpi_real, &
19908 rb, count, mpi_real, comm%handle, ierr)
19909 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19910 CALL mpi_comm_size(comm%handle, np, ierr)
19911 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19912 msglen = 2*count*np
19913 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19914#else
19915 mark_used(count)
19916 mark_used(comm)
19917 rb = reshape(sb, shape(rb))
19918#endif
19919 CALL mp_timestop(handle)
19920
19921 END SUBROUTINE mp_alltoall_r54
19922
19923! **************************************************************************************************
19924!> \brief Send one datum to another process
19925!> \param[in] msg Scalar to send
19926!> \param[in] dest Destination process
19927!> \param[in] tag Transfer identifier
19928!> \param[in] comm Message passing environment identifier
19929!> \par MPI mapping
19930!> mpi_send
19931! **************************************************************************************************
19932 SUBROUTINE mp_send_r (msg, dest, tag, comm)
19933 REAL(kind=real_4), INTENT(IN) :: msg
19934 INTEGER, INTENT(IN) :: dest, tag
19935 CLASS(mp_comm_type), INTENT(IN) :: comm
19936
19937 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_r'
19938
19939 INTEGER :: handle
19940#if defined(__parallel)
19941 INTEGER :: ierr, msglen
19942#endif
19943
19944 CALL mp_timeset(routinen, handle)
19945
19946#if defined(__parallel)
19947 msglen = 1
19948 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19949 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19950 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19951#else
19952 mark_used(msg)
19953 mark_used(dest)
19954 mark_used(tag)
19955 mark_used(comm)
19956 ! only defined in parallel
19957 cpabort("not in parallel mode")
19958#endif
19959 CALL mp_timestop(handle)
19960 END SUBROUTINE mp_send_r
19961
19962! **************************************************************************************************
19963!> \brief Send rank-1 data to another process
19964!> \param[in] msg Rank-1 data to send
19965!> \param dest ...
19966!> \param tag ...
19967!> \param comm ...
19968!> \note see mp_send_r
19969! **************************************************************************************************
19970 SUBROUTINE mp_send_rv(msg, dest, tag, comm)
19971 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
19972 INTEGER, INTENT(IN) :: dest, tag
19973 CLASS(mp_comm_type), INTENT(IN) :: comm
19974
19975 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_rv'
19976
19977 INTEGER :: handle
19978#if defined(__parallel)
19979 INTEGER :: ierr, msglen
19980#endif
19981
19982 CALL mp_timeset(routinen, handle)
19983
19984#if defined(__parallel)
19985 msglen = SIZE(msg)
19986 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19987 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19988 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19989#else
19990 mark_used(msg)
19991 mark_used(dest)
19992 mark_used(tag)
19993 mark_used(comm)
19994 ! only defined in parallel
19995 cpabort("not in parallel mode")
19996#endif
19997 CALL mp_timestop(handle)
19998 END SUBROUTINE mp_send_rv
19999
20000! **************************************************************************************************
20001!> \brief Send rank-2 data to another process
20002!> \param[in] msg Rank-2 data to send
20003!> \param dest ...
20004!> \param tag ...
20005!> \param comm ...
20006!> \note see mp_send_r
20007! **************************************************************************************************
20008 SUBROUTINE mp_send_rm2(msg, dest, tag, comm)
20009 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
20010 INTEGER, INTENT(IN) :: dest, tag
20011 CLASS(mp_comm_type), INTENT(IN) :: comm
20012
20013 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_rm2'
20014
20015 INTEGER :: handle
20016#if defined(__parallel)
20017 INTEGER :: ierr, msglen
20018#endif
20019
20020 CALL mp_timeset(routinen, handle)
20021
20022#if defined(__parallel)
20023 msglen = SIZE(msg)
20024 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
20025 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
20026 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
20027#else
20028 mark_used(msg)
20029 mark_used(dest)
20030 mark_used(tag)
20031 mark_used(comm)
20032 ! only defined in parallel
20033 cpabort("not in parallel mode")
20034#endif
20035 CALL mp_timestop(handle)
20036 END SUBROUTINE mp_send_rm2
20037
20038! **************************************************************************************************
20039!> \brief Send rank-3 data to another process
20040!> \param[in] msg Rank-3 data to send
20041!> \param dest ...
20042!> \param tag ...
20043!> \param comm ...
20044!> \note see mp_send_r
20045! **************************************************************************************************
20046 SUBROUTINE mp_send_rm3(msg, dest, tag, comm)
20047 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
20048 INTEGER, INTENT(IN) :: dest, tag
20049 CLASS(mp_comm_type), INTENT(IN) :: comm
20050
20051 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
20052
20053 INTEGER :: handle
20054#if defined(__parallel)
20055 INTEGER :: ierr, msglen
20056#endif
20057
20058 CALL mp_timeset(routinen, handle)
20059
20060#if defined(__parallel)
20061 msglen = SIZE(msg)
20062 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
20063 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
20064 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
20065#else
20066 mark_used(msg)
20067 mark_used(dest)
20068 mark_used(tag)
20069 mark_used(comm)
20070 ! only defined in parallel
20071 cpabort("not in parallel mode")
20072#endif
20073 CALL mp_timestop(handle)
20074 END SUBROUTINE mp_send_rm3
20075
20076! **************************************************************************************************
20077!> \brief Receive one datum from another process
20078!> \param[in,out] msg Place received data into this variable
20079!> \param[in,out] source Process to receive from
20080!> \param[in,out] tag Transfer identifier
20081!> \param[in] comm Message passing environment identifier
20082!> \par MPI mapping
20083!> mpi_send
20084! **************************************************************************************************
20085 SUBROUTINE mp_recv_r (msg, source, tag, comm)
20086 REAL(kind=real_4), INTENT(INOUT) :: msg
20087 INTEGER, INTENT(INOUT) :: source, tag
20088 CLASS(mp_comm_type), INTENT(IN) :: comm
20089
20090 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_r'
20091
20092 INTEGER :: handle
20093#if defined(__parallel)
20094 INTEGER :: ierr, msglen
20095 mpi_status_type :: status
20096#endif
20097
20098 CALL mp_timeset(routinen, handle)
20099
20100#if defined(__parallel)
20101 msglen = 1
20102 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
20103 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
20104 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20105 ELSE
20106 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
20107 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20108 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
20109 source = status mpi_status_extract(mpi_source)
20110 tag = status mpi_status_extract(mpi_tag)
20111 END IF
20112#else
20113 mark_used(msg)
20114 mark_used(source)
20115 mark_used(tag)
20116 mark_used(comm)
20117 ! only defined in parallel
20118 cpabort("not in parallel mode")
20119#endif
20120 CALL mp_timestop(handle)
20121 END SUBROUTINE mp_recv_r
20122
20123! **************************************************************************************************
20124!> \brief Receive rank-1 data from another process
20125!> \param[in,out] msg Place received data into this rank-1 array
20126!> \param source ...
20127!> \param tag ...
20128!> \param comm ...
20129!> \note see mp_recv_r
20130! **************************************************************************************************
20131 SUBROUTINE mp_recv_rv(msg, source, tag, comm)
20132 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20133 INTEGER, INTENT(INOUT) :: source, tag
20134 CLASS(mp_comm_type), INTENT(IN) :: comm
20135
20136 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rv'
20137
20138 INTEGER :: handle
20139#if defined(__parallel)
20140 INTEGER :: ierr, msglen
20141 mpi_status_type :: status
20142#endif
20143
20144 CALL mp_timeset(routinen, handle)
20145
20146#if defined(__parallel)
20147 msglen = SIZE(msg)
20148 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
20149 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
20150 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20151 ELSE
20152 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
20153 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20154 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
20155 source = status mpi_status_extract(mpi_source)
20156 tag = status mpi_status_extract(mpi_tag)
20157 END IF
20158#else
20159 mark_used(msg)
20160 mark_used(source)
20161 mark_used(tag)
20162 mark_used(comm)
20163 ! only defined in parallel
20164 cpabort("not in parallel mode")
20165#endif
20166 CALL mp_timestop(handle)
20167 END SUBROUTINE mp_recv_rv
20168
20169! **************************************************************************************************
20170!> \brief Receive rank-2 data from another process
20171!> \param[in,out] msg Place received data into this rank-2 array
20172!> \param source ...
20173!> \param tag ...
20174!> \param comm ...
20175!> \note see mp_recv_r
20176! **************************************************************************************************
20177 SUBROUTINE mp_recv_rm2(msg, source, tag, comm)
20178 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20179 INTEGER, INTENT(INOUT) :: source, tag
20180 CLASS(mp_comm_type), INTENT(IN) :: comm
20181
20182 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rm2'
20183
20184 INTEGER :: handle
20185#if defined(__parallel)
20186 INTEGER :: ierr, msglen
20187 mpi_status_type :: status
20188#endif
20189
20190 CALL mp_timeset(routinen, handle)
20191
20192#if defined(__parallel)
20193 msglen = SIZE(msg)
20194 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
20195 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
20196 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20197 ELSE
20198 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
20199 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20200 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
20201 source = status mpi_status_extract(mpi_source)
20202 tag = status mpi_status_extract(mpi_tag)
20203 END IF
20204#else
20205 mark_used(msg)
20206 mark_used(source)
20207 mark_used(tag)
20208 mark_used(comm)
20209 ! only defined in parallel
20210 cpabort("not in parallel mode")
20211#endif
20212 CALL mp_timestop(handle)
20213 END SUBROUTINE mp_recv_rm2
20214
20215! **************************************************************************************************
20216!> \brief Receive rank-3 data from another process
20217!> \param[in,out] msg Place received data into this rank-3 array
20218!> \param source ...
20219!> \param tag ...
20220!> \param comm ...
20221!> \note see mp_recv_r
20222! **************************************************************************************************
20223 SUBROUTINE mp_recv_rm3(msg, source, tag, comm)
20224 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
20225 INTEGER, INTENT(INOUT) :: source, tag
20226 CLASS(mp_comm_type), INTENT(IN) :: comm
20227
20228 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rm3'
20229
20230 INTEGER :: handle
20231#if defined(__parallel)
20232 INTEGER :: ierr, msglen
20233 mpi_status_type :: status
20234#endif
20235
20236 CALL mp_timeset(routinen, handle)
20237
20238#if defined(__parallel)
20239 msglen = SIZE(msg)
20240 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
20241 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
20242 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20243 ELSE
20244 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
20245 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20246 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
20247 source = status mpi_status_extract(mpi_source)
20248 tag = status mpi_status_extract(mpi_tag)
20249 END IF
20250#else
20251 mark_used(msg)
20252 mark_used(source)
20253 mark_used(tag)
20254 mark_used(comm)
20255 ! only defined in parallel
20256 cpabort("not in parallel mode")
20257#endif
20258 CALL mp_timestop(handle)
20259 END SUBROUTINE mp_recv_rm3
20260
20261! **************************************************************************************************
20262!> \brief Broadcasts a datum to all processes.
20263!> \param[in] msg Datum to broadcast
20264!> \param[in] source Processes which broadcasts
20265!> \param[in] comm Message passing environment identifier
20266!> \par MPI mapping
20267!> mpi_bcast
20268! **************************************************************************************************
20269 SUBROUTINE mp_bcast_r (msg, source, comm)
20270 REAL(kind=real_4), INTENT(INOUT) :: msg
20271 INTEGER, INTENT(IN) :: source
20272 CLASS(mp_comm_type), INTENT(IN) :: comm
20273
20274 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r'
20275
20276 INTEGER :: handle
20277#if defined(__parallel)
20278 INTEGER :: ierr, msglen
20279#endif
20280
20281 CALL mp_timeset(routinen, handle)
20282
20283#if defined(__parallel)
20284 msglen = 1
20285 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20286 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20287 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20288#else
20289 mark_used(msg)
20290 mark_used(source)
20291 mark_used(comm)
20292#endif
20293 CALL mp_timestop(handle)
20294 END SUBROUTINE mp_bcast_r
20295
20296! **************************************************************************************************
20297!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
20298!> \param[in] msg Datum to broadcast
20299!> \param[in] comm Message passing environment identifier
20300!> \par MPI mapping
20301!> mpi_bcast
20302! **************************************************************************************************
20303 SUBROUTINE mp_bcast_r_src(msg, comm)
20304 REAL(kind=real_4), INTENT(INOUT) :: msg
20305 CLASS(mp_comm_type), INTENT(IN) :: comm
20306
20307 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r_src'
20308
20309 INTEGER :: handle
20310#if defined(__parallel)
20311 INTEGER :: ierr, msglen
20312#endif
20313
20314 CALL mp_timeset(routinen, handle)
20315
20316#if defined(__parallel)
20317 msglen = 1
20318 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20319 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20320 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20321#else
20322 mark_used(msg)
20323 mark_used(comm)
20324#endif
20325 CALL mp_timestop(handle)
20326 END SUBROUTINE mp_bcast_r_src
20327
20328! **************************************************************************************************
20329!> \brief Broadcasts a datum to all processes.
20330!> \param[in] msg Datum to broadcast
20331!> \param[in] source Processes which broadcasts
20332!> \param[in] comm Message passing environment identifier
20333!> \par MPI mapping
20334!> mpi_bcast
20335! **************************************************************************************************
20336 SUBROUTINE mp_ibcast_r (msg, source, comm, request)
20337 REAL(kind=real_4), INTENT(INOUT) :: msg
20338 INTEGER, INTENT(IN) :: source
20339 CLASS(mp_comm_type), INTENT(IN) :: comm
20340 TYPE(mp_request_type), INTENT(OUT) :: request
20341
20342 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_r'
20343
20344 INTEGER :: handle
20345#if defined(__parallel)
20346 INTEGER :: ierr, msglen
20347#endif
20348
20349 CALL mp_timeset(routinen, handle)
20350
20351#if defined(__parallel)
20352 msglen = 1
20353 CALL mpi_ibcast(msg, msglen, mpi_real, source, comm%handle, request%handle, ierr)
20354 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
20355 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_4_size)
20356#else
20357 mark_used(msg)
20358 mark_used(source)
20359 mark_used(comm)
20360 request = mp_request_null
20361#endif
20362 CALL mp_timestop(handle)
20363 END SUBROUTINE mp_ibcast_r
20364
20365! **************************************************************************************************
20366!> \brief Broadcasts rank-1 data to all processes
20367!> \param[in] msg Data to broadcast
20368!> \param source ...
20369!> \param comm ...
20370!> \note see mp_bcast_r1
20371! **************************************************************************************************
20372 SUBROUTINE mp_bcast_rv(msg, source, comm)
20373 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20374 INTEGER, INTENT(IN) :: source
20375 CLASS(mp_comm_type), INTENT(IN) :: comm
20376
20377 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rv'
20378
20379 INTEGER :: handle
20380#if defined(__parallel)
20381 INTEGER :: ierr, msglen
20382#endif
20383
20384 CALL mp_timeset(routinen, handle)
20385
20386#if defined(__parallel)
20387 msglen = SIZE(msg)
20388 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20389 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20390 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20391#else
20392 mark_used(msg)
20393 mark_used(source)
20394 mark_used(comm)
20395#endif
20396 CALL mp_timestop(handle)
20397 END SUBROUTINE mp_bcast_rv
20398
20399! **************************************************************************************************
20400!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
20401!> \param[in] msg Data to broadcast
20402!> \param comm ...
20403!> \note see mp_bcast_r1
20404! **************************************************************************************************
20405 SUBROUTINE mp_bcast_rv_src(msg, comm)
20406 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20407 CLASS(mp_comm_type), INTENT(IN) :: comm
20408
20409 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rv_src'
20410
20411 INTEGER :: handle
20412#if defined(__parallel)
20413 INTEGER :: ierr, msglen
20414#endif
20415
20416 CALL mp_timeset(routinen, handle)
20417
20418#if defined(__parallel)
20419 msglen = SIZE(msg)
20420 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20421 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20422 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20423#else
20424 mark_used(msg)
20425 mark_used(comm)
20426#endif
20427 CALL mp_timestop(handle)
20428 END SUBROUTINE mp_bcast_rv_src
20429
20430! **************************************************************************************************
20431!> \brief Broadcasts rank-1 data to all processes
20432!> \param[in] msg Data to broadcast
20433!> \param source ...
20434!> \param comm ...
20435!> \note see mp_bcast_r1
20436! **************************************************************************************************
20437 SUBROUTINE mp_ibcast_rv(msg, source, comm, request)
20438 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20439 INTEGER, INTENT(IN) :: source
20440 CLASS(mp_comm_type), INTENT(IN) :: comm
20441 TYPE(mp_request_type) :: request
20442
20443 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_rv'
20444
20445 INTEGER :: handle
20446#if defined(__parallel)
20447 INTEGER :: ierr, msglen
20448#endif
20449
20450 CALL mp_timeset(routinen, handle)
20451
20452#if defined(__parallel)
20453#if !defined(__GNUC__) || __GNUC__ >= 9
20454 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
20455#endif
20456 msglen = SIZE(msg)
20457 CALL mpi_ibcast(msg, msglen, mpi_real, source, comm%handle, request%handle, ierr)
20458 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
20459 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_4_size)
20460#else
20461 mark_used(msg)
20462 mark_used(source)
20463 mark_used(comm)
20464 request = mp_request_null
20465#endif
20466 CALL mp_timestop(handle)
20467 END SUBROUTINE mp_ibcast_rv
20468
20469! **************************************************************************************************
20470!> \brief Broadcasts rank-2 data to all processes
20471!> \param[in] msg Data to broadcast
20472!> \param source ...
20473!> \param comm ...
20474!> \note see mp_bcast_r1
20475! **************************************************************************************************
20476 SUBROUTINE mp_bcast_rm(msg, source, comm)
20477 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20478 INTEGER, INTENT(IN) :: source
20479 CLASS(mp_comm_type), INTENT(IN) :: comm
20480
20481 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rm'
20482
20483 INTEGER :: handle
20484#if defined(__parallel)
20485 INTEGER :: ierr, msglen
20486#endif
20487
20488 CALL mp_timeset(routinen, handle)
20489
20490#if defined(__parallel)
20491 msglen = SIZE(msg)
20492 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20493 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20494 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20495#else
20496 mark_used(msg)
20497 mark_used(source)
20498 mark_used(comm)
20499#endif
20500 CALL mp_timestop(handle)
20501 END SUBROUTINE mp_bcast_rm
20502
20503! **************************************************************************************************
20504!> \brief Broadcasts rank-2 data to all processes
20505!> \param[in] msg Data to broadcast
20506!> \param source ...
20507!> \param comm ...
20508!> \note see mp_bcast_r1
20509! **************************************************************************************************
20510 SUBROUTINE mp_bcast_rm_src(msg, comm)
20511 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20512 CLASS(mp_comm_type), INTENT(IN) :: comm
20513
20514 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rm_src'
20515
20516 INTEGER :: handle
20517#if defined(__parallel)
20518 INTEGER :: ierr, msglen
20519#endif
20520
20521 CALL mp_timeset(routinen, handle)
20522
20523#if defined(__parallel)
20524 msglen = SIZE(msg)
20525 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20526 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20527 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20528#else
20529 mark_used(msg)
20530 mark_used(comm)
20531#endif
20532 CALL mp_timestop(handle)
20533 END SUBROUTINE mp_bcast_rm_src
20534
20535! **************************************************************************************************
20536!> \brief Broadcasts rank-3 data to all processes
20537!> \param[in] msg Data to broadcast
20538!> \param source ...
20539!> \param comm ...
20540!> \note see mp_bcast_r1
20541! **************************************************************************************************
20542 SUBROUTINE mp_bcast_r3(msg, source, comm)
20543 REAL(kind=real_4), CONTIGUOUS :: msg(:, :, :)
20544 INTEGER, INTENT(IN) :: source
20545 CLASS(mp_comm_type), INTENT(IN) :: comm
20546
20547 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r3'
20548
20549 INTEGER :: handle
20550#if defined(__parallel)
20551 INTEGER :: ierr, msglen
20552#endif
20553
20554 CALL mp_timeset(routinen, handle)
20555
20556#if defined(__parallel)
20557 msglen = SIZE(msg)
20558 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20559 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20560 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20561#else
20562 mark_used(msg)
20563 mark_used(source)
20564 mark_used(comm)
20565#endif
20566 CALL mp_timestop(handle)
20567 END SUBROUTINE mp_bcast_r3
20568
20569! **************************************************************************************************
20570!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
20571!> \param[in] msg Data to broadcast
20572!> \param source ...
20573!> \param comm ...
20574!> \note see mp_bcast_r1
20575! **************************************************************************************************
20576 SUBROUTINE mp_bcast_r3_src(msg, comm)
20577 REAL(kind=real_4), CONTIGUOUS :: msg(:, :, :)
20578 CLASS(mp_comm_type), INTENT(IN) :: comm
20579
20580 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r3_src'
20581
20582 INTEGER :: handle
20583#if defined(__parallel)
20584 INTEGER :: ierr, msglen
20585#endif
20586
20587 CALL mp_timeset(routinen, handle)
20588
20589#if defined(__parallel)
20590 msglen = SIZE(msg)
20591 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20592 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20593 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20594#else
20595 mark_used(msg)
20596 mark_used(comm)
20597#endif
20598 CALL mp_timestop(handle)
20599 END SUBROUTINE mp_bcast_r3_src
20600
20601! **************************************************************************************************
20602!> \brief Sums a datum from all processes with result left on all processes.
20603!> \param[in,out] msg Datum to sum (input) and result (output)
20604!> \param[in] comm Message passing environment identifier
20605!> \par MPI mapping
20606!> mpi_allreduce
20607! **************************************************************************************************
20608 SUBROUTINE mp_sum_r (msg, comm)
20609 REAL(kind=real_4), INTENT(INOUT) :: msg
20610 CLASS(mp_comm_type), INTENT(IN) :: comm
20611
20612 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_r'
20613
20614 INTEGER :: handle
20615#if defined(__parallel)
20616 INTEGER :: ierr, msglen
20617 REAL(kind=real_4) :: res
20618#endif
20619
20620 CALL mp_timeset(routinen, handle)
20621
20622#if defined(__parallel)
20623 msglen = 1
20624 IF (comm%num_pe > 1) THEN
20625 CALL mpi_allreduce(msg, res, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20626 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20627 msg = res
20628 END IF
20629 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20630#else
20631 mark_used(msg)
20632 mark_used(comm)
20633#endif
20634 CALL mp_timestop(handle)
20635 END SUBROUTINE mp_sum_r
20636
20637! **************************************************************************************************
20638!> \brief Element-wise sum of a rank-1 array on all processes.
20639!> \param[in,out] msg Vector to sum and result
20640!> \param comm ...
20641!> \note see mp_sum_r
20642! **************************************************************************************************
20643 SUBROUTINE mp_sum_rv(msg, comm)
20644 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20645 CLASS(mp_comm_type), INTENT(IN) :: comm
20646
20647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rv'
20648
20649 INTEGER :: handle
20650#if defined(__parallel)
20651 INTEGER :: ierr, msglen
20652 REAL(kind=real_4), ALLOCATABLE :: msgbuf(:)
20653#endif
20654
20655 CALL mp_timeset(routinen, handle)
20656
20657#if defined(__parallel)
20658 msglen = SIZE(msg)
20659 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
20660 ALLOCATE (msgbuf(msglen))
20661 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20662 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20663 msg = msgbuf
20664 END IF
20665 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20666#else
20667 mark_used(msg)
20668 mark_used(comm)
20669#endif
20670 CALL mp_timestop(handle)
20671 END SUBROUTINE mp_sum_rv
20672
20673! **************************************************************************************************
20674!> \brief Element-wise sum of a rank-1 array on all processes.
20675!> \param[in,out] msg Vector to sum and result
20676!> \param comm ...
20677!> \note see mp_sum_r
20678! **************************************************************************************************
20679 SUBROUTINE mp_isum_rv(msg, comm, request)
20680 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20681 CLASS(mp_comm_type), INTENT(IN) :: comm
20682 TYPE(mp_request_type), INTENT(OUT) :: request
20683
20684 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_rv'
20685
20686 INTEGER :: handle
20687#if defined(__parallel)
20688 INTEGER :: ierr, msglen
20689#endif
20690
20691 CALL mp_timeset(routinen, handle)
20692
20693#if defined(__parallel)
20694#if !defined(__GNUC__) || __GNUC__ >= 9
20695 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
20696#endif
20697 msglen = SIZE(msg)
20698 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
20699 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, request%handle, ierr)
20700 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
20701 ELSE
20702 request = mp_request_null
20703 END IF
20704 CALL add_perf(perf_id=23, count=1, msg_size=msglen*real_4_size)
20705#else
20706 mark_used(msg)
20707 mark_used(comm)
20708 request = mp_request_null
20709#endif
20710 CALL mp_timestop(handle)
20711 END SUBROUTINE mp_isum_rv
20712
20713! **************************************************************************************************
20714!> \brief Element-wise sum of a rank-2 array on all processes.
20715!> \param[in] msg Matrix to sum and result
20716!> \param comm ...
20717!> \note see mp_sum_r
20718! **************************************************************************************************
20719 SUBROUTINE mp_sum_rm(msg, comm)
20720 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20721 CLASS(mp_comm_type), INTENT(IN) :: comm
20722
20723 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm'
20724
20725 INTEGER :: handle
20726#if defined(__parallel)
20727 INTEGER, PARAMETER :: max_msg = 2**25
20728 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
20729 REAL(kind=real_4), ALLOCATABLE :: msgbuf(:)
20730#endif
20731
20732 CALL mp_timeset(routinen, handle)
20733
20734#if defined(__parallel)
20735 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
20736 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
20737 msglensum = 0
20738 DO m1 = lbound(msg, 2), ubound(msg, 2), step
20739 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
20740 msglensum = msglensum + msglen
20741 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
20742 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
20743 ALLOCATE (msgbuf(msglen))
20744 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20745 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20746 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
20747 DEALLOCATE (msgbuf)
20748 END IF
20749 END DO
20750 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_4_size)
20751#else
20752 mark_used(msg)
20753 mark_used(comm)
20754#endif
20755 CALL mp_timestop(handle)
20756 END SUBROUTINE mp_sum_rm
20757
20758! **************************************************************************************************
20759!> \brief Element-wise sum of a rank-3 array on all processes.
20760!> \param[in] msg Array to sum and result
20761!> \param comm ...
20762!> \note see mp_sum_r
20763! **************************************************************************************************
20764 SUBROUTINE mp_sum_rm3(msg, comm)
20765 REAL(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
20766 CLASS(mp_comm_type), INTENT(IN) :: comm
20767
20768 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm3'
20769
20770 INTEGER :: handle
20771#if defined(__parallel)
20772 INTEGER :: ierr, msglen
20773 REAL(kind=real_4), ALLOCATABLE :: msgbuf(:)
20774#endif
20775
20776 CALL mp_timeset(routinen, handle)
20777
20778#if defined(__parallel)
20779 msglen = SIZE(msg)
20780 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
20781 ALLOCATE (msgbuf(msglen))
20782 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20783 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20784 msg = reshape(msgbuf, shape(msg))
20785 END IF
20786 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20787#else
20788 mark_used(msg)
20789 mark_used(comm)
20790#endif
20791 CALL mp_timestop(handle)
20792 END SUBROUTINE mp_sum_rm3
20793
20794! **************************************************************************************************
20795!> \brief Element-wise sum of a rank-4 array on all processes.
20796!> \param[in] msg Array to sum and result
20797!> \param comm ...
20798!> \note see mp_sum_r
20799! **************************************************************************************************
20800 SUBROUTINE mp_sum_rm4(msg, comm)
20801 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
20802 CLASS(mp_comm_type), INTENT(IN) :: comm
20803
20804 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm4'
20805
20806 INTEGER :: handle
20807#if defined(__parallel)
20808 INTEGER :: ierr, msglen
20809 REAL(kind=real_4), ALLOCATABLE :: msgbuf(:)
20810#endif
20811
20812 CALL mp_timeset(routinen, handle)
20813
20814#if defined(__parallel)
20815 msglen = SIZE(msg)
20816 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
20817 ALLOCATE (msgbuf(msglen))
20818 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20819 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20820 msg = reshape(msgbuf, shape(msg))
20821 END IF
20822 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20823#else
20824 mark_used(msg)
20825 mark_used(comm)
20826#endif
20827 CALL mp_timestop(handle)
20828 END SUBROUTINE mp_sum_rm4
20829
20830! **************************************************************************************************
20831!> \brief Element-wise sum of data from all processes with result left only on
20832!> one.
20833!> \param[in,out] msg Vector to sum (input) and (only on process root)
20834!> result (output)
20835!> \param root ...
20836!> \param[in] comm Message passing environment identifier
20837!> \par MPI mapping
20838!> mpi_reduce
20839! **************************************************************************************************
20840 SUBROUTINE mp_sum_root_rv(msg, root, comm)
20841 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20842 INTEGER, INTENT(IN) :: root
20843 CLASS(mp_comm_type), INTENT(IN) :: comm
20844
20845 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rv'
20846
20847 INTEGER :: handle
20848#if defined(__parallel)
20849 INTEGER :: ierr, m1, msglen, taskid
20850 REAL(kind=real_4), ALLOCATABLE :: res(:)
20851#endif
20852
20853 CALL mp_timeset(routinen, handle)
20854
20855#if defined(__parallel)
20856 msglen = SIZE(msg)
20857 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20858 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20859 IF (msglen > 0) THEN
20860 m1 = SIZE(msg, 1)
20861 ALLOCATE (res(m1))
20862 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_sum, &
20863 root, comm%handle, ierr)
20864 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20865 IF (taskid == root) THEN
20866 msg = res
20867 END IF
20868 DEALLOCATE (res)
20869 END IF
20870 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20871#else
20872 mark_used(msg)
20873 mark_used(root)
20874 mark_used(comm)
20875#endif
20876 CALL mp_timestop(handle)
20877 END SUBROUTINE mp_sum_root_rv
20878
20879! **************************************************************************************************
20880!> \brief Element-wise sum of data from all processes with result left only on
20881!> one.
20882!> \param[in,out] msg Matrix to sum (input) and (only on process root)
20883!> result (output)
20884!> \param root ...
20885!> \param comm ...
20886!> \note see mp_sum_root_rv
20887! **************************************************************************************************
20888 SUBROUTINE mp_sum_root_rm(msg, root, comm)
20889 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20890 INTEGER, INTENT(IN) :: root
20891 CLASS(mp_comm_type), INTENT(IN) :: comm
20892
20893 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
20894
20895 INTEGER :: handle
20896#if defined(__parallel)
20897 INTEGER :: ierr, m1, m2, msglen, taskid
20898 REAL(kind=real_4), ALLOCATABLE :: res(:, :)
20899#endif
20900
20901 CALL mp_timeset(routinen, handle)
20902
20903#if defined(__parallel)
20904 msglen = SIZE(msg)
20905 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20906 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20907 IF (msglen > 0) THEN
20908 m1 = SIZE(msg, 1)
20909 m2 = SIZE(msg, 2)
20910 ALLOCATE (res(m1, m2))
20911 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_sum, root, comm%handle, ierr)
20912 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20913 IF (taskid == root) THEN
20914 msg = res
20915 END IF
20916 DEALLOCATE (res)
20917 END IF
20918 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20919#else
20920 mark_used(root)
20921 mark_used(msg)
20922 mark_used(comm)
20923#endif
20924 CALL mp_timestop(handle)
20925 END SUBROUTINE mp_sum_root_rm
20926
20927! **************************************************************************************************
20928!> \brief Partial sum of data from all processes with result on each process.
20929!> \param[in] msg Matrix to sum (input)
20930!> \param[out] res Matrix containing result (output)
20931!> \param[in] comm Message passing environment identifier
20932! **************************************************************************************************
20933 SUBROUTINE mp_sum_partial_rm(msg, res, comm)
20934 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
20935 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
20936 CLASS(mp_comm_type), INTENT(IN) :: comm
20937
20938 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_rm'
20939
20940 INTEGER :: handle
20941#if defined(__parallel)
20942 INTEGER :: ierr, msglen, taskid
20943#endif
20944
20945 CALL mp_timeset(routinen, handle)
20946
20947#if defined(__parallel)
20948 msglen = SIZE(msg)
20949 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20950 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20951 IF (msglen > 0) THEN
20952 CALL mpi_scan(msg, res, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20953 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
20954 END IF
20955 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20956 ! perf_id is same as for other summation routines
20957#else
20958 res = msg
20959 mark_used(comm)
20960#endif
20961 CALL mp_timestop(handle)
20962 END SUBROUTINE mp_sum_partial_rm
20963
20964! **************************************************************************************************
20965!> \brief Finds the maximum of a datum with the result left on all processes.
20966!> \param[in,out] msg Find maximum among these data (input) and
20967!> maximum (output)
20968!> \param[in] comm Message passing environment identifier
20969!> \par MPI mapping
20970!> mpi_allreduce
20971! **************************************************************************************************
20972 SUBROUTINE mp_max_r (msg, comm)
20973 REAL(kind=real_4), INTENT(INOUT) :: msg
20974 CLASS(mp_comm_type), INTENT(IN) :: comm
20975
20976 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_r'
20977
20978 INTEGER :: handle
20979#if defined(__parallel)
20980 INTEGER :: ierr, msglen
20981 REAL(kind=real_4) :: res
20982#endif
20983
20984 CALL mp_timeset(routinen, handle)
20985
20986#if defined(__parallel)
20987 msglen = 1
20988 IF (comm%num_pe > 1) THEN
20989 CALL mpi_allreduce(msg, res, msglen, mpi_real, mpi_max, comm%handle, ierr)
20990 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20991 msg = res
20992 END IF
20993 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20994#else
20995 mark_used(msg)
20996 mark_used(comm)
20997#endif
20998 CALL mp_timestop(handle)
20999 END SUBROUTINE mp_max_r
21000
21001! **************************************************************************************************
21002!> \brief Finds the maximum of a datum with the result left on all processes.
21003!> \param[in,out] msg Find maximum among these data (input) and
21004!> maximum (output)
21005!> \param[in] comm Message passing environment identifier
21006!> \par MPI mapping
21007!> mpi_allreduce
21008! **************************************************************************************************
21009 SUBROUTINE mp_max_root_r (msg, root, comm)
21010 REAL(kind=real_4), INTENT(INOUT) :: msg
21011 INTEGER, INTENT(IN) :: root
21012 CLASS(mp_comm_type), INTENT(IN) :: comm
21013
21014 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_r'
21015
21016 INTEGER :: handle
21017#if defined(__parallel)
21018 INTEGER :: ierr, msglen
21019 REAL(kind=real_4) :: res
21020#endif
21021
21022 CALL mp_timeset(routinen, handle)
21023
21024#if defined(__parallel)
21025 msglen = 1
21026 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_max, root, comm%handle, ierr)
21027 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
21028 IF (root == comm%mepos) msg = res
21029 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
21030#else
21031 mark_used(msg)
21032 mark_used(comm)
21033 mark_used(root)
21034#endif
21035 CALL mp_timestop(handle)
21036 END SUBROUTINE mp_max_root_r
21037
21038! **************************************************************************************************
21039!> \brief Finds the element-wise maximum of a vector with the result left on
21040!> all processes.
21041!> \param[in,out] msg Find maximum among these data (input) and
21042!> maximum (output)
21043!> \param comm ...
21044!> \note see mp_max_r
21045! **************************************************************************************************
21046 SUBROUTINE mp_max_rv(msg, comm)
21047 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
21048 CLASS(mp_comm_type), INTENT(IN) :: comm
21049
21050 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_rv'
21051
21052 INTEGER :: handle
21053#if defined(__parallel)
21054 INTEGER :: ierr, msglen
21055 REAL(kind=real_4), ALLOCATABLE :: msgbuf(:)
21056#endif
21057
21058 CALL mp_timeset(routinen, handle)
21059
21060#if defined(__parallel)
21061 msglen = SIZE(msg)
21062 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
21063 ALLOCATE (msgbuf(msglen))
21064 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_real, mpi_max, comm%handle, ierr)
21065 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
21066 msg = msgbuf
21067 END IF
21068 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
21069#else
21070 mark_used(msg)
21071 mark_used(comm)
21072#endif
21073 CALL mp_timestop(handle)
21074 END SUBROUTINE mp_max_rv
21075
21076! **************************************************************************************************
21077!> \brief Finds the element-wise maximum of a rank2-array with the result left on
21078!> all processes.
21079!> \param[in] msg Matrix - Find maximum among these data (input) and
21080!> maximum (output)
21081!> \param comm ...
21082!> \note see mp_max_r
21083! **************************************************************************************************
21084 SUBROUTINE mp_max_rm(msg, comm)
21085 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
21086 CLASS(mp_comm_type), INTENT(IN) :: comm
21087
21088 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_rm'
21089
21090 INTEGER :: handle
21091#if defined(__parallel)
21092 INTEGER, PARAMETER :: max_msg = 2**25
21093 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
21094 REAL(kind=real_4), ALLOCATABLE :: msgbuf(:)
21095#endif
21096
21097 CALL mp_timeset(routinen, handle)
21098
21099#if defined(__parallel)
21100 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
21101 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
21102 msglensum = 0
21103 DO m1 = lbound(msg, 2), ubound(msg, 2), step
21104 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
21105 msglensum = msglensum + msglen
21106 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
21107 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
21108 ALLOCATE (msgbuf(msglen))
21109 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_real, mpi_max, comm%handle, ierr)
21110 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
21111 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
21112 DEALLOCATE (msgbuf)
21113 END IF
21114 END DO
21115 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_4_size)
21116#else
21117 mark_used(msg)
21118 mark_used(comm)
21119#endif
21120 CALL mp_timestop(handle)
21121 END SUBROUTINE mp_max_rm
21122
21123! **************************************************************************************************
21124!> \brief Finds the element-wise maximum of a vector with the result left on
21125!> all processes.
21126!> \param[in,out] msg Find maximum among these data (input) and
21127!> maximum (output)
21128!> \param comm ...
21129!> \note see mp_max_r
21130! **************************************************************************************************
21131 SUBROUTINE mp_max_root_rm(msg, root, comm)
21132 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
21133 INTEGER :: root
21134 CLASS(mp_comm_type), INTENT(IN) :: comm
21135
21136 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_rm'
21137
21138 INTEGER :: handle
21139#if defined(__parallel)
21140 INTEGER :: ierr, msglen
21141 REAL(kind=real_4) :: res(SIZE(msg, 1), SIZE(msg, 2))
21142#endif
21143
21144 CALL mp_timeset(routinen, handle)
21145
21146#if defined(__parallel)
21147 msglen = SIZE(msg)
21148 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_max, root, comm%handle, ierr)
21149 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
21150 IF (root == comm%mepos) msg = res
21151 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
21152#else
21153 mark_used(msg)
21154 mark_used(comm)
21155 mark_used(root)
21156#endif
21157 CALL mp_timestop(handle)
21158 END SUBROUTINE mp_max_root_rm
21159
21160! **************************************************************************************************
21161!> \brief Finds the minimum of a datum with the result left on all processes.
21162!> \param[in,out] msg Find minimum among these data (input) and
21163!> maximum (output)
21164!> \param[in] comm Message passing environment identifier
21165!> \par MPI mapping
21166!> mpi_allreduce
21167! **************************************************************************************************
21168 SUBROUTINE mp_min_r (msg, comm)
21169 REAL(kind=real_4), INTENT(INOUT) :: msg
21170 CLASS(mp_comm_type), INTENT(IN) :: comm
21171
21172 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_r'
21173
21174 INTEGER :: handle
21175#if defined(__parallel)
21176 INTEGER :: ierr, msglen
21177 REAL(kind=real_4) :: res
21178#endif
21179
21180 CALL mp_timeset(routinen, handle)
21181
21182#if defined(__parallel)
21183 msglen = 1
21184 IF (comm%num_pe > 1) THEN
21185 CALL mpi_allreduce(msg, res, msglen, mpi_real, mpi_min, comm%handle, ierr)
21186 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
21187 msg = res
21188 END IF
21189 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
21190#else
21191 mark_used(msg)
21192 mark_used(comm)
21193#endif
21194 CALL mp_timestop(handle)
21195 END SUBROUTINE mp_min_r
21196
21197! **************************************************************************************************
21198!> \brief Finds the element-wise minimum of vector with the result left on
21199!> all processes.
21200!> \param[in,out] msg Find minimum among these data (input) and
21201!> maximum (output)
21202!> \param comm ...
21203!> \par MPI mapping
21204!> mpi_allreduce
21205!> \note see mp_min_r
21206! **************************************************************************************************
21207 SUBROUTINE mp_min_rv(msg, comm)
21208 REAL(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
21209 CLASS(mp_comm_type), INTENT(IN) :: comm
21210
21211 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_rv'
21212
21213 INTEGER :: handle
21214#if defined(__parallel)
21215 INTEGER :: ierr, msglen
21216 REAL(kind=real_4), ALLOCATABLE :: msgbuf(:)
21217#endif
21218
21219 CALL mp_timeset(routinen, handle)
21220
21221#if defined(__parallel)
21222 msglen = SIZE(msg)
21223 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
21224 ALLOCATE (msgbuf(msglen))
21225 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_real, mpi_min, comm%handle, ierr)
21226 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
21227 msg = msgbuf
21228 END IF
21229 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
21230#else
21231 mark_used(msg)
21232 mark_used(comm)
21233#endif
21234 CALL mp_timestop(handle)
21235 END SUBROUTINE mp_min_rv
21236
21237! **************************************************************************************************
21238!> \brief Finds the element-wise minimum of a rank2-array with the result left on
21239!> all processes.
21240!> \param[in] msg Matrix - Find maximum among these data (input) and
21241!> minimum (output)
21242!> \param comm ...
21243!> \note see mp_min_r
21244! **************************************************************************************************
21245 SUBROUTINE mp_min_rm(msg, comm)
21246 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
21247 CLASS(mp_comm_type), INTENT(IN) :: comm
21248
21249 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_rm'
21250
21251 INTEGER :: handle
21252#if defined(__parallel)
21253 INTEGER, PARAMETER :: max_msg = 2**25
21254 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
21255 REAL(kind=real_4), ALLOCATABLE :: msgbuf(:)
21256#endif
21257
21258 CALL mp_timeset(routinen, handle)
21259
21260#if defined(__parallel)
21261 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
21262 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
21263 msglensum = 0
21264 DO m1 = lbound(msg, 2), ubound(msg, 2), step
21265 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
21266 msglensum = msglensum + msglen
21267 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
21268 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
21269 ALLOCATE (msgbuf(msglen))
21270 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_real, mpi_min, comm%handle, ierr)
21271 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
21272 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
21273 DEALLOCATE (msgbuf)
21274 END IF
21275 END DO
21276 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_4_size)
21277#else
21278 mark_used(msg)
21279 mark_used(comm)
21280#endif
21281 CALL mp_timestop(handle)
21282 END SUBROUTINE mp_min_rm
21283
21284! **************************************************************************************************
21285!> \brief Multiplies a set of numbers scattered across a number of processes,
21286!> then replicates the result.
21287!> \param[in,out] msg a number to multiply (input) and result (output)
21288!> \param[in] comm message passing environment identifier
21289!> \par MPI mapping
21290!> mpi_allreduce
21291! **************************************************************************************************
21292 SUBROUTINE mp_prod_r (msg, comm)
21293 REAL(kind=real_4), INTENT(INOUT) :: msg
21294 CLASS(mp_comm_type), INTENT(IN) :: comm
21295
21296 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_r'
21297
21298 INTEGER :: handle
21299#if defined(__parallel)
21300 INTEGER :: ierr, msglen
21301 REAL(kind=real_4) :: res
21302#endif
21303
21304 CALL mp_timeset(routinen, handle)
21305
21306#if defined(__parallel)
21307 msglen = 1
21308 IF (comm%num_pe > 1) THEN
21309 CALL mpi_allreduce(msg, res, msglen, mpi_real, mpi_prod, comm%handle, ierr)
21310 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
21311 msg = res
21312 END IF
21313 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
21314#else
21315 mark_used(msg)
21316 mark_used(comm)
21317#endif
21318 CALL mp_timestop(handle)
21319 END SUBROUTINE mp_prod_r
21320
21321! **************************************************************************************************
21322!> \brief Scatters data from one processes to all others
21323!> \param[in] msg_scatter Data to scatter (for root process)
21324!> \param[out] msg Received data
21325!> \param[in] root Process which scatters data
21326!> \param[in] comm Message passing environment identifier
21327!> \par MPI mapping
21328!> mpi_scatter
21329! **************************************************************************************************
21330 SUBROUTINE mp_scatter_rv(msg_scatter, msg, root, comm)
21331 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
21332 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
21333 INTEGER, INTENT(IN) :: root
21334 CLASS(mp_comm_type), INTENT(IN) :: comm
21335
21336 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_rv'
21337
21338 INTEGER :: handle
21339#if defined(__parallel)
21340 INTEGER :: ierr, msglen
21341#endif
21342
21343 CALL mp_timeset(routinen, handle)
21344
21345#if defined(__parallel)
21346 msglen = SIZE(msg)
21347 CALL mpi_scatter(msg_scatter, msglen, mpi_real, msg, &
21348 msglen, mpi_real, root, comm%handle, ierr)
21349 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
21350 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21351#else
21352 mark_used(root)
21353 mark_used(comm)
21354 msg = msg_scatter
21355#endif
21356 CALL mp_timestop(handle)
21357 END SUBROUTINE mp_scatter_rv
21358
21359! **************************************************************************************************
21360!> \brief Scatters data from one processes to all others
21361!> \param[in] msg_scatter Data to scatter (for root process)
21362!> \param[in] root Process which scatters data
21363!> \param[in] comm Message passing environment identifier
21364!> \par MPI mapping
21365!> mpi_scatter
21366! **************************************************************************************************
21367 SUBROUTINE mp_iscatter_r (msg_scatter, msg, root, comm, request)
21368 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:)
21369 REAL(kind=real_4), INTENT(INOUT) :: msg
21370 INTEGER, INTENT(IN) :: root
21371 CLASS(mp_comm_type), INTENT(IN) :: comm
21372 TYPE(mp_request_type), INTENT(OUT) :: request
21373
21374 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_r'
21375
21376 INTEGER :: handle
21377#if defined(__parallel)
21378 INTEGER :: ierr, msglen
21379#endif
21380
21381 CALL mp_timeset(routinen, handle)
21382
21383#if defined(__parallel)
21384#if !defined(__GNUC__) || __GNUC__ >= 9
21385 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
21386#endif
21387 msglen = 1
21388 CALL mpi_iscatter(msg_scatter, msglen, mpi_real, msg, &
21389 msglen, mpi_real, root, comm%handle, request%handle, ierr)
21390 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
21391 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
21392#else
21393 mark_used(root)
21394 mark_used(comm)
21395 msg = msg_scatter(1)
21396 request = mp_request_null
21397#endif
21398 CALL mp_timestop(handle)
21399 END SUBROUTINE mp_iscatter_r
21400
21401! **************************************************************************************************
21402!> \brief Scatters data from one processes to all others
21403!> \param[in] msg_scatter Data to scatter (for root process)
21404!> \param[in] root Process which scatters data
21405!> \param[in] comm Message passing environment identifier
21406!> \par MPI mapping
21407!> mpi_scatter
21408! **************************************************************************************************
21409 SUBROUTINE mp_iscatter_rv2(msg_scatter, msg, root, comm, request)
21410 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:, :)
21411 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
21412 INTEGER, INTENT(IN) :: root
21413 CLASS(mp_comm_type), INTENT(IN) :: comm
21414 TYPE(mp_request_type), INTENT(OUT) :: request
21415
21416 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_rv2'
21417
21418 INTEGER :: handle
21419#if defined(__parallel)
21420 INTEGER :: ierr, msglen
21421#endif
21422
21423 CALL mp_timeset(routinen, handle)
21424
21425#if defined(__parallel)
21426#if !defined(__GNUC__) || __GNUC__ >= 9
21427 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
21428#endif
21429 msglen = SIZE(msg)
21430 CALL mpi_iscatter(msg_scatter, msglen, mpi_real, msg, &
21431 msglen, mpi_real, root, comm%handle, request%handle, ierr)
21432 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
21433 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
21434#else
21435 mark_used(root)
21436 mark_used(comm)
21437 msg(:) = msg_scatter(:, 1)
21438 request = mp_request_null
21439#endif
21440 CALL mp_timestop(handle)
21441 END SUBROUTINE mp_iscatter_rv2
21442
21443! **************************************************************************************************
21444!> \brief Scatters data from one processes to all others
21445!> \param[in] msg_scatter Data to scatter (for root process)
21446!> \param[in] root Process which scatters data
21447!> \param[in] comm Message passing environment identifier
21448!> \par MPI mapping
21449!> mpi_scatter
21450! **************************************************************************************************
21451 SUBROUTINE mp_iscatterv_rv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
21452 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:)
21453 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
21454 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
21455 INTEGER, INTENT(IN) :: recvcount, root
21456 CLASS(mp_comm_type), INTENT(IN) :: comm
21457 TYPE(mp_request_type), INTENT(OUT) :: request
21458
21459 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_rv'
21460
21461 INTEGER :: handle
21462#if defined(__parallel)
21463 INTEGER :: ierr
21464#endif
21465
21466 CALL mp_timeset(routinen, handle)
21467
21468#if defined(__parallel)
21469#if !defined(__GNUC__) || __GNUC__ >= 9
21470 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
21471 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
21472 cpassert(is_contiguous(sendcounts) .OR. SIZE(sendcounts) == 0)
21473 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
21474#endif
21475 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_real, msg, &
21476 recvcount, mpi_real, root, comm%handle, request%handle, ierr)
21477 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
21478 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
21479#else
21480 mark_used(sendcounts)
21481 mark_used(displs)
21482 mark_used(recvcount)
21483 mark_used(root)
21484 mark_used(comm)
21485 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
21486 request = mp_request_null
21487#endif
21488 CALL mp_timestop(handle)
21489 END SUBROUTINE mp_iscatterv_rv
21490
21491! **************************************************************************************************
21492!> \brief Gathers a datum from all processes to one
21493!> \param[in] msg Datum to send to root
21494!> \param[out] msg_gather Received data (on root)
21495!> \param[in] root Process which gathers the data
21496!> \param[in] comm Message passing environment identifier
21497!> \par MPI mapping
21498!> mpi_gather
21499! **************************************************************************************************
21500 SUBROUTINE mp_gather_r (msg, msg_gather, root, comm)
21501 REAL(kind=real_4), INTENT(IN) :: msg
21502 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21503 INTEGER, INTENT(IN) :: root
21504 CLASS(mp_comm_type), INTENT(IN) :: comm
21505
21506 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_r'
21507
21508 INTEGER :: handle
21509#if defined(__parallel)
21510 INTEGER :: ierr, msglen
21511#endif
21512
21513 CALL mp_timeset(routinen, handle)
21514
21515#if defined(__parallel)
21516 msglen = 1
21517 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21518 msglen, mpi_real, root, comm%handle, ierr)
21519 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21520 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21521#else
21522 mark_used(root)
21523 mark_used(comm)
21524 msg_gather(1) = msg
21525#endif
21526 CALL mp_timestop(handle)
21527 END SUBROUTINE mp_gather_r
21528
21529! **************************************************************************************************
21530!> \brief Gathers a datum from all processes to one, uses the source process of comm
21531!> \param[in] msg Datum to send to root
21532!> \param[out] msg_gather Received data (on root)
21533!> \param[in] comm Message passing environment identifier
21534!> \par MPI mapping
21535!> mpi_gather
21536! **************************************************************************************************
21537 SUBROUTINE mp_gather_r_src(msg, msg_gather, comm)
21538 REAL(kind=real_4), INTENT(IN) :: msg
21539 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21540 CLASS(mp_comm_type), INTENT(IN) :: comm
21541
21542 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_r_src'
21543
21544 INTEGER :: handle
21545#if defined(__parallel)
21546 INTEGER :: ierr, msglen
21547#endif
21548
21549 CALL mp_timeset(routinen, handle)
21550
21551#if defined(__parallel)
21552 msglen = 1
21553 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21554 msglen, mpi_real, comm%source, comm%handle, ierr)
21555 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21556 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21557#else
21558 mark_used(comm)
21559 msg_gather(1) = msg
21560#endif
21561 CALL mp_timestop(handle)
21562 END SUBROUTINE mp_gather_r_src
21563
21564! **************************************************************************************************
21565!> \brief Gathers data from all processes to one
21566!> \param[in] msg Datum to send to root
21567!> \param msg_gather ...
21568!> \param root ...
21569!> \param comm ...
21570!> \par Data length
21571!> All data (msg) is equal-sized
21572!> \par MPI mapping
21573!> mpi_gather
21574!> \note see mp_gather_r
21575! **************************************************************************************************
21576 SUBROUTINE mp_gather_rv(msg, msg_gather, root, comm)
21577 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
21578 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21579 INTEGER, INTENT(IN) :: root
21580 CLASS(mp_comm_type), INTENT(IN) :: comm
21581
21582 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rv'
21583
21584 INTEGER :: handle
21585#if defined(__parallel)
21586 INTEGER :: ierr, msglen
21587#endif
21588
21589 CALL mp_timeset(routinen, handle)
21590
21591#if defined(__parallel)
21592 msglen = SIZE(msg)
21593 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21594 msglen, mpi_real, root, comm%handle, ierr)
21595 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21596 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21597#else
21598 mark_used(root)
21599 mark_used(comm)
21600 msg_gather = msg
21601#endif
21602 CALL mp_timestop(handle)
21603 END SUBROUTINE mp_gather_rv
21604
21605! **************************************************************************************************
21606!> \brief Gathers data from all processes to one. Gathers from comm%source
21607!> \param[in] msg Datum to send to root
21608!> \param msg_gather ...
21609!> \param comm ...
21610!> \par Data length
21611!> All data (msg) is equal-sized
21612!> \par MPI mapping
21613!> mpi_gather
21614!> \note see mp_gather_r
21615! **************************************************************************************************
21616 SUBROUTINE mp_gather_rv_src(msg, msg_gather, comm)
21617 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
21618 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21619 CLASS(mp_comm_type), INTENT(IN) :: comm
21620
21621 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rv_src'
21622
21623 INTEGER :: handle
21624#if defined(__parallel)
21625 INTEGER :: ierr, msglen
21626#endif
21627
21628 CALL mp_timeset(routinen, handle)
21629
21630#if defined(__parallel)
21631 msglen = SIZE(msg)
21632 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21633 msglen, mpi_real, comm%source, comm%handle, ierr)
21634 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21635 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21636#else
21637 mark_used(comm)
21638 msg_gather = msg
21639#endif
21640 CALL mp_timestop(handle)
21641 END SUBROUTINE mp_gather_rv_src
21642
21643! **************************************************************************************************
21644!> \brief Gathers data from all processes to one
21645!> \param[in] msg Datum to send to root
21646!> \param msg_gather ...
21647!> \param root ...
21648!> \param comm ...
21649!> \par Data length
21650!> All data (msg) is equal-sized
21651!> \par MPI mapping
21652!> mpi_gather
21653!> \note see mp_gather_r
21654! **************************************************************************************************
21655 SUBROUTINE mp_gather_rm(msg, msg_gather, root, comm)
21656 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
21657 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
21658 INTEGER, INTENT(IN) :: root
21659 CLASS(mp_comm_type), INTENT(IN) :: comm
21660
21661 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rm'
21662
21663 INTEGER :: handle
21664#if defined(__parallel)
21665 INTEGER :: ierr, msglen
21666#endif
21667
21668 CALL mp_timeset(routinen, handle)
21669
21670#if defined(__parallel)
21671 msglen = SIZE(msg)
21672 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21673 msglen, mpi_real, root, comm%handle, ierr)
21674 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21675 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21676#else
21677 mark_used(root)
21678 mark_used(comm)
21679 msg_gather = msg
21680#endif
21681 CALL mp_timestop(handle)
21682 END SUBROUTINE mp_gather_rm
21683
21684! **************************************************************************************************
21685!> \brief Gathers data from all processes to one. Gathers from comm%source
21686!> \param[in] msg Datum to send to root
21687!> \param msg_gather ...
21688!> \param comm ...
21689!> \par Data length
21690!> All data (msg) is equal-sized
21691!> \par MPI mapping
21692!> mpi_gather
21693!> \note see mp_gather_r
21694! **************************************************************************************************
21695 SUBROUTINE mp_gather_rm_src(msg, msg_gather, comm)
21696 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
21697 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
21698 CLASS(mp_comm_type), INTENT(IN) :: comm
21699
21700 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rm_src'
21701
21702 INTEGER :: handle
21703#if defined(__parallel)
21704 INTEGER :: ierr, msglen
21705#endif
21706
21707 CALL mp_timeset(routinen, handle)
21708
21709#if defined(__parallel)
21710 msglen = SIZE(msg)
21711 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21712 msglen, mpi_real, comm%source, comm%handle, ierr)
21713 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21714 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21715#else
21716 mark_used(comm)
21717 msg_gather = msg
21718#endif
21719 CALL mp_timestop(handle)
21720 END SUBROUTINE mp_gather_rm_src
21721
21722! **************************************************************************************************
21723!> \brief Gathers data from all processes to one.
21724!> \param[in] sendbuf Data to send to root
21725!> \param[out] recvbuf Received data (on root)
21726!> \param[in] recvcounts Sizes of data received from processes
21727!> \param[in] displs Offsets of data received from processes
21728!> \param[in] root Process which gathers the data
21729!> \param[in] comm Message passing environment identifier
21730!> \par Data length
21731!> Data can have different lengths
21732!> \par Offsets
21733!> Offsets start at 0
21734!> \par MPI mapping
21735!> mpi_gather
21736! **************************************************************************************************
21737 SUBROUTINE mp_gatherv_rv(sendbuf, recvbuf, recvcounts, displs, root, comm)
21738
21739 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
21740 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
21741 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21742 INTEGER, INTENT(IN) :: root
21743 CLASS(mp_comm_type), INTENT(IN) :: comm
21744
21745 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rv'
21746
21747 INTEGER :: handle
21748#if defined(__parallel)
21749 INTEGER :: ierr, sendcount
21750#endif
21751
21752 CALL mp_timeset(routinen, handle)
21753
21754#if defined(__parallel)
21755 sendcount = SIZE(sendbuf)
21756 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21757 recvbuf, recvcounts, displs, mpi_real, &
21758 root, comm%handle, ierr)
21759 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21760 CALL add_perf(perf_id=4, &
21761 count=1, &
21762 msg_size=sendcount*real_4_size)
21763#else
21764 mark_used(recvcounts)
21765 mark_used(root)
21766 mark_used(comm)
21767 recvbuf(1 + displs(1):) = sendbuf
21768#endif
21769 CALL mp_timestop(handle)
21770 END SUBROUTINE mp_gatherv_rv
21771
21772! **************************************************************************************************
21773!> \brief Gathers data from all processes to one. Gathers from comm%source
21774!> \param[in] sendbuf Data to send to root
21775!> \param[out] recvbuf Received data (on root)
21776!> \param[in] recvcounts Sizes of data received from processes
21777!> \param[in] displs Offsets of data received from processes
21778!> \param[in] comm Message passing environment identifier
21779!> \par Data length
21780!> Data can have different lengths
21781!> \par Offsets
21782!> Offsets start at 0
21783!> \par MPI mapping
21784!> mpi_gather
21785! **************************************************************************************************
21786 SUBROUTINE mp_gatherv_rv_src(sendbuf, recvbuf, recvcounts, displs, comm)
21787
21788 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
21789 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
21790 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21791 CLASS(mp_comm_type), INTENT(IN) :: comm
21792
21793 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rv_src'
21794
21795 INTEGER :: handle
21796#if defined(__parallel)
21797 INTEGER :: ierr, sendcount
21798#endif
21799
21800 CALL mp_timeset(routinen, handle)
21801
21802#if defined(__parallel)
21803 sendcount = SIZE(sendbuf)
21804 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21805 recvbuf, recvcounts, displs, mpi_real, &
21806 comm%source, comm%handle, ierr)
21807 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21808 CALL add_perf(perf_id=4, &
21809 count=1, &
21810 msg_size=sendcount*real_4_size)
21811#else
21812 mark_used(recvcounts)
21813 mark_used(comm)
21814 recvbuf(1 + displs(1):) = sendbuf
21815#endif
21816 CALL mp_timestop(handle)
21817 END SUBROUTINE mp_gatherv_rv_src
21818
21819! **************************************************************************************************
21820!> \brief Gathers data from all processes to one.
21821!> \param[in] sendbuf Data to send to root
21822!> \param[out] recvbuf Received data (on root)
21823!> \param[in] recvcounts Sizes of data received from processes
21824!> \param[in] displs Offsets of data received from processes
21825!> \param[in] root Process which gathers the data
21826!> \param[in] comm Message passing environment identifier
21827!> \par Data length
21828!> Data can have different lengths
21829!> \par Offsets
21830!> Offsets start at 0
21831!> \par MPI mapping
21832!> mpi_gather
21833! **************************************************************************************************
21834 SUBROUTINE mp_gatherv_rm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
21835
21836 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
21837 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
21838 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21839 INTEGER, INTENT(IN) :: root
21840 CLASS(mp_comm_type), INTENT(IN) :: comm
21841
21842 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rm2'
21843
21844 INTEGER :: handle
21845#if defined(__parallel)
21846 INTEGER :: ierr, sendcount
21847#endif
21848
21849 CALL mp_timeset(routinen, handle)
21850
21851#if defined(__parallel)
21852 sendcount = SIZE(sendbuf)
21853 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21854 recvbuf, recvcounts, displs, mpi_real, &
21855 root, comm%handle, ierr)
21856 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21857 CALL add_perf(perf_id=4, &
21858 count=1, &
21859 msg_size=sendcount*real_4_size)
21860#else
21861 mark_used(recvcounts)
21862 mark_used(root)
21863 mark_used(comm)
21864 recvbuf(:, 1 + displs(1):) = sendbuf
21865#endif
21866 CALL mp_timestop(handle)
21867 END SUBROUTINE mp_gatherv_rm2
21868
21869! **************************************************************************************************
21870!> \brief Gathers data from all processes to one.
21871!> \param[in] sendbuf Data to send to root
21872!> \param[out] recvbuf Received data (on root)
21873!> \param[in] recvcounts Sizes of data received from processes
21874!> \param[in] displs Offsets of data received from processes
21875!> \param[in] comm Message passing environment identifier
21876!> \par Data length
21877!> Data can have different lengths
21878!> \par Offsets
21879!> Offsets start at 0
21880!> \par MPI mapping
21881!> mpi_gather
21882! **************************************************************************************************
21883 SUBROUTINE mp_gatherv_rm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
21884
21885 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
21886 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
21887 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21888 CLASS(mp_comm_type), INTENT(IN) :: comm
21889
21890 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rm2_src'
21891
21892 INTEGER :: handle
21893#if defined(__parallel)
21894 INTEGER :: ierr, sendcount
21895#endif
21896
21897 CALL mp_timeset(routinen, handle)
21898
21899#if defined(__parallel)
21900 sendcount = SIZE(sendbuf)
21901 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21902 recvbuf, recvcounts, displs, mpi_real, &
21903 comm%source, comm%handle, ierr)
21904 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21905 CALL add_perf(perf_id=4, &
21906 count=1, &
21907 msg_size=sendcount*real_4_size)
21908#else
21909 mark_used(recvcounts)
21910 mark_used(comm)
21911 recvbuf(:, 1 + displs(1):) = sendbuf
21912#endif
21913 CALL mp_timestop(handle)
21914 END SUBROUTINE mp_gatherv_rm2_src
21915
21916! **************************************************************************************************
21917!> \brief Gathers data from all processes to one.
21918!> \param[in] sendbuf Data to send to root
21919!> \param[out] recvbuf Received data (on root)
21920!> \param[in] recvcounts Sizes of data received from processes
21921!> \param[in] displs Offsets of data received from processes
21922!> \param[in] root Process which gathers the data
21923!> \param[in] comm Message passing environment identifier
21924!> \par Data length
21925!> Data can have different lengths
21926!> \par Offsets
21927!> Offsets start at 0
21928!> \par MPI mapping
21929!> mpi_gather
21930! **************************************************************************************************
21931 SUBROUTINE mp_igatherv_rv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
21932 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: sendbuf
21933 REAL(kind=real_4), DIMENSION(:), INTENT(OUT) :: recvbuf
21934 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21935 INTEGER, INTENT(IN) :: sendcount, root
21936 CLASS(mp_comm_type), INTENT(IN) :: comm
21937 TYPE(mp_request_type), INTENT(OUT) :: request
21938
21939 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_rv'
21940
21941 INTEGER :: handle
21942#if defined(__parallel)
21943 INTEGER :: ierr
21944#endif
21945
21946 CALL mp_timeset(routinen, handle)
21947
21948#if defined(__parallel)
21949#if !defined(__GNUC__) || __GNUC__ >= 9
21950 cpassert(is_contiguous(sendbuf) .OR. SIZE(sendbuf) == 0)
21951 cpassert(is_contiguous(recvbuf) .OR. SIZE(recvbuf) == 0)
21952 cpassert(is_contiguous(recvcounts) .OR. SIZE(recvcounts) == 0)
21953 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
21954#endif
21955 CALL mpi_igatherv(sendbuf, sendcount, mpi_real, &
21956 recvbuf, recvcounts, displs, mpi_real, &
21957 root, comm%handle, request%handle, ierr)
21958 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21959 CALL add_perf(perf_id=24, &
21960 count=1, &
21961 msg_size=sendcount*real_4_size)
21962#else
21963 mark_used(sendcount)
21964 mark_used(recvcounts)
21965 mark_used(root)
21966 mark_used(comm)
21967 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
21968 request = mp_request_null
21969#endif
21970 CALL mp_timestop(handle)
21971 END SUBROUTINE mp_igatherv_rv
21972
21973! **************************************************************************************************
21974!> \brief Gathers a datum from all processes and all processes receive the
21975!> same data
21976!> \param[in] msgout Datum to send
21977!> \param[out] msgin Received data
21978!> \param[in] comm Message passing environment identifier
21979!> \par Data size
21980!> All processes send equal-sized data
21981!> \par MPI mapping
21982!> mpi_allgather
21983! **************************************************************************************************
21984 SUBROUTINE mp_allgather_r (msgout, msgin, comm)
21985 REAL(kind=real_4), INTENT(IN) :: msgout
21986 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
21987 CLASS(mp_comm_type), INTENT(IN) :: comm
21988
21989 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r'
21990
21991 INTEGER :: handle
21992#if defined(__parallel)
21993 INTEGER :: ierr, rcount, scount
21994#endif
21995
21996 CALL mp_timeset(routinen, handle)
21997
21998#if defined(__parallel)
21999 scount = 1
22000 rcount = 1
22001 CALL mpi_allgather(msgout, scount, mpi_real, &
22002 msgin, rcount, mpi_real, &
22003 comm%handle, ierr)
22004 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
22005#else
22006 mark_used(comm)
22007 msgin = msgout
22008#endif
22009 CALL mp_timestop(handle)
22010 END SUBROUTINE mp_allgather_r
22011
22012! **************************************************************************************************
22013!> \brief Gathers a datum from all processes and all processes receive the
22014!> same data
22015!> \param[in] msgout Datum to send
22016!> \param[out] msgin Received data
22017!> \param[in] comm Message passing environment identifier
22018!> \par Data size
22019!> All processes send equal-sized data
22020!> \par MPI mapping
22021!> mpi_allgather
22022! **************************************************************************************************
22023 SUBROUTINE mp_allgather_r2(msgout, msgin, comm)
22024 REAL(kind=real_4), INTENT(IN) :: msgout
22025 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
22026 CLASS(mp_comm_type), INTENT(IN) :: comm
22027
22028 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r2'
22029
22030 INTEGER :: handle
22031#if defined(__parallel)
22032 INTEGER :: ierr, rcount, scount
22033#endif
22034
22035 CALL mp_timeset(routinen, handle)
22036
22037#if defined(__parallel)
22038 scount = 1
22039 rcount = 1
22040 CALL mpi_allgather(msgout, scount, mpi_real, &
22041 msgin, rcount, mpi_real, &
22042 comm%handle, ierr)
22043 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
22044#else
22045 mark_used(comm)
22046 msgin = msgout
22047#endif
22048 CALL mp_timestop(handle)
22049 END SUBROUTINE mp_allgather_r2
22050
22051! **************************************************************************************************
22052!> \brief Gathers a datum from all processes and all processes receive the
22053!> same data
22054!> \param[in] msgout Datum to send
22055!> \param[out] msgin Received data
22056!> \param[in] comm Message passing environment identifier
22057!> \par Data size
22058!> All processes send equal-sized data
22059!> \par MPI mapping
22060!> mpi_allgather
22061! **************************************************************************************************
22062 SUBROUTINE mp_iallgather_r (msgout, msgin, comm, request)
22063 REAL(kind=real_4), INTENT(IN) :: msgout
22064 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22065 CLASS(mp_comm_type), INTENT(IN) :: comm
22066 TYPE(mp_request_type), INTENT(OUT) :: request
22067
22068 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r'
22069
22070 INTEGER :: handle
22071#if defined(__parallel)
22072 INTEGER :: ierr, rcount, scount
22073#endif
22074
22075 CALL mp_timeset(routinen, handle)
22076
22077#if defined(__parallel)
22078#if !defined(__GNUC__) || __GNUC__ >= 9
22079 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
22080#endif
22081 scount = 1
22082 rcount = 1
22083 CALL mpi_iallgather(msgout, scount, mpi_real, &
22084 msgin, rcount, mpi_real, &
22085 comm%handle, request%handle, ierr)
22086 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
22087#else
22088 mark_used(comm)
22089 msgin = msgout
22090 request = mp_request_null
22091#endif
22092 CALL mp_timestop(handle)
22093 END SUBROUTINE mp_iallgather_r
22094
22095! **************************************************************************************************
22096!> \brief Gathers vector data from all processes and all processes receive the
22097!> same data
22098!> \param[in] msgout Rank-1 data to send
22099!> \param[out] msgin Received data
22100!> \param[in] comm Message passing environment identifier
22101!> \par Data size
22102!> All processes send equal-sized data
22103!> \par Ranks
22104!> The last rank counts the processes
22105!> \par MPI mapping
22106!> mpi_allgather
22107! **************************************************************************************************
22108 SUBROUTINE mp_allgather_r12(msgout, msgin, comm)
22109 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:)
22110 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
22111 CLASS(mp_comm_type), INTENT(IN) :: comm
22112
22113 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r12'
22114
22115 INTEGER :: handle
22116#if defined(__parallel)
22117 INTEGER :: ierr, rcount, scount
22118#endif
22119
22120 CALL mp_timeset(routinen, handle)
22121
22122#if defined(__parallel)
22123 scount = SIZE(msgout(:))
22124 rcount = scount
22125 CALL mpi_allgather(msgout, scount, mpi_real, &
22126 msgin, rcount, mpi_real, &
22127 comm%handle, ierr)
22128 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
22129#else
22130 mark_used(comm)
22131 msgin(:, 1) = msgout(:)
22132#endif
22133 CALL mp_timestop(handle)
22134 END SUBROUTINE mp_allgather_r12
22135
22136! **************************************************************************************************
22137!> \brief Gathers matrix data from all processes and all processes receive the
22138!> same data
22139!> \param[in] msgout Rank-2 data to send
22140!> \param msgin ...
22141!> \param comm ...
22142!> \note see mp_allgather_r12
22143! **************************************************************************************************
22144 SUBROUTINE mp_allgather_r23(msgout, msgin, comm)
22145 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
22146 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
22147 CLASS(mp_comm_type), INTENT(IN) :: comm
22148
22149 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r23'
22150
22151 INTEGER :: handle
22152#if defined(__parallel)
22153 INTEGER :: ierr, rcount, scount
22154#endif
22155
22156 CALL mp_timeset(routinen, handle)
22157
22158#if defined(__parallel)
22159 scount = SIZE(msgout(:, :))
22160 rcount = scount
22161 CALL mpi_allgather(msgout, scount, mpi_real, &
22162 msgin, rcount, mpi_real, &
22163 comm%handle, ierr)
22164 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
22165#else
22166 mark_used(comm)
22167 msgin(:, :, 1) = msgout(:, :)
22168#endif
22169 CALL mp_timestop(handle)
22170 END SUBROUTINE mp_allgather_r23
22171
22172! **************************************************************************************************
22173!> \brief Gathers rank-3 data from all processes and all processes receive the
22174!> same data
22175!> \param[in] msgout Rank-3 data to send
22176!> \param msgin ...
22177!> \param comm ...
22178!> \note see mp_allgather_r12
22179! **************************************************************************************************
22180 SUBROUTINE mp_allgather_r34(msgout, msgin, comm)
22181 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
22182 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
22183 CLASS(mp_comm_type), INTENT(IN) :: comm
22184
22185 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r34'
22186
22187 INTEGER :: handle
22188#if defined(__parallel)
22189 INTEGER :: ierr, rcount, scount
22190#endif
22191
22192 CALL mp_timeset(routinen, handle)
22193
22194#if defined(__parallel)
22195 scount = SIZE(msgout(:, :, :))
22196 rcount = scount
22197 CALL mpi_allgather(msgout, scount, mpi_real, &
22198 msgin, rcount, mpi_real, &
22199 comm%handle, ierr)
22200 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
22201#else
22202 mark_used(comm)
22203 msgin(:, :, :, 1) = msgout(:, :, :)
22204#endif
22205 CALL mp_timestop(handle)
22206 END SUBROUTINE mp_allgather_r34
22207
22208! **************************************************************************************************
22209!> \brief Gathers rank-2 data from all processes and all processes receive the
22210!> same data
22211!> \param[in] msgout Rank-2 data to send
22212!> \param msgin ...
22213!> \param comm ...
22214!> \note see mp_allgather_r12
22215! **************************************************************************************************
22216 SUBROUTINE mp_allgather_r22(msgout, msgin, comm)
22217 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
22218 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
22219 CLASS(mp_comm_type), INTENT(IN) :: comm
22220
22221 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r22'
22222
22223 INTEGER :: handle
22224#if defined(__parallel)
22225 INTEGER :: ierr, rcount, scount
22226#endif
22227
22228 CALL mp_timeset(routinen, handle)
22229
22230#if defined(__parallel)
22231 scount = SIZE(msgout(:, :))
22232 rcount = scount
22233 CALL mpi_allgather(msgout, scount, mpi_real, &
22234 msgin, rcount, mpi_real, &
22235 comm%handle, ierr)
22236 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
22237#else
22238 mark_used(comm)
22239 msgin(:, :) = msgout(:, :)
22240#endif
22241 CALL mp_timestop(handle)
22242 END SUBROUTINE mp_allgather_r22
22243
22244! **************************************************************************************************
22245!> \brief Gathers rank-1 data from all processes and all processes receive the
22246!> same data
22247!> \param[in] msgout Rank-1 data to send
22248!> \param msgin ...
22249!> \param comm ...
22250!> \param request ...
22251!> \note see mp_allgather_r11
22252! **************************************************************************************************
22253 SUBROUTINE mp_iallgather_r11(msgout, msgin, comm, request)
22254 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22255 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22256 CLASS(mp_comm_type), INTENT(IN) :: comm
22257 TYPE(mp_request_type), INTENT(OUT) :: request
22258
22259 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r11'
22260
22261 INTEGER :: handle
22262#if defined(__parallel)
22263 INTEGER :: ierr, rcount, scount
22264#endif
22265
22266 CALL mp_timeset(routinen, handle)
22267
22268#if defined(__parallel)
22269#if !defined(__GNUC__) || __GNUC__ >= 9
22270 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
22271 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
22272#endif
22273 scount = SIZE(msgout(:))
22274 rcount = scount
22275 CALL mpi_iallgather(msgout, scount, mpi_real, &
22276 msgin, rcount, mpi_real, &
22277 comm%handle, request%handle, ierr)
22278 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22279#else
22280 mark_used(comm)
22281 msgin = msgout
22282 request = mp_request_null
22283#endif
22284 CALL mp_timestop(handle)
22285 END SUBROUTINE mp_iallgather_r11
22286
22287! **************************************************************************************************
22288!> \brief Gathers rank-2 data from all processes and all processes receive the
22289!> same data
22290!> \param[in] msgout Rank-2 data to send
22291!> \param msgin ...
22292!> \param comm ...
22293!> \param request ...
22294!> \note see mp_allgather_r12
22295! **************************************************************************************************
22296 SUBROUTINE mp_iallgather_r13(msgout, msgin, comm, request)
22297 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22298 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
22299 CLASS(mp_comm_type), INTENT(IN) :: comm
22300 TYPE(mp_request_type), INTENT(OUT) :: request
22301
22302 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r13'
22303
22304 INTEGER :: handle
22305#if defined(__parallel)
22306 INTEGER :: ierr, rcount, scount
22307#endif
22308
22309 CALL mp_timeset(routinen, handle)
22310
22311#if defined(__parallel)
22312#if !defined(__GNUC__) || __GNUC__ >= 9
22313 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
22314 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
22315#endif
22316
22317 scount = SIZE(msgout(:))
22318 rcount = scount
22319 CALL mpi_iallgather(msgout, scount, mpi_real, &
22320 msgin, rcount, mpi_real, &
22321 comm%handle, request%handle, ierr)
22322 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22323#else
22324 mark_used(comm)
22325 msgin(:, 1, 1) = msgout(:)
22326 request = mp_request_null
22327#endif
22328 CALL mp_timestop(handle)
22329 END SUBROUTINE mp_iallgather_r13
22330
22331! **************************************************************************************************
22332!> \brief Gathers rank-2 data from all processes and all processes receive the
22333!> same data
22334!> \param[in] msgout Rank-2 data to send
22335!> \param msgin ...
22336!> \param comm ...
22337!> \param request ...
22338!> \note see mp_allgather_r12
22339! **************************************************************************************************
22340 SUBROUTINE mp_iallgather_r22(msgout, msgin, comm, request)
22341 REAL(kind=real_4), INTENT(IN) :: msgout(:, :)
22342 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :)
22343 CLASS(mp_comm_type), INTENT(IN) :: comm
22344 TYPE(mp_request_type), INTENT(OUT) :: request
22345
22346 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r22'
22347
22348 INTEGER :: handle
22349#if defined(__parallel)
22350 INTEGER :: ierr, rcount, scount
22351#endif
22352
22353 CALL mp_timeset(routinen, handle)
22354
22355#if defined(__parallel)
22356#if !defined(__GNUC__) || __GNUC__ >= 9
22357 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
22358 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
22359#endif
22360
22361 scount = SIZE(msgout(:, :))
22362 rcount = scount
22363 CALL mpi_iallgather(msgout, scount, mpi_real, &
22364 msgin, rcount, mpi_real, &
22365 comm%handle, request%handle, ierr)
22366 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22367#else
22368 mark_used(comm)
22369 msgin(:, :) = msgout(:, :)
22370 request = mp_request_null
22371#endif
22372 CALL mp_timestop(handle)
22373 END SUBROUTINE mp_iallgather_r22
22374
22375! **************************************************************************************************
22376!> \brief Gathers rank-2 data from all processes and all processes receive the
22377!> same data
22378!> \param[in] msgout Rank-2 data to send
22379!> \param msgin ...
22380!> \param comm ...
22381!> \param request ...
22382!> \note see mp_allgather_r12
22383! **************************************************************************************************
22384 SUBROUTINE mp_iallgather_r24(msgout, msgin, comm, request)
22385 REAL(kind=real_4), INTENT(IN) :: msgout(:, :)
22386 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :, :)
22387 CLASS(mp_comm_type), INTENT(IN) :: comm
22388 TYPE(mp_request_type), INTENT(OUT) :: request
22389
22390 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r24'
22391
22392 INTEGER :: handle
22393#if defined(__parallel)
22394 INTEGER :: ierr, rcount, scount
22395#endif
22396
22397 CALL mp_timeset(routinen, handle)
22398
22399#if defined(__parallel)
22400#if !defined(__GNUC__) || __GNUC__ >= 9
22401 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
22402 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
22403#endif
22404
22405 scount = SIZE(msgout(:, :))
22406 rcount = scount
22407 CALL mpi_iallgather(msgout, scount, mpi_real, &
22408 msgin, rcount, mpi_real, &
22409 comm%handle, request%handle, ierr)
22410 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22411#else
22412 mark_used(comm)
22413 msgin(:, :, 1, 1) = msgout(:, :)
22414 request = mp_request_null
22415#endif
22416 CALL mp_timestop(handle)
22417 END SUBROUTINE mp_iallgather_r24
22418
22419! **************************************************************************************************
22420!> \brief Gathers rank-3 data from all processes and all processes receive the
22421!> same data
22422!> \param[in] msgout Rank-3 data to send
22423!> \param msgin ...
22424!> \param comm ...
22425!> \param request ...
22426!> \note see mp_allgather_r12
22427! **************************************************************************************************
22428 SUBROUTINE mp_iallgather_r33(msgout, msgin, comm, request)
22429 REAL(kind=real_4), INTENT(IN) :: msgout(:, :, :)
22430 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
22431 CLASS(mp_comm_type), INTENT(IN) :: comm
22432 TYPE(mp_request_type), INTENT(OUT) :: request
22433
22434 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r33'
22435
22436 INTEGER :: handle
22437#if defined(__parallel)
22438 INTEGER :: ierr, rcount, scount
22439#endif
22440
22441 CALL mp_timeset(routinen, handle)
22442
22443#if defined(__parallel)
22444#if !defined(__GNUC__) || __GNUC__ >= 9
22445 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
22446 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
22447#endif
22448
22449 scount = SIZE(msgout(:, :, :))
22450 rcount = scount
22451 CALL mpi_iallgather(msgout, scount, mpi_real, &
22452 msgin, rcount, mpi_real, &
22453 comm%handle, request%handle, ierr)
22454 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22455#else
22456 mark_used(comm)
22457 msgin(:, :, :) = msgout(:, :, :)
22458 request = mp_request_null
22459#endif
22460 CALL mp_timestop(handle)
22461 END SUBROUTINE mp_iallgather_r33
22462
22463! **************************************************************************************************
22464!> \brief Gathers vector data from all processes and all processes receive the
22465!> same data
22466!> \param[in] msgout Rank-1 data to send
22467!> \param[out] msgin Received data
22468!> \param[in] rcount Size of sent data for every process
22469!> \param[in] rdispl Offset of sent data for every process
22470!> \param[in] comm Message passing environment identifier
22471!> \par Data size
22472!> Processes can send different-sized data
22473!> \par Ranks
22474!> The last rank counts the processes
22475!> \par Offsets
22476!> Offsets are from 0
22477!> \par MPI mapping
22478!> mpi_allgather
22479! **************************************************************************************************
22480 SUBROUTINE mp_allgatherv_rv(msgout, msgin, rcount, rdispl, comm)
22481 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
22482 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22483 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22484 CLASS(mp_comm_type), INTENT(IN) :: comm
22485
22486 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_rv'
22487
22488 INTEGER :: handle
22489#if defined(__parallel)
22490 INTEGER :: ierr, scount
22491#endif
22492
22493 CALL mp_timeset(routinen, handle)
22494
22495#if defined(__parallel)
22496 scount = SIZE(msgout)
22497 CALL mpi_allgatherv(msgout, scount, mpi_real, msgin, rcount, &
22498 rdispl, mpi_real, comm%handle, ierr)
22499 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
22500#else
22501 mark_used(rcount)
22502 mark_used(rdispl)
22503 mark_used(comm)
22504 msgin = msgout
22505#endif
22506 CALL mp_timestop(handle)
22507 END SUBROUTINE mp_allgatherv_rv
22508
22509! **************************************************************************************************
22510!> \brief Gathers vector data from all processes and all processes receive the
22511!> same data
22512!> \param[in] msgout Rank-1 data to send
22513!> \param[out] msgin Received data
22514!> \param[in] rcount Size of sent data for every process
22515!> \param[in] rdispl Offset of sent data for every process
22516!> \param[in] comm Message passing environment identifier
22517!> \par Data size
22518!> Processes can send different-sized data
22519!> \par Ranks
22520!> The last rank counts the processes
22521!> \par Offsets
22522!> Offsets are from 0
22523!> \par MPI mapping
22524!> mpi_allgather
22525! **************************************************************************************************
22526 SUBROUTINE mp_allgatherv_rm2(msgout, msgin, rcount, rdispl, comm)
22527 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
22528 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
22529 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22530 CLASS(mp_comm_type), INTENT(IN) :: comm
22531
22532 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_rv'
22533
22534 INTEGER :: handle
22535#if defined(__parallel)
22536 INTEGER :: ierr, scount
22537#endif
22538
22539 CALL mp_timeset(routinen, handle)
22540
22541#if defined(__parallel)
22542 scount = SIZE(msgout)
22543 CALL mpi_allgatherv(msgout, scount, mpi_real, msgin, rcount, &
22544 rdispl, mpi_real, comm%handle, ierr)
22545 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
22546#else
22547 mark_used(rcount)
22548 mark_used(rdispl)
22549 mark_used(comm)
22550 msgin = msgout
22551#endif
22552 CALL mp_timestop(handle)
22553 END SUBROUTINE mp_allgatherv_rm2
22554
22555! **************************************************************************************************
22556!> \brief Gathers vector data from all processes and all processes receive the
22557!> same data
22558!> \param[in] msgout Rank-1 data to send
22559!> \param[out] msgin Received data
22560!> \param[in] rcount Size of sent data for every process
22561!> \param[in] rdispl Offset of sent data for every process
22562!> \param[in] comm Message passing environment identifier
22563!> \par Data size
22564!> Processes can send different-sized data
22565!> \par Ranks
22566!> The last rank counts the processes
22567!> \par Offsets
22568!> Offsets are from 0
22569!> \par MPI mapping
22570!> mpi_allgather
22571! **************************************************************************************************
22572 SUBROUTINE mp_iallgatherv_rv(msgout, msgin, rcount, rdispl, comm, request)
22573 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22574 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22575 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22576 CLASS(mp_comm_type), INTENT(IN) :: comm
22577 TYPE(mp_request_type), INTENT(OUT) :: request
22578
22579 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_rv'
22580
22581 INTEGER :: handle
22582#if defined(__parallel)
22583 INTEGER :: ierr, scount, rsize
22584#endif
22585
22586 CALL mp_timeset(routinen, handle)
22587
22588#if defined(__parallel)
22589#if !defined(__GNUC__) || __GNUC__ >= 9
22590 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
22591 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
22592 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
22593 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
22594#endif
22595
22596 scount = SIZE(msgout)
22597 rsize = SIZE(rcount)
22598 CALL mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, &
22599 rdispl, comm, request, ierr)
22600 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
22601#else
22602 mark_used(rcount)
22603 mark_used(rdispl)
22604 mark_used(comm)
22605 msgin = msgout
22606 request = mp_request_null
22607#endif
22608 CALL mp_timestop(handle)
22609 END SUBROUTINE mp_iallgatherv_rv
22610
22611! **************************************************************************************************
22612!> \brief Gathers vector data from all processes and all processes receive the
22613!> same data
22614!> \param[in] msgout Rank-1 data to send
22615!> \param[out] msgin Received data
22616!> \param[in] rcount Size of sent data for every process
22617!> \param[in] rdispl Offset of sent data for every process
22618!> \param[in] comm Message passing environment identifier
22619!> \par Data size
22620!> Processes can send different-sized data
22621!> \par Ranks
22622!> The last rank counts the processes
22623!> \par Offsets
22624!> Offsets are from 0
22625!> \par MPI mapping
22626!> mpi_allgather
22627! **************************************************************************************************
22628 SUBROUTINE mp_iallgatherv_rv2(msgout, msgin, rcount, rdispl, comm, request)
22629 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22630 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22631 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
22632 CLASS(mp_comm_type), INTENT(IN) :: comm
22633 TYPE(mp_request_type), INTENT(OUT) :: request
22634
22635 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_rv2'
22636
22637 INTEGER :: handle
22638#if defined(__parallel)
22639 INTEGER :: ierr, scount, rsize
22640#endif
22641
22642 CALL mp_timeset(routinen, handle)
22643
22644#if defined(__parallel)
22645#if !defined(__GNUC__) || __GNUC__ >= 9
22646 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
22647 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
22648 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
22649 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
22650#endif
22651
22652 scount = SIZE(msgout)
22653 rsize = SIZE(rcount)
22654 CALL mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, &
22655 rdispl, comm, request, ierr)
22656 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
22657#else
22658 mark_used(rcount)
22659 mark_used(rdispl)
22660 mark_used(comm)
22661 msgin = msgout
22662 request = mp_request_null
22663#endif
22664 CALL mp_timestop(handle)
22665 END SUBROUTINE mp_iallgatherv_rv2
22666
22667! **************************************************************************************************
22668!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
22669!> the issue is with the rank of rcount and rdispl
22670!> \param count ...
22671!> \param array_of_requests ...
22672!> \param array_of_statuses ...
22673!> \param ierr ...
22674!> \author Alfio Lazzaro
22675! **************************************************************************************************
22676#if defined(__parallel)
22677 SUBROUTINE mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
22678 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
22679 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22680 INTEGER, INTENT(IN) :: rsize
22681 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
22682 CLASS(mp_comm_type), INTENT(IN) :: comm
22683 TYPE(mp_request_type), INTENT(OUT) :: request
22684 INTEGER, INTENT(INOUT) :: ierr
22685
22686 CALL mpi_iallgatherv(msgout, scount, mpi_real, msgin, rcount, &
22687 rdispl, mpi_real, comm%handle, request%handle, ierr)
22688
22689 END SUBROUTINE mp_iallgatherv_rv_internal
22690#endif
22691
22692! **************************************************************************************************
22693!> \brief Sums a vector and partitions the result among processes
22694!> \param[in] msgout Data to sum
22695!> \param[out] msgin Received portion of summed data
22696!> \param[in] rcount Partition sizes of the summed data for
22697!> every process
22698!> \param[in] comm Message passing environment identifier
22699! **************************************************************************************************
22700 SUBROUTINE mp_sum_scatter_rv(msgout, msgin, rcount, comm)
22701 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
22702 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22703 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
22704 CLASS(mp_comm_type), INTENT(IN) :: comm
22705
22706 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_rv'
22707
22708 INTEGER :: handle
22709#if defined(__parallel)
22710 INTEGER :: ierr
22711#endif
22712
22713 CALL mp_timeset(routinen, handle)
22714
22715#if defined(__parallel)
22716 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_real, mpi_sum, &
22717 comm%handle, ierr)
22718 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
22719
22720 CALL add_perf(perf_id=3, count=1, &
22721 msg_size=rcount(1)*2*real_4_size)
22722#else
22723 mark_used(rcount)
22724 mark_used(comm)
22725 msgin = msgout(:, 1)
22726#endif
22727 CALL mp_timestop(handle)
22728 END SUBROUTINE mp_sum_scatter_rv
22729
22730! **************************************************************************************************
22731!> \brief Sends and receives vector data
22732!> \param[in] msgin Data to send
22733!> \param[in] dest Process to send data to
22734!> \param[out] msgout Received data
22735!> \param[in] source Process from which to receive
22736!> \param[in] comm Message passing environment identifier
22737!> \param[in] tag Send and recv tag (default: 0)
22738! **************************************************************************************************
22739 SUBROUTINE mp_sendrecv_r (msgin, dest, msgout, source, comm, tag)
22740 REAL(kind=real_4), INTENT(IN) :: msgin
22741 INTEGER, INTENT(IN) :: dest
22742 REAL(kind=real_4), INTENT(OUT) :: msgout
22743 INTEGER, INTENT(IN) :: source
22744 CLASS(mp_comm_type), INTENT(IN) :: comm
22745 INTEGER, INTENT(IN), OPTIONAL :: tag
22746
22747 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_r'
22748
22749 INTEGER :: handle
22750#if defined(__parallel)
22751 INTEGER :: ierr, msglen_in, msglen_out, &
22752 recv_tag, send_tag
22753#endif
22754
22755 CALL mp_timeset(routinen, handle)
22756
22757#if defined(__parallel)
22758 msglen_in = 1
22759 msglen_out = 1
22760 send_tag = 0 ! cannot think of something better here, this might be dangerous
22761 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22762 IF (PRESENT(tag)) THEN
22763 send_tag = tag
22764 recv_tag = tag
22765 END IF
22766 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22767 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22768 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22769 CALL add_perf(perf_id=7, count=1, &
22770 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22771#else
22772 mark_used(dest)
22773 mark_used(source)
22774 mark_used(comm)
22775 mark_used(tag)
22776 msgout = msgin
22777#endif
22778 CALL mp_timestop(handle)
22779 END SUBROUTINE mp_sendrecv_r
22780
22781! **************************************************************************************************
22782!> \brief Sends and receives vector data
22783!> \param[in] msgin Data to send
22784!> \param[in] dest Process to send data to
22785!> \param[out] msgout Received data
22786!> \param[in] source Process from which to receive
22787!> \param[in] comm Message passing environment identifier
22788!> \param[in] tag Send and recv tag (default: 0)
22789! **************************************************************************************************
22790 SUBROUTINE mp_sendrecv_rv(msgin, dest, msgout, source, comm, tag)
22791 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
22792 INTEGER, INTENT(IN) :: dest
22793 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
22794 INTEGER, INTENT(IN) :: source
22795 CLASS(mp_comm_type), INTENT(IN) :: comm
22796 INTEGER, INTENT(IN), OPTIONAL :: tag
22797
22798 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rv'
22799
22800 INTEGER :: handle
22801#if defined(__parallel)
22802 INTEGER :: ierr, msglen_in, msglen_out, &
22803 recv_tag, send_tag
22804#endif
22805
22806 CALL mp_timeset(routinen, handle)
22807
22808#if defined(__parallel)
22809 msglen_in = SIZE(msgin)
22810 msglen_out = SIZE(msgout)
22811 send_tag = 0 ! cannot think of something better here, this might be dangerous
22812 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22813 IF (PRESENT(tag)) THEN
22814 send_tag = tag
22815 recv_tag = tag
22816 END IF
22817 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22818 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22819 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22820 CALL add_perf(perf_id=7, count=1, &
22821 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22822#else
22823 mark_used(dest)
22824 mark_used(source)
22825 mark_used(comm)
22826 mark_used(tag)
22827 msgout = msgin
22828#endif
22829 CALL mp_timestop(handle)
22830 END SUBROUTINE mp_sendrecv_rv
22831
22832! **************************************************************************************************
22833!> \brief Sends and receives matrix data
22834!> \param msgin ...
22835!> \param dest ...
22836!> \param msgout ...
22837!> \param source ...
22838!> \param comm ...
22839!> \param tag ...
22840!> \note see mp_sendrecv_rv
22841! **************************************************************************************************
22842 SUBROUTINE mp_sendrecv_rm2(msgin, dest, msgout, source, comm, tag)
22843 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
22844 INTEGER, INTENT(IN) :: dest
22845 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
22846 INTEGER, INTENT(IN) :: source
22847 CLASS(mp_comm_type), INTENT(IN) :: comm
22848 INTEGER, INTENT(IN), OPTIONAL :: tag
22849
22850 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm2'
22851
22852 INTEGER :: handle
22853#if defined(__parallel)
22854 INTEGER :: ierr, msglen_in, msglen_out, &
22855 recv_tag, send_tag
22856#endif
22857
22858 CALL mp_timeset(routinen, handle)
22859
22860#if defined(__parallel)
22861 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
22862 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
22863 send_tag = 0 ! cannot think of something better here, this might be dangerous
22864 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22865 IF (PRESENT(tag)) THEN
22866 send_tag = tag
22867 recv_tag = tag
22868 END IF
22869 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22870 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22871 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22872 CALL add_perf(perf_id=7, count=1, &
22873 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22874#else
22875 mark_used(dest)
22876 mark_used(source)
22877 mark_used(comm)
22878 mark_used(tag)
22879 msgout = msgin
22880#endif
22881 CALL mp_timestop(handle)
22882 END SUBROUTINE mp_sendrecv_rm2
22883
22884! **************************************************************************************************
22885!> \brief Sends and receives rank-3 data
22886!> \param msgin ...
22887!> \param dest ...
22888!> \param msgout ...
22889!> \param source ...
22890!> \param comm ...
22891!> \note see mp_sendrecv_rv
22892! **************************************************************************************************
22893 SUBROUTINE mp_sendrecv_rm3(msgin, dest, msgout, source, comm, tag)
22894 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
22895 INTEGER, INTENT(IN) :: dest
22896 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
22897 INTEGER, INTENT(IN) :: source
22898 CLASS(mp_comm_type), INTENT(IN) :: comm
22899 INTEGER, INTENT(IN), OPTIONAL :: tag
22900
22901 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm3'
22902
22903 INTEGER :: handle
22904#if defined(__parallel)
22905 INTEGER :: ierr, msglen_in, msglen_out, &
22906 recv_tag, send_tag
22907#endif
22908
22909 CALL mp_timeset(routinen, handle)
22910
22911#if defined(__parallel)
22912 msglen_in = SIZE(msgin)
22913 msglen_out = SIZE(msgout)
22914 send_tag = 0 ! cannot think of something better here, this might be dangerous
22915 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22916 IF (PRESENT(tag)) THEN
22917 send_tag = tag
22918 recv_tag = tag
22919 END IF
22920 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22921 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22922 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22923 CALL add_perf(perf_id=7, count=1, &
22924 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22925#else
22926 mark_used(dest)
22927 mark_used(source)
22928 mark_used(comm)
22929 mark_used(tag)
22930 msgout = msgin
22931#endif
22932 CALL mp_timestop(handle)
22933 END SUBROUTINE mp_sendrecv_rm3
22934
22935! **************************************************************************************************
22936!> \brief Sends and receives rank-4 data
22937!> \param msgin ...
22938!> \param dest ...
22939!> \param msgout ...
22940!> \param source ...
22941!> \param comm ...
22942!> \note see mp_sendrecv_rv
22943! **************************************************************************************************
22944 SUBROUTINE mp_sendrecv_rm4(msgin, dest, msgout, source, comm, tag)
22945 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
22946 INTEGER, INTENT(IN) :: dest
22947 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
22948 INTEGER, INTENT(IN) :: source
22949 CLASS(mp_comm_type), INTENT(IN) :: comm
22950 INTEGER, INTENT(IN), OPTIONAL :: tag
22951
22952 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm4'
22953
22954 INTEGER :: handle
22955#if defined(__parallel)
22956 INTEGER :: ierr, msglen_in, msglen_out, &
22957 recv_tag, send_tag
22958#endif
22959
22960 CALL mp_timeset(routinen, handle)
22961
22962#if defined(__parallel)
22963 msglen_in = SIZE(msgin)
22964 msglen_out = SIZE(msgout)
22965 send_tag = 0 ! cannot think of something better here, this might be dangerous
22966 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22967 IF (PRESENT(tag)) THEN
22968 send_tag = tag
22969 recv_tag = tag
22970 END IF
22971 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22972 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22973 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22974 CALL add_perf(perf_id=7, count=1, &
22975 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22976#else
22977 mark_used(dest)
22978 mark_used(source)
22979 mark_used(comm)
22980 mark_used(tag)
22981 msgout = msgin
22982#endif
22983 CALL mp_timestop(handle)
22984 END SUBROUTINE mp_sendrecv_rm4
22985
22986! **************************************************************************************************
22987!> \brief Non-blocking send and receive of a scalar
22988!> \param[in] msgin Scalar data to send
22989!> \param[in] dest Which process to send to
22990!> \param[out] msgout Receive data into this pointer
22991!> \param[in] source Process to receive from
22992!> \param[in] comm Message passing environment identifier
22993!> \param[out] send_request Request handle for the send
22994!> \param[out] recv_request Request handle for the receive
22995!> \param[in] tag (optional) tag to differentiate requests
22996!> \par Implementation
22997!> Calls mpi_isend and mpi_irecv.
22998!> \par History
22999!> 02.2005 created [Alfio Lazzaro]
23000! **************************************************************************************************
23001 SUBROUTINE mp_isendrecv_r (msgin, dest, msgout, source, comm, send_request, &
23002 recv_request, tag)
23003 REAL(kind=real_4), INTENT(IN) :: msgin
23004 INTEGER, INTENT(IN) :: dest
23005 REAL(kind=real_4), INTENT(INOUT) :: msgout
23006 INTEGER, INTENT(IN) :: source
23007 CLASS(mp_comm_type), INTENT(IN) :: comm
23008 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
23009 INTEGER, INTENT(in), OPTIONAL :: tag
23010
23011 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_r'
23012
23013 INTEGER :: handle
23014#if defined(__parallel)
23015 INTEGER :: ierr, my_tag
23016#endif
23017
23018 CALL mp_timeset(routinen, handle)
23019
23020#if defined(__parallel)
23021 my_tag = 0
23022 IF (PRESENT(tag)) my_tag = tag
23023
23024 CALL mpi_irecv(msgout, 1, mpi_real, source, my_tag, &
23025 comm%handle, recv_request%handle, ierr)
23026 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
23027
23028 CALL mpi_isend(msgin, 1, mpi_real, dest, my_tag, &
23029 comm%handle, send_request%handle, ierr)
23030 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
23031
23032 CALL add_perf(perf_id=8, count=1, msg_size=2*real_4_size)
23033#else
23034 mark_used(dest)
23035 mark_used(source)
23036 mark_used(comm)
23037 mark_used(tag)
23038 send_request = mp_request_null
23039 recv_request = mp_request_null
23040 msgout = msgin
23041#endif
23042 CALL mp_timestop(handle)
23043 END SUBROUTINE mp_isendrecv_r
23044
23045! **************************************************************************************************
23046!> \brief Non-blocking send and receive of a vector
23047!> \param[in] msgin Vector data to send
23048!> \param[in] dest Which process to send to
23049!> \param[out] msgout Receive data into this pointer
23050!> \param[in] source Process to receive from
23051!> \param[in] comm Message passing environment identifier
23052!> \param[out] send_request Request handle for the send
23053!> \param[out] recv_request Request handle for the receive
23054!> \param[in] tag (optional) tag to differentiate requests
23055!> \par Implementation
23056!> Calls mpi_isend and mpi_irecv.
23057!> \par History
23058!> 11.2004 created [Joost VandeVondele]
23059!> \note
23060!> arrays can be pointers or assumed shape, but they must be contiguous!
23061! **************************************************************************************************
23062 SUBROUTINE mp_isendrecv_rv(msgin, dest, msgout, source, comm, send_request, &
23063 recv_request, tag)
23064 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
23065 INTEGER, INTENT(IN) :: dest
23066 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
23067 INTEGER, INTENT(IN) :: source
23068 CLASS(mp_comm_type), INTENT(IN) :: comm
23069 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
23070 INTEGER, INTENT(in), OPTIONAL :: tag
23071
23072 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_rv'
23073
23074 INTEGER :: handle
23075#if defined(__parallel)
23076 INTEGER :: ierr, msglen, my_tag
23077 REAL(kind=real_4) :: foo
23078#endif
23079
23080 CALL mp_timeset(routinen, handle)
23081
23082#if defined(__parallel)
23083#if !defined(__GNUC__) || __GNUC__ >= 9
23084 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
23085 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
23086#endif
23087
23088 my_tag = 0
23089 IF (PRESENT(tag)) my_tag = tag
23090
23091 msglen = SIZE(msgout, 1)
23092 IF (msglen > 0) THEN
23093 CALL mpi_irecv(msgout(1), msglen, mpi_real, source, my_tag, &
23094 comm%handle, recv_request%handle, ierr)
23095 ELSE
23096 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23097 comm%handle, recv_request%handle, ierr)
23098 END IF
23099 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
23100
23101 msglen = SIZE(msgin, 1)
23102 IF (msglen > 0) THEN
23103 CALL mpi_isend(msgin(1), msglen, mpi_real, dest, my_tag, &
23104 comm%handle, send_request%handle, ierr)
23105 ELSE
23106 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
23107 comm%handle, send_request%handle, ierr)
23108 END IF
23109 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
23110
23111 msglen = (msglen + SIZE(msgout, 1) + 1)/2
23112 CALL add_perf(perf_id=8, count=1, msg_size=msglen*real_4_size)
23113#else
23114 mark_used(dest)
23115 mark_used(source)
23116 mark_used(comm)
23117 mark_used(tag)
23118 send_request = mp_request_null
23119 recv_request = mp_request_null
23120 msgout = msgin
23121#endif
23122 CALL mp_timestop(handle)
23123 END SUBROUTINE mp_isendrecv_rv
23124
23125! **************************************************************************************************
23126!> \brief Non-blocking send of vector data
23127!> \param msgin ...
23128!> \param dest ...
23129!> \param comm ...
23130!> \param request ...
23131!> \param tag ...
23132!> \par History
23133!> 08.2003 created [f&j]
23134!> \note see mp_isendrecv_rv
23135!> \note
23136!> arrays can be pointers or assumed shape, but they must be contiguous!
23137! **************************************************************************************************
23138 SUBROUTINE mp_isend_rv(msgin, dest, comm, request, tag)
23139 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
23140 INTEGER, INTENT(IN) :: dest
23141 CLASS(mp_comm_type), INTENT(IN) :: comm
23142 TYPE(mp_request_type), INTENT(out) :: request
23143 INTEGER, INTENT(in), OPTIONAL :: tag
23144
23145 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rv'
23146
23147 INTEGER :: handle, ierr
23148#if defined(__parallel)
23149 INTEGER :: msglen, my_tag
23150 REAL(kind=real_4) :: foo(1)
23151#endif
23152
23153 CALL mp_timeset(routinen, handle)
23154
23155#if defined(__parallel)
23156#if !defined(__GNUC__) || __GNUC__ >= 9
23157 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
23158#endif
23159 my_tag = 0
23160 IF (PRESENT(tag)) my_tag = tag
23161
23162 msglen = SIZE(msgin)
23163 IF (msglen > 0) THEN
23164 CALL mpi_isend(msgin(1), msglen, mpi_real, dest, my_tag, &
23165 comm%handle, request%handle, ierr)
23166 ELSE
23167 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
23168 comm%handle, request%handle, ierr)
23169 END IF
23170 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
23171
23172 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
23173#else
23174 mark_used(msgin)
23175 mark_used(dest)
23176 mark_used(comm)
23177 mark_used(request)
23178 mark_used(tag)
23179 ierr = 1
23180 request = mp_request_null
23181 CALL mp_stop(ierr, "mp_isend called in non parallel case")
23182#endif
23183 CALL mp_timestop(handle)
23184 END SUBROUTINE mp_isend_rv
23185
23186! **************************************************************************************************
23187!> \brief Non-blocking send of matrix data
23188!> \param msgin ...
23189!> \param dest ...
23190!> \param comm ...
23191!> \param request ...
23192!> \param tag ...
23193!> \par History
23194!> 2009-11-25 [UB] Made type-generic for templates
23195!> \author fawzi
23196!> \note see mp_isendrecv_rv
23197!> \note see mp_isend_rv
23198!> \note
23199!> arrays can be pointers or assumed shape, but they must be contiguous!
23200! **************************************************************************************************
23201 SUBROUTINE mp_isend_rm2(msgin, dest, comm, request, tag)
23202 REAL(kind=real_4), DIMENSION(:, :), INTENT(IN) :: msgin
23203 INTEGER, INTENT(IN) :: dest
23204 CLASS(mp_comm_type), INTENT(IN) :: comm
23205 TYPE(mp_request_type), INTENT(out) :: request
23206 INTEGER, INTENT(in), OPTIONAL :: tag
23207
23208 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm2'
23209
23210 INTEGER :: handle, ierr
23211#if defined(__parallel)
23212 INTEGER :: msglen, my_tag
23213 REAL(kind=real_4) :: foo(1)
23214#endif
23215
23216 CALL mp_timeset(routinen, handle)
23217
23218#if defined(__parallel)
23219#if !defined(__GNUC__) || __GNUC__ >= 9
23220 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
23221#endif
23222
23223 my_tag = 0
23224 IF (PRESENT(tag)) my_tag = tag
23225
23226 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
23227 IF (msglen > 0) THEN
23228 CALL mpi_isend(msgin(1, 1), msglen, mpi_real, dest, my_tag, &
23229 comm%handle, request%handle, ierr)
23230 ELSE
23231 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
23232 comm%handle, request%handle, ierr)
23233 END IF
23234 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
23235
23236 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
23237#else
23238 mark_used(msgin)
23239 mark_used(dest)
23240 mark_used(comm)
23241 mark_used(request)
23242 mark_used(tag)
23243 ierr = 1
23244 request = mp_request_null
23245 CALL mp_stop(ierr, "mp_isend called in non parallel case")
23246#endif
23247 CALL mp_timestop(handle)
23248 END SUBROUTINE mp_isend_rm2
23249
23250! **************************************************************************************************
23251!> \brief Non-blocking send of rank-3 data
23252!> \param msgin ...
23253!> \param dest ...
23254!> \param comm ...
23255!> \param request ...
23256!> \param tag ...
23257!> \par History
23258!> 9.2008 added _rm3 subroutine [Iain Bethune]
23259!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
23260!> 2009-11-25 [UB] Made type-generic for templates
23261!> \author fawzi
23262!> \note see mp_isendrecv_rv
23263!> \note see mp_isend_rv
23264!> \note
23265!> arrays can be pointers or assumed shape, but they must be contiguous!
23266! **************************************************************************************************
23267 SUBROUTINE mp_isend_rm3(msgin, dest, comm, request, tag)
23268 REAL(kind=real_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
23269 INTEGER, INTENT(IN) :: dest
23270 CLASS(mp_comm_type), INTENT(IN) :: comm
23271 TYPE(mp_request_type), INTENT(out) :: request
23272 INTEGER, INTENT(in), OPTIONAL :: tag
23273
23274 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm3'
23275
23276 INTEGER :: handle, ierr
23277#if defined(__parallel)
23278 INTEGER :: msglen, my_tag
23279 REAL(kind=real_4) :: foo(1)
23280#endif
23281
23282 CALL mp_timeset(routinen, handle)
23283
23284#if defined(__parallel)
23285#if !defined(__GNUC__) || __GNUC__ >= 9
23286 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
23287#endif
23288
23289 my_tag = 0
23290 IF (PRESENT(tag)) my_tag = tag
23291
23292 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
23293 IF (msglen > 0) THEN
23294 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_real, dest, my_tag, &
23295 comm%handle, request%handle, ierr)
23296 ELSE
23297 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
23298 comm%handle, request%handle, ierr)
23299 END IF
23300 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
23301
23302 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
23303#else
23304 mark_used(msgin)
23305 mark_used(dest)
23306 mark_used(comm)
23307 mark_used(request)
23308 mark_used(tag)
23309 ierr = 1
23310 request = mp_request_null
23311 CALL mp_stop(ierr, "mp_isend called in non parallel case")
23312#endif
23313 CALL mp_timestop(handle)
23314 END SUBROUTINE mp_isend_rm3
23315
23316! **************************************************************************************************
23317!> \brief Non-blocking send of rank-4 data
23318!> \param msgin the input message
23319!> \param dest the destination processor
23320!> \param comm the communicator object
23321!> \param request the communication request id
23322!> \param tag the message tag
23323!> \par History
23324!> 2.2016 added _rm4 subroutine [Nico Holmberg]
23325!> \author fawzi
23326!> \note see mp_isend_rv
23327!> \note
23328!> arrays can be pointers or assumed shape, but they must be contiguous!
23329! **************************************************************************************************
23330 SUBROUTINE mp_isend_rm4(msgin, dest, comm, request, tag)
23331 REAL(kind=real_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
23332 INTEGER, INTENT(IN) :: dest
23333 CLASS(mp_comm_type), INTENT(IN) :: comm
23334 TYPE(mp_request_type), INTENT(out) :: request
23335 INTEGER, INTENT(in), OPTIONAL :: tag
23336
23337 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm4'
23338
23339 INTEGER :: handle, ierr
23340#if defined(__parallel)
23341 INTEGER :: msglen, my_tag
23342 REAL(kind=real_4) :: foo(1)
23343#endif
23344
23345 CALL mp_timeset(routinen, handle)
23346
23347#if defined(__parallel)
23348#if !defined(__GNUC__) || __GNUC__ >= 9
23349 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
23350#endif
23351
23352 my_tag = 0
23353 IF (PRESENT(tag)) my_tag = tag
23354
23355 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
23356 IF (msglen > 0) THEN
23357 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_real, dest, my_tag, &
23358 comm%handle, request%handle, ierr)
23359 ELSE
23360 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
23361 comm%handle, request%handle, ierr)
23362 END IF
23363 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
23364
23365 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
23366#else
23367 mark_used(msgin)
23368 mark_used(dest)
23369 mark_used(comm)
23370 mark_used(request)
23371 mark_used(tag)
23372 ierr = 1
23373 request = mp_request_null
23374 CALL mp_stop(ierr, "mp_isend called in non parallel case")
23375#endif
23376 CALL mp_timestop(handle)
23377 END SUBROUTINE mp_isend_rm4
23378
23379! **************************************************************************************************
23380!> \brief Non-blocking receive of vector data
23381!> \param msgout ...
23382!> \param source ...
23383!> \param comm ...
23384!> \param request ...
23385!> \param tag ...
23386!> \par History
23387!> 08.2003 created [f&j]
23388!> 2009-11-25 [UB] Made type-generic for templates
23389!> \note see mp_isendrecv_rv
23390!> \note
23391!> arrays can be pointers or assumed shape, but they must be contiguous!
23392! **************************************************************************************************
23393 SUBROUTINE mp_irecv_rv(msgout, source, comm, request, tag)
23394 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
23395 INTEGER, INTENT(IN) :: source
23396 CLASS(mp_comm_type), INTENT(IN) :: comm
23397 TYPE(mp_request_type), INTENT(out) :: request
23398 INTEGER, INTENT(in), OPTIONAL :: tag
23399
23400 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rv'
23401
23402 INTEGER :: handle
23403#if defined(__parallel)
23404 INTEGER :: ierr, msglen, my_tag
23405 REAL(kind=real_4) :: foo(1)
23406#endif
23407
23408 CALL mp_timeset(routinen, handle)
23409
23410#if defined(__parallel)
23411#if !defined(__GNUC__) || __GNUC__ >= 9
23412 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
23413#endif
23414
23415 my_tag = 0
23416 IF (PRESENT(tag)) my_tag = tag
23417
23418 msglen = SIZE(msgout)
23419 IF (msglen > 0) THEN
23420 CALL mpi_irecv(msgout(1), msglen, mpi_real, source, my_tag, &
23421 comm%handle, request%handle, ierr)
23422 ELSE
23423 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23424 comm%handle, request%handle, ierr)
23425 END IF
23426 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
23427
23428 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23429#else
23430 cpabort("mp_irecv called in non parallel case")
23431 mark_used(msgout)
23432 mark_used(source)
23433 mark_used(comm)
23434 mark_used(tag)
23435 request = mp_request_null
23436#endif
23437 CALL mp_timestop(handle)
23438 END SUBROUTINE mp_irecv_rv
23439
23440! **************************************************************************************************
23441!> \brief Non-blocking receive of matrix data
23442!> \param msgout ...
23443!> \param source ...
23444!> \param comm ...
23445!> \param request ...
23446!> \param tag ...
23447!> \par History
23448!> 2009-11-25 [UB] Made type-generic for templates
23449!> \author fawzi
23450!> \note see mp_isendrecv_rv
23451!> \note see mp_irecv_rv
23452!> \note
23453!> arrays can be pointers or assumed shape, but they must be contiguous!
23454! **************************************************************************************************
23455 SUBROUTINE mp_irecv_rm2(msgout, source, comm, request, tag)
23456 REAL(kind=real_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
23457 INTEGER, INTENT(IN) :: source
23458 CLASS(mp_comm_type), INTENT(IN) :: comm
23459 TYPE(mp_request_type), INTENT(out) :: request
23460 INTEGER, INTENT(in), OPTIONAL :: tag
23461
23462 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm2'
23463
23464 INTEGER :: handle
23465#if defined(__parallel)
23466 INTEGER :: ierr, msglen, my_tag
23467 REAL(kind=real_4) :: foo(1)
23468#endif
23469
23470 CALL mp_timeset(routinen, handle)
23471
23472#if defined(__parallel)
23473#if !defined(__GNUC__) || __GNUC__ >= 9
23474 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
23475#endif
23476
23477 my_tag = 0
23478 IF (PRESENT(tag)) my_tag = tag
23479
23480 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
23481 IF (msglen > 0) THEN
23482 CALL mpi_irecv(msgout(1, 1), msglen, mpi_real, source, my_tag, &
23483 comm%handle, request%handle, ierr)
23484 ELSE
23485 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23486 comm%handle, request%handle, ierr)
23487 END IF
23488 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
23489
23490 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23491#else
23492 mark_used(msgout)
23493 mark_used(source)
23494 mark_used(comm)
23495 mark_used(tag)
23496 request = mp_request_null
23497 cpabort("mp_irecv called in non parallel case")
23498#endif
23499 CALL mp_timestop(handle)
23500 END SUBROUTINE mp_irecv_rm2
23501
23502! **************************************************************************************************
23503!> \brief Non-blocking send of rank-3 data
23504!> \param msgout ...
23505!> \param source ...
23506!> \param comm ...
23507!> \param request ...
23508!> \param tag ...
23509!> \par History
23510!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
23511!> 2009-11-25 [UB] Made type-generic for templates
23512!> \author fawzi
23513!> \note see mp_isendrecv_rv
23514!> \note see mp_irecv_rv
23515!> \note
23516!> arrays can be pointers or assumed shape, but they must be contiguous!
23517! **************************************************************************************************
23518 SUBROUTINE mp_irecv_rm3(msgout, source, comm, request, tag)
23519 REAL(kind=real_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
23520 INTEGER, INTENT(IN) :: source
23521 CLASS(mp_comm_type), INTENT(IN) :: comm
23522 TYPE(mp_request_type), INTENT(out) :: request
23523 INTEGER, INTENT(in), OPTIONAL :: tag
23524
23525 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm3'
23526
23527 INTEGER :: handle
23528#if defined(__parallel)
23529 INTEGER :: ierr, msglen, my_tag
23530 REAL(kind=real_4) :: foo(1)
23531#endif
23532
23533 CALL mp_timeset(routinen, handle)
23534
23535#if defined(__parallel)
23536#if !defined(__GNUC__) || __GNUC__ >= 9
23537 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
23538#endif
23539
23540 my_tag = 0
23541 IF (PRESENT(tag)) my_tag = tag
23542
23543 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
23544 IF (msglen > 0) THEN
23545 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_real, source, my_tag, &
23546 comm%handle, request%handle, ierr)
23547 ELSE
23548 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23549 comm%handle, request%handle, ierr)
23550 END IF
23551 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
23552
23553 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23554#else
23555 mark_used(msgout)
23556 mark_used(source)
23557 mark_used(comm)
23558 mark_used(tag)
23559 request = mp_request_null
23560 cpabort("mp_irecv called in non parallel case")
23561#endif
23562 CALL mp_timestop(handle)
23563 END SUBROUTINE mp_irecv_rm3
23564
23565! **************************************************************************************************
23566!> \brief Non-blocking receive of rank-4 data
23567!> \param msgout the output message
23568!> \param source the source processor
23569!> \param comm the communicator object
23570!> \param request the communication request id
23571!> \param tag the message tag
23572!> \par History
23573!> 2.2016 added _rm4 subroutine [Nico Holmberg]
23574!> \author fawzi
23575!> \note see mp_irecv_rv
23576!> \note
23577!> arrays can be pointers or assumed shape, but they must be contiguous!
23578! **************************************************************************************************
23579 SUBROUTINE mp_irecv_rm4(msgout, source, comm, request, tag)
23580 REAL(kind=real_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
23581 INTEGER, INTENT(IN) :: source
23582 CLASS(mp_comm_type), INTENT(IN) :: comm
23583 TYPE(mp_request_type), INTENT(out) :: request
23584 INTEGER, INTENT(in), OPTIONAL :: tag
23585
23586 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm4'
23587
23588 INTEGER :: handle
23589#if defined(__parallel)
23590 INTEGER :: ierr, msglen, my_tag
23591 REAL(kind=real_4) :: foo(1)
23592#endif
23593
23594 CALL mp_timeset(routinen, handle)
23595
23596#if defined(__parallel)
23597#if !defined(__GNUC__) || __GNUC__ >= 9
23598 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
23599#endif
23600
23601 my_tag = 0
23602 IF (PRESENT(tag)) my_tag = tag
23603
23604 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
23605 IF (msglen > 0) THEN
23606 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_real, source, my_tag, &
23607 comm%handle, request%handle, ierr)
23608 ELSE
23609 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23610 comm%handle, request%handle, ierr)
23611 END IF
23612 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
23613
23614 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23615#else
23616 mark_used(msgout)
23617 mark_used(source)
23618 mark_used(comm)
23619 mark_used(tag)
23620 request = mp_request_null
23621 cpabort("mp_irecv called in non parallel case")
23622#endif
23623 CALL mp_timestop(handle)
23624 END SUBROUTINE mp_irecv_rm4
23625
23626! **************************************************************************************************
23627!> \brief Window initialization function for vector data
23628!> \param base ...
23629!> \param comm ...
23630!> \param win ...
23631!> \par History
23632!> 02.2015 created [Alfio Lazzaro]
23633!> \note
23634!> arrays can be pointers or assumed shape, but they must be contiguous!
23635! **************************************************************************************************
23636 SUBROUTINE mp_win_create_rv(base, comm, win)
23637 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
23638 TYPE(mp_comm_type), INTENT(IN) :: comm
23639 CLASS(mp_win_type), INTENT(INOUT) :: win
23640
23641 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_rv'
23642
23643 INTEGER :: handle
23644#if defined(__parallel)
23645 INTEGER :: ierr
23646 INTEGER(kind=mpi_address_kind) :: len
23647 REAL(kind=real_4) :: foo(1)
23648#endif
23649
23650 CALL mp_timeset(routinen, handle)
23651
23652#if defined(__parallel)
23653
23654 len = SIZE(base)*real_4_size
23655 IF (len > 0) THEN
23656 CALL mpi_win_create(base(1), len, real_4_size, mpi_info_null, comm%handle, win%handle, ierr)
23657 ELSE
23658 CALL mpi_win_create(foo, len, real_4_size, mpi_info_null, comm%handle, win%handle, ierr)
23659 END IF
23660 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
23661
23662 CALL add_perf(perf_id=20, count=1)
23663#else
23664 mark_used(base)
23665 mark_used(comm)
23666 win%handle = mp_win_null_handle
23667#endif
23668 CALL mp_timestop(handle)
23669 END SUBROUTINE mp_win_create_rv
23670
23671! **************************************************************************************************
23672!> \brief Single-sided get function for vector data
23673!> \param base ...
23674!> \param comm ...
23675!> \param win ...
23676!> \par History
23677!> 02.2015 created [Alfio Lazzaro]
23678!> \note
23679!> arrays can be pointers or assumed shape, but they must be contiguous!
23680! **************************************************************************************************
23681 SUBROUTINE mp_rget_rv(base, source, win, win_data, myproc, disp, request, &
23682 origin_datatype, target_datatype)
23683 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
23684 INTEGER, INTENT(IN) :: source
23685 CLASS(mp_win_type), INTENT(IN) :: win
23686 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: win_data
23687 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
23688 TYPE(mp_request_type), INTENT(OUT) :: request
23689 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
23690
23691 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_rv'
23692
23693 INTEGER :: handle
23694#if defined(__parallel)
23695 INTEGER :: ierr, len, &
23696 origin_len, target_len
23697 LOGICAL :: do_local_copy
23698 INTEGER(kind=mpi_address_kind) :: disp_aint
23699 mpi_data_type :: handle_origin_datatype, handle_target_datatype
23700#endif
23701
23702 CALL mp_timeset(routinen, handle)
23703
23704#if defined(__parallel)
23705 len = SIZE(base)
23706 disp_aint = 0
23707 IF (PRESENT(disp)) THEN
23708 disp_aint = int(disp, kind=mpi_address_kind)
23709 END IF
23710 handle_origin_datatype = mpi_real
23711 origin_len = len
23712 IF (PRESENT(origin_datatype)) THEN
23713 handle_origin_datatype = origin_datatype%type_handle
23714 origin_len = 1
23715 END IF
23716 handle_target_datatype = mpi_real
23717 target_len = len
23718 IF (PRESENT(target_datatype)) THEN
23719 handle_target_datatype = target_datatype%type_handle
23720 target_len = 1
23721 END IF
23722 IF (len > 0) THEN
23723 do_local_copy = .false.
23724 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
23725 IF (myproc .EQ. source) do_local_copy = .true.
23726 END IF
23727 IF (do_local_copy) THEN
23728 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
23729 base(:) = win_data(disp_aint + 1:disp_aint + len)
23730 !$OMP END PARALLEL WORKSHARE
23731 request = mp_request_null
23732 ierr = 0
23733 ELSE
23734 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
23735 target_len, handle_target_datatype, win%handle, request%handle, ierr)
23736 END IF
23737 ELSE
23738 request = mp_request_null
23739 ierr = 0
23740 END IF
23741 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
23742
23743 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*real_4_size)
23744#else
23745 mark_used(source)
23746 mark_used(win)
23747 mark_used(myproc)
23748 mark_used(origin_datatype)
23749 mark_used(target_datatype)
23750
23751 request = mp_request_null
23752 !
23753 IF (PRESENT(disp)) THEN
23754 base(:) = win_data(disp + 1:disp + SIZE(base))
23755 ELSE
23756 base(:) = win_data(:SIZE(base))
23757 END IF
23758
23759#endif
23760 CALL mp_timestop(handle)
23761 END SUBROUTINE mp_rget_rv
23762
23763! **************************************************************************************************
23764!> \brief ...
23765!> \param count ...
23766!> \param lengths ...
23767!> \param displs ...
23768!> \return ...
23769! ***************************************************************************
23770 FUNCTION mp_type_indexed_make_r (count, lengths, displs) &
23771 result(type_descriptor)
23772 INTEGER, INTENT(IN) :: count
23773 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
23774 TYPE(mp_type_descriptor_type) :: type_descriptor
23775
23776 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_r'
23777
23778 INTEGER :: handle
23779#if defined(__parallel)
23780 INTEGER :: ierr
23781#endif
23782
23783 CALL mp_timeset(routinen, handle)
23784
23785#if defined(__parallel)
23786 CALL mpi_type_indexed(count, lengths, displs, mpi_real, &
23787 type_descriptor%type_handle, ierr)
23788 IF (ierr /= 0) &
23789 cpabort("MPI_Type_Indexed @ "//routinen)
23790 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
23791 IF (ierr /= 0) &
23792 cpabort("MPI_Type_commit @ "//routinen)
23793#else
23794 type_descriptor%type_handle = 1
23795#endif
23796 type_descriptor%length = count
23797 NULLIFY (type_descriptor%subtype)
23798 type_descriptor%vector_descriptor(1:2) = 1
23799 type_descriptor%has_indexing = .true.
23800 type_descriptor%index_descriptor%index => lengths
23801 type_descriptor%index_descriptor%chunks => displs
23802
23803 CALL mp_timestop(handle)
23804
23805 END FUNCTION mp_type_indexed_make_r
23806
23807! **************************************************************************************************
23808!> \brief Allocates special parallel memory
23809!> \param[in] DATA pointer to integer array to allocate
23810!> \param[in] len number of integers to allocate
23811!> \param[out] stat (optional) allocation status result
23812!> \author UB
23813! **************************************************************************************************
23814 SUBROUTINE mp_allocate_r (DATA, len, stat)
23815 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23816 INTEGER, INTENT(IN) :: len
23817 INTEGER, INTENT(OUT), OPTIONAL :: stat
23818
23819 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_r'
23820
23821 INTEGER :: handle, ierr
23822
23823 CALL mp_timeset(routinen, handle)
23824
23825#if defined(__parallel)
23826 NULLIFY (data)
23827 CALL mp_alloc_mem(DATA, len, stat=ierr)
23828 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
23829 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
23830 CALL add_perf(perf_id=15, count=1)
23831#else
23832 ALLOCATE (DATA(len), stat=ierr)
23833 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
23834 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
23835#endif
23836 IF (PRESENT(stat)) stat = ierr
23837 CALL mp_timestop(handle)
23838 END SUBROUTINE mp_allocate_r
23839
23840! **************************************************************************************************
23841!> \brief Deallocates special parallel memory
23842!> \param[in] DATA pointer to special memory to deallocate
23843!> \param stat ...
23844!> \author UB
23845! **************************************************************************************************
23846 SUBROUTINE mp_deallocate_r (DATA, stat)
23847 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23848 INTEGER, INTENT(OUT), OPTIONAL :: stat
23849
23850 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_r'
23851
23852 INTEGER :: handle
23853#if defined(__parallel)
23854 INTEGER :: ierr
23855#endif
23856
23857 CALL mp_timeset(routinen, handle)
23858
23859#if defined(__parallel)
23860 CALL mp_free_mem(DATA, ierr)
23861 IF (PRESENT(stat)) THEN
23862 stat = ierr
23863 ELSE
23864 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
23865 END IF
23866 NULLIFY (data)
23867 CALL add_perf(perf_id=15, count=1)
23868#else
23869 DEALLOCATE (data)
23870 IF (PRESENT(stat)) stat = 0
23871#endif
23872 CALL mp_timestop(handle)
23873 END SUBROUTINE mp_deallocate_r
23874
23875! **************************************************************************************************
23876!> \brief (parallel) Blocking individual file write using explicit offsets
23877!> (serial) Unformatted stream write
23878!> \param[in] fh file handle (file storage unit)
23879!> \param[in] offset file offset (position)
23880!> \param[in] msg data to be written to the file
23881!> \param msglen ...
23882!> \par MPI-I/O mapping mpi_file_write_at
23883!> \par STREAM-I/O mapping WRITE
23884!> \param[in](optional) msglen number of the elements of data
23885! **************************************************************************************************
23886 SUBROUTINE mp_file_write_at_rv(fh, offset, msg, msglen)
23887 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
23888 CLASS(mp_file_type), INTENT(IN) :: fh
23889 INTEGER, INTENT(IN), OPTIONAL :: msglen
23890 INTEGER(kind=file_offset), INTENT(IN) :: offset
23891
23892 INTEGER :: msg_len
23893#if defined(__parallel)
23894 INTEGER :: ierr
23895#endif
23896
23897 msg_len = SIZE(msg)
23898 IF (PRESENT(msglen)) msg_len = msglen
23899#if defined(__parallel)
23900 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23901 IF (ierr .NE. 0) &
23902 cpabort("mpi_file_write_at_rv @ mp_file_write_at_rv")
23903#else
23904 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23905#endif
23906 END SUBROUTINE mp_file_write_at_rv
23907
23908! **************************************************************************************************
23909!> \brief ...
23910!> \param fh ...
23911!> \param offset ...
23912!> \param msg ...
23913! **************************************************************************************************
23914 SUBROUTINE mp_file_write_at_r (fh, offset, msg)
23915 REAL(kind=real_4), INTENT(IN) :: msg
23916 CLASS(mp_file_type), INTENT(IN) :: fh
23917 INTEGER(kind=file_offset), INTENT(IN) :: offset
23918
23919#if defined(__parallel)
23920 INTEGER :: ierr
23921
23922 ierr = 0
23923 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23924 IF (ierr .NE. 0) &
23925 cpabort("mpi_file_write_at_r @ mp_file_write_at_r")
23926#else
23927 WRITE (unit=fh%handle, pos=offset + 1) msg
23928#endif
23929 END SUBROUTINE mp_file_write_at_r
23930
23931! **************************************************************************************************
23932!> \brief (parallel) Blocking collective file write using explicit offsets
23933!> (serial) Unformatted stream write
23934!> \param fh ...
23935!> \param offset ...
23936!> \param msg ...
23937!> \param msglen ...
23938!> \par MPI-I/O mapping mpi_file_write_at_all
23939!> \par STREAM-I/O mapping WRITE
23940! **************************************************************************************************
23941 SUBROUTINE mp_file_write_at_all_rv(fh, offset, msg, msglen)
23942 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
23943 CLASS(mp_file_type), INTENT(IN) :: fh
23944 INTEGER, INTENT(IN), OPTIONAL :: msglen
23945 INTEGER(kind=file_offset), INTENT(IN) :: offset
23946
23947 INTEGER :: msg_len
23948#if defined(__parallel)
23949 INTEGER :: ierr
23950#endif
23951
23952 msg_len = SIZE(msg)
23953 IF (PRESENT(msglen)) msg_len = msglen
23954#if defined(__parallel)
23955 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23956 IF (ierr .NE. 0) &
23957 cpabort("mpi_file_write_at_all_rv @ mp_file_write_at_all_rv")
23958#else
23959 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23960#endif
23961 END SUBROUTINE mp_file_write_at_all_rv
23962
23963! **************************************************************************************************
23964!> \brief ...
23965!> \param fh ...
23966!> \param offset ...
23967!> \param msg ...
23968! **************************************************************************************************
23969 SUBROUTINE mp_file_write_at_all_r (fh, offset, msg)
23970 REAL(kind=real_4), INTENT(IN) :: msg
23971 CLASS(mp_file_type), INTENT(IN) :: fh
23972 INTEGER(kind=file_offset), INTENT(IN) :: offset
23973
23974#if defined(__parallel)
23975 INTEGER :: ierr
23976
23977 ierr = 0
23978 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23979 IF (ierr .NE. 0) &
23980 cpabort("mpi_file_write_at_all_r @ mp_file_write_at_all_r")
23981#else
23982 WRITE (unit=fh%handle, pos=offset + 1) msg
23983#endif
23984 END SUBROUTINE mp_file_write_at_all_r
23985
23986! **************************************************************************************************
23987!> \brief (parallel) Blocking individual file read using explicit offsets
23988!> (serial) Unformatted stream read
23989!> \param[in] fh file handle (file storage unit)
23990!> \param[in] offset file offset (position)
23991!> \param[out] msg data to be read from the file
23992!> \param msglen ...
23993!> \par MPI-I/O mapping mpi_file_read_at
23994!> \par STREAM-I/O mapping READ
23995!> \param[in](optional) msglen number of elements of data
23996! **************************************************************************************************
23997 SUBROUTINE mp_file_read_at_rv(fh, offset, msg, msglen)
23998 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
23999 CLASS(mp_file_type), INTENT(IN) :: fh
24000 INTEGER, INTENT(IN), OPTIONAL :: msglen
24001 INTEGER(kind=file_offset), INTENT(IN) :: offset
24002
24003 INTEGER :: msg_len
24004#if defined(__parallel)
24005 INTEGER :: ierr
24006#endif
24007
24008 msg_len = SIZE(msg)
24009 IF (PRESENT(msglen)) msg_len = msglen
24010#if defined(__parallel)
24011 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
24012 IF (ierr .NE. 0) &
24013 cpabort("mpi_file_read_at_rv @ mp_file_read_at_rv")
24014#else
24015 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
24016#endif
24017 END SUBROUTINE mp_file_read_at_rv
24018
24019! **************************************************************************************************
24020!> \brief ...
24021!> \param fh ...
24022!> \param offset ...
24023!> \param msg ...
24024! **************************************************************************************************
24025 SUBROUTINE mp_file_read_at_r (fh, offset, msg)
24026 REAL(kind=real_4), INTENT(OUT) :: msg
24027 CLASS(mp_file_type), INTENT(IN) :: fh
24028 INTEGER(kind=file_offset), INTENT(IN) :: offset
24029
24030#if defined(__parallel)
24031 INTEGER :: ierr
24032
24033 ierr = 0
24034 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
24035 IF (ierr .NE. 0) &
24036 cpabort("mpi_file_read_at_r @ mp_file_read_at_r")
24037#else
24038 READ (unit=fh%handle, pos=offset + 1) msg
24039#endif
24040 END SUBROUTINE mp_file_read_at_r
24041
24042! **************************************************************************************************
24043!> \brief (parallel) Blocking collective file read using explicit offsets
24044!> (serial) Unformatted stream read
24045!> \param fh ...
24046!> \param offset ...
24047!> \param msg ...
24048!> \param msglen ...
24049!> \par MPI-I/O mapping mpi_file_read_at_all
24050!> \par STREAM-I/O mapping READ
24051! **************************************************************************************************
24052 SUBROUTINE mp_file_read_at_all_rv(fh, offset, msg, msglen)
24053 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
24054 CLASS(mp_file_type), INTENT(IN) :: fh
24055 INTEGER, INTENT(IN), OPTIONAL :: msglen
24056 INTEGER(kind=file_offset), INTENT(IN) :: offset
24057
24058 INTEGER :: msg_len
24059#if defined(__parallel)
24060 INTEGER :: ierr
24061#endif
24062
24063 msg_len = SIZE(msg)
24064 IF (PRESENT(msglen)) msg_len = msglen
24065#if defined(__parallel)
24066 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
24067 IF (ierr .NE. 0) &
24068 cpabort("mpi_file_read_at_all_rv @ mp_file_read_at_all_rv")
24069#else
24070 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
24071#endif
24072 END SUBROUTINE mp_file_read_at_all_rv
24073
24074! **************************************************************************************************
24075!> \brief ...
24076!> \param fh ...
24077!> \param offset ...
24078!> \param msg ...
24079! **************************************************************************************************
24080 SUBROUTINE mp_file_read_at_all_r (fh, offset, msg)
24081 REAL(kind=real_4), INTENT(OUT) :: msg
24082 CLASS(mp_file_type), INTENT(IN) :: fh
24083 INTEGER(kind=file_offset), INTENT(IN) :: offset
24084
24085#if defined(__parallel)
24086 INTEGER :: ierr
24087
24088 ierr = 0
24089 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
24090 IF (ierr .NE. 0) &
24091 cpabort("mpi_file_read_at_all_r @ mp_file_read_at_all_r")
24092#else
24093 READ (unit=fh%handle, pos=offset + 1) msg
24094#endif
24095 END SUBROUTINE mp_file_read_at_all_r
24096
24097! **************************************************************************************************
24098!> \brief ...
24099!> \param ptr ...
24100!> \param vector_descriptor ...
24101!> \param index_descriptor ...
24102!> \return ...
24103! **************************************************************************************************
24104 FUNCTION mp_type_make_r (ptr, &
24105 vector_descriptor, index_descriptor) &
24106 result(type_descriptor)
24107 REAL(kind=real_4), DIMENSION(:), TARGET, asynchronous :: ptr
24108 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
24109 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
24110 TYPE(mp_type_descriptor_type) :: type_descriptor
24111
24112 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_r'
24113
24114#if defined(__parallel)
24115 INTEGER :: ierr
24116#if defined(__MPI_F08)
24117 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
24118 EXTERNAL :: mpi_get_address
24119#endif
24120#endif
24121
24122 NULLIFY (type_descriptor%subtype)
24123 type_descriptor%length = SIZE(ptr)
24124#if defined(__parallel)
24125 type_descriptor%type_handle = mpi_real
24126 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
24127 IF (ierr /= 0) &
24128 cpabort("MPI_Get_address @ "//routinen)
24129#else
24130 type_descriptor%type_handle = 1
24131#endif
24132 type_descriptor%vector_descriptor(1:2) = 1
24133 type_descriptor%has_indexing = .false.
24134 type_descriptor%data_r => ptr
24135 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
24136 cpabort(routinen//": Vectors and indices NYI")
24137 END IF
24138 END FUNCTION mp_type_make_r
24139
24140! **************************************************************************************************
24141!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
24142!> as the Fortran version returns an integer, which we take to be a C_PTR
24143!> \param DATA data array to allocate
24144!> \param[in] len length (in data elements) of data array allocation
24145!> \param[out] stat (optional) allocation status result
24146! **************************************************************************************************
24147 SUBROUTINE mp_alloc_mem_r (DATA, len, stat)
24148 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
24149 INTEGER, INTENT(IN) :: len
24150 INTEGER, INTENT(OUT), OPTIONAL :: stat
24151
24152#if defined(__parallel)
24153 INTEGER :: size, ierr, length, &
24154 mp_res
24155 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
24156 TYPE(c_ptr) :: mp_baseptr
24157 mpi_info_type :: mp_info
24158
24159 length = max(len, 1)
24160 CALL mpi_type_size(mpi_real, size, ierr)
24161 mp_size = int(length, kind=mpi_address_kind)*size
24162 IF (mp_size .GT. mp_max_memory_size) THEN
24163 cpabort("MPI cannot allocate more than 2 GiByte")
24164 END IF
24165 mp_info = mpi_info_null
24166 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
24167 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
24168 IF (PRESENT(stat)) stat = mp_res
24169#else
24170 INTEGER :: length, mystat
24171 length = max(len, 1)
24172 IF (PRESENT(stat)) THEN
24173 ALLOCATE (DATA(length), stat=mystat)
24174 stat = mystat ! show to convention checker that stat is used
24175 ELSE
24176 ALLOCATE (DATA(length))
24177 END IF
24178#endif
24179 END SUBROUTINE mp_alloc_mem_r
24180
24181! **************************************************************************************************
24182!> \brief Deallocates am array, ... this is hackish
24183!> as the Fortran version takes an integer, which we hope to get by reference
24184!> \param DATA data array to allocate
24185!> \param[out] stat (optional) allocation status result
24186! **************************************************************************************************
24187 SUBROUTINE mp_free_mem_r (DATA, stat)
24188 REAL(kind=real_4), DIMENSION(:), &
24189 POINTER, asynchronous :: DATA
24190 INTEGER, INTENT(OUT), OPTIONAL :: stat
24191
24192#if defined(__parallel)
24193 INTEGER :: mp_res
24194 CALL mpi_free_mem(DATA, mp_res)
24195 IF (PRESENT(stat)) stat = mp_res
24196#else
24197 DEALLOCATE (data)
24198 IF (PRESENT(stat)) stat = 0
24199#endif
24200 END SUBROUTINE mp_free_mem_r
24201! **************************************************************************************************
24202!> \brief Shift around the data in msg
24203!> \param[in,out] msg Rank-2 data to shift
24204!> \param[in] comm message passing environment identifier
24205!> \param[in] displ_in displacements (?)
24206!> \par Example
24207!> msg will be moved from rank to rank+displ_in (in a circular way)
24208!> \par Limitations
24209!> * displ_in will be 1 by default (others not tested)
24210!> * the message array needs to be the same size on all processes
24211! **************************************************************************************************
24212 SUBROUTINE mp_shift_zm(msg, comm, displ_in)
24213
24214 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24215 CLASS(mp_comm_type), INTENT(IN) :: comm
24216 INTEGER, INTENT(IN), OPTIONAL :: displ_in
24217
24218 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_zm'
24219
24220 INTEGER :: handle, ierror
24221#if defined(__parallel)
24222 INTEGER :: displ, left, &
24223 msglen, myrank, nprocs, &
24224 right, tag
24225#endif
24226
24227 ierror = 0
24228 CALL mp_timeset(routinen, handle)
24229
24230#if defined(__parallel)
24231 CALL mpi_comm_rank(comm%handle, myrank, ierror)
24232 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
24233 CALL mpi_comm_size(comm%handle, nprocs, ierror)
24234 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
24235 IF (PRESENT(displ_in)) THEN
24236 displ = displ_in
24237 ELSE
24238 displ = 1
24239 END IF
24240 right = modulo(myrank + displ, nprocs)
24241 left = modulo(myrank - displ, nprocs)
24242 tag = 17
24243 msglen = SIZE(msg)
24244 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_complex, right, tag, left, tag, &
24245 comm%handle, mpi_status_ignore, ierror)
24246 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
24247 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_8_size))
24248#else
24249 mark_used(msg)
24250 mark_used(comm)
24251 mark_used(displ_in)
24252#endif
24253 CALL mp_timestop(handle)
24254
24255 END SUBROUTINE mp_shift_zm
24256
24257! **************************************************************************************************
24258!> \brief Shift around the data in msg
24259!> \param[in,out] msg Data to shift
24260!> \param[in] comm message passing environment identifier
24261!> \param[in] displ_in displacements (?)
24262!> \par Example
24263!> msg will be moved from rank to rank+displ_in (in a circular way)
24264!> \par Limitations
24265!> * displ_in will be 1 by default (others not tested)
24266!> * the message array needs to be the same size on all processes
24267! **************************************************************************************************
24268 SUBROUTINE mp_shift_z (msg, comm, displ_in)
24269
24270 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24271 CLASS(mp_comm_type), INTENT(IN) :: comm
24272 INTEGER, INTENT(IN), OPTIONAL :: displ_in
24273
24274 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_z'
24275
24276 INTEGER :: handle, ierror
24277#if defined(__parallel)
24278 INTEGER :: displ, left, &
24279 msglen, myrank, nprocs, &
24280 right, tag
24281#endif
24282
24283 ierror = 0
24284 CALL mp_timeset(routinen, handle)
24285
24286#if defined(__parallel)
24287 CALL mpi_comm_rank(comm%handle, myrank, ierror)
24288 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
24289 CALL mpi_comm_size(comm%handle, nprocs, ierror)
24290 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
24291 IF (PRESENT(displ_in)) THEN
24292 displ = displ_in
24293 ELSE
24294 displ = 1
24295 END IF
24296 right = modulo(myrank + displ, nprocs)
24297 left = modulo(myrank - displ, nprocs)
24298 tag = 19
24299 msglen = SIZE(msg)
24300 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_complex, right, tag, left, &
24301 tag, comm%handle, mpi_status_ignore, ierror)
24302 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
24303 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_8_size))
24304#else
24305 mark_used(msg)
24306 mark_used(comm)
24307 mark_used(displ_in)
24308#endif
24309 CALL mp_timestop(handle)
24310
24311 END SUBROUTINE mp_shift_z
24312
24313! **************************************************************************************************
24314!> \brief All-to-all data exchange, rank-1 data of different sizes
24315!> \param[in] sb Data to send
24316!> \param[in] scount Data counts for data sent to other processes
24317!> \param[in] sdispl Respective data offsets for data sent to process
24318!> \param[in,out] rb Buffer into which to receive data
24319!> \param[in] rcount Data counts for data received from other
24320!> processes
24321!> \param[in] rdispl Respective data offsets for data received from
24322!> other processes
24323!> \param[in] comm Message passing environment identifier
24324!> \par MPI mapping
24325!> mpi_alltoallv
24326!> \par Array sizes
24327!> The scount, rcount, and the sdispl and rdispl arrays have a
24328!> size equal to the number of processes.
24329!> \par Offsets
24330!> Values in sdispl and rdispl start with 0.
24331! **************************************************************************************************
24332 SUBROUTINE mp_alltoall_z11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
24333
24334 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
24335 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
24336 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
24337 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
24338 CLASS(mp_comm_type), INTENT(IN) :: comm
24339
24340 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z11v'
24341
24342 INTEGER :: handle
24343#if defined(__parallel)
24344 INTEGER :: ierr, msglen
24345#else
24346 INTEGER :: i
24347#endif
24348
24349 CALL mp_timeset(routinen, handle)
24350
24351#if defined(__parallel)
24352 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_complex, &
24353 rb, rcount, rdispl, mpi_double_complex, comm%handle, ierr)
24354 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
24355 msglen = sum(scount) + sum(rcount)
24356 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24357#else
24358 mark_used(comm)
24359 mark_used(scount)
24360 mark_used(sdispl)
24361 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
24362 DO i = 1, rcount(1)
24363 rb(rdispl(1) + i) = sb(sdispl(1) + i)
24364 END DO
24365#endif
24366 CALL mp_timestop(handle)
24367
24368 END SUBROUTINE mp_alltoall_z11v
24369
24370! **************************************************************************************************
24371!> \brief All-to-all data exchange, rank-2 data of different sizes
24372!> \param sb ...
24373!> \param scount ...
24374!> \param sdispl ...
24375!> \param rb ...
24376!> \param rcount ...
24377!> \param rdispl ...
24378!> \param comm ...
24379!> \par MPI mapping
24380!> mpi_alltoallv
24381!> \note see mp_alltoall_z11v
24382! **************************************************************************************************
24383 SUBROUTINE mp_alltoall_z22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
24384
24385 COMPLEX(kind=real_8), DIMENSION(:, :), &
24386 INTENT(IN), CONTIGUOUS :: sb
24387 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
24388 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, &
24389 INTENT(INOUT) :: rb
24390 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
24391 CLASS(mp_comm_type), INTENT(IN) :: comm
24392
24393 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z22v'
24394
24395 INTEGER :: handle
24396#if defined(__parallel)
24397 INTEGER :: ierr, msglen
24398#endif
24399
24400 CALL mp_timeset(routinen, handle)
24401
24402#if defined(__parallel)
24403 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_complex, &
24404 rb, rcount, rdispl, mpi_double_complex, comm%handle, ierr)
24405 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
24406 msglen = sum(scount) + sum(rcount)
24407 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*(2*real_8_size))
24408#else
24409 mark_used(comm)
24410 mark_used(scount)
24411 mark_used(sdispl)
24412 mark_used(rcount)
24413 mark_used(rdispl)
24414 rb = sb
24415#endif
24416 CALL mp_timestop(handle)
24417
24418 END SUBROUTINE mp_alltoall_z22v
24419
24420! **************************************************************************************************
24421!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
24422!> \param[in] sb array with data to send
24423!> \param[out] rb array into which data is received
24424!> \param[in] count number of elements to send/receive (product of the
24425!> extents of the first two dimensions)
24426!> \param[in] comm Message passing environment identifier
24427!> \par Index meaning
24428!> \par The first two indices specify the data while the last index counts
24429!> the processes
24430!> \par Sizes of ranks
24431!> All processes have the same data size.
24432!> \par MPI mapping
24433!> mpi_alltoall
24434! **************************************************************************************************
24435 SUBROUTINE mp_alltoall_z (sb, rb, count, comm)
24436
24437 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
24438 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
24439 INTEGER, INTENT(IN) :: count
24440 CLASS(mp_comm_type), INTENT(IN) :: comm
24441
24442 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z'
24443
24444 INTEGER :: handle
24445#if defined(__parallel)
24446 INTEGER :: ierr, msglen, np
24447#endif
24448
24449 CALL mp_timeset(routinen, handle)
24450
24451#if defined(__parallel)
24452 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24453 rb, count, mpi_double_complex, comm%handle, ierr)
24454 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24455 CALL mpi_comm_size(comm%handle, np, ierr)
24456 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24457 msglen = 2*count*np
24458 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24459#else
24460 mark_used(count)
24461 mark_used(comm)
24462 rb = sb
24463#endif
24464 CALL mp_timestop(handle)
24465
24466 END SUBROUTINE mp_alltoall_z
24467
24468! **************************************************************************************************
24469!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
24470!> \param sb ...
24471!> \param rb ...
24472!> \param count ...
24473!> \param commp ...
24474!> \note see mp_alltoall_z
24475! **************************************************************************************************
24476 SUBROUTINE mp_alltoall_z22(sb, rb, count, comm)
24477
24478 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
24479 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
24480 INTEGER, INTENT(IN) :: count
24481 CLASS(mp_comm_type), INTENT(IN) :: comm
24482
24483 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z22'
24484
24485 INTEGER :: handle
24486#if defined(__parallel)
24487 INTEGER :: ierr, msglen, np
24488#endif
24489
24490 CALL mp_timeset(routinen, handle)
24491
24492#if defined(__parallel)
24493 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24494 rb, count, mpi_double_complex, comm%handle, ierr)
24495 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24496 CALL mpi_comm_size(comm%handle, np, ierr)
24497 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24498 msglen = 2*SIZE(sb)*np
24499 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24500#else
24501 mark_used(count)
24502 mark_used(comm)
24503 rb = sb
24504#endif
24505 CALL mp_timestop(handle)
24506
24507 END SUBROUTINE mp_alltoall_z22
24508
24509! **************************************************************************************************
24510!> \brief All-to-all data exchange, rank-3 data with equal sizes
24511!> \param sb ...
24512!> \param rb ...
24513!> \param count ...
24514!> \param comm ...
24515!> \note see mp_alltoall_z
24516! **************************************************************************************************
24517 SUBROUTINE mp_alltoall_z33(sb, rb, count, comm)
24518
24519 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
24520 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
24521 INTEGER, INTENT(IN) :: count
24522 CLASS(mp_comm_type), INTENT(IN) :: comm
24523
24524 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z33'
24525
24526 INTEGER :: handle
24527#if defined(__parallel)
24528 INTEGER :: ierr, msglen, np
24529#endif
24530
24531 CALL mp_timeset(routinen, handle)
24532
24533#if defined(__parallel)
24534 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24535 rb, count, mpi_double_complex, comm%handle, ierr)
24536 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24537 CALL mpi_comm_size(comm%handle, np, ierr)
24538 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24539 msglen = 2*count*np
24540 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24541#else
24542 mark_used(count)
24543 mark_used(comm)
24544 rb = sb
24545#endif
24546 CALL mp_timestop(handle)
24547
24548 END SUBROUTINE mp_alltoall_z33
24549
24550! **************************************************************************************************
24551!> \brief All-to-all data exchange, rank 4 data, equal sizes
24552!> \param sb ...
24553!> \param rb ...
24554!> \param count ...
24555!> \param comm ...
24556!> \note see mp_alltoall_z
24557! **************************************************************************************************
24558 SUBROUTINE mp_alltoall_z44(sb, rb, count, comm)
24559
24560 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24561 INTENT(IN) :: sb
24562 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24563 INTENT(OUT) :: rb
24564 INTEGER, INTENT(IN) :: count
24565 CLASS(mp_comm_type), INTENT(IN) :: comm
24566
24567 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z44'
24568
24569 INTEGER :: handle
24570#if defined(__parallel)
24571 INTEGER :: ierr, msglen, np
24572#endif
24573
24574 CALL mp_timeset(routinen, handle)
24575
24576#if defined(__parallel)
24577 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24578 rb, count, mpi_double_complex, comm%handle, ierr)
24579 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24580 CALL mpi_comm_size(comm%handle, np, ierr)
24581 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24582 msglen = 2*count*np
24583 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24584#else
24585 mark_used(count)
24586 mark_used(comm)
24587 rb = sb
24588#endif
24589 CALL mp_timestop(handle)
24590
24591 END SUBROUTINE mp_alltoall_z44
24592
24593! **************************************************************************************************
24594!> \brief All-to-all data exchange, rank 5 data, equal sizes
24595!> \param sb ...
24596!> \param rb ...
24597!> \param count ...
24598!> \param comm ...
24599!> \note see mp_alltoall_z
24600! **************************************************************************************************
24601 SUBROUTINE mp_alltoall_z55(sb, rb, count, comm)
24602
24603 COMPLEX(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
24604 INTENT(IN) :: sb
24605 COMPLEX(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
24606 INTENT(OUT) :: rb
24607 INTEGER, INTENT(IN) :: count
24608 CLASS(mp_comm_type), INTENT(IN) :: comm
24609
24610 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z55'
24611
24612 INTEGER :: handle
24613#if defined(__parallel)
24614 INTEGER :: ierr, msglen, np
24615#endif
24616
24617 CALL mp_timeset(routinen, handle)
24618
24619#if defined(__parallel)
24620 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24621 rb, count, mpi_double_complex, comm%handle, ierr)
24622 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24623 CALL mpi_comm_size(comm%handle, np, ierr)
24624 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24625 msglen = 2*count*np
24626 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24627#else
24628 mark_used(count)
24629 mark_used(comm)
24630 rb = sb
24631#endif
24632 CALL mp_timestop(handle)
24633
24634 END SUBROUTINE mp_alltoall_z55
24635
24636! **************************************************************************************************
24637!> \brief All-to-all data exchange, rank-4 data to rank-5 data
24638!> \param sb ...
24639!> \param rb ...
24640!> \param count ...
24641!> \param comm ...
24642!> \note see mp_alltoall_z
24643!> \note User must ensure size consistency.
24644! **************************************************************************************************
24645 SUBROUTINE mp_alltoall_z45(sb, rb, count, comm)
24646
24647 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24648 INTENT(IN) :: sb
24649 COMPLEX(kind=real_8), &
24650 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
24651 INTEGER, INTENT(IN) :: count
24652 CLASS(mp_comm_type), INTENT(IN) :: comm
24653
24654 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z45'
24655
24656 INTEGER :: handle
24657#if defined(__parallel)
24658 INTEGER :: ierr, msglen, np
24659#endif
24660
24661 CALL mp_timeset(routinen, handle)
24662
24663#if defined(__parallel)
24664 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24665 rb, count, mpi_double_complex, comm%handle, ierr)
24666 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24667 CALL mpi_comm_size(comm%handle, np, ierr)
24668 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24669 msglen = 2*count*np
24670 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24671#else
24672 mark_used(count)
24673 mark_used(comm)
24674 rb = reshape(sb, shape(rb))
24675#endif
24676 CALL mp_timestop(handle)
24677
24678 END SUBROUTINE mp_alltoall_z45
24679
24680! **************************************************************************************************
24681!> \brief All-to-all data exchange, rank-3 data to rank-4 data
24682!> \param sb ...
24683!> \param rb ...
24684!> \param count ...
24685!> \param comm ...
24686!> \note see mp_alltoall_z
24687!> \note User must ensure size consistency.
24688! **************************************************************************************************
24689 SUBROUTINE mp_alltoall_z34(sb, rb, count, comm)
24690
24691 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, &
24692 INTENT(IN) :: sb
24693 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24694 INTENT(OUT) :: rb
24695 INTEGER, INTENT(IN) :: count
24696 CLASS(mp_comm_type), INTENT(IN) :: comm
24697
24698 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z34'
24699
24700 INTEGER :: handle
24701#if defined(__parallel)
24702 INTEGER :: ierr, msglen, np
24703#endif
24704
24705 CALL mp_timeset(routinen, handle)
24706
24707#if defined(__parallel)
24708 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24709 rb, count, mpi_double_complex, comm%handle, ierr)
24710 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24711 CALL mpi_comm_size(comm%handle, np, ierr)
24712 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24713 msglen = 2*count*np
24714 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24715#else
24716 mark_used(count)
24717 mark_used(comm)
24718 rb = reshape(sb, shape(rb))
24719#endif
24720 CALL mp_timestop(handle)
24721
24722 END SUBROUTINE mp_alltoall_z34
24723
24724! **************************************************************************************************
24725!> \brief All-to-all data exchange, rank-5 data to rank-4 data
24726!> \param sb ...
24727!> \param rb ...
24728!> \param count ...
24729!> \param comm ...
24730!> \note see mp_alltoall_z
24731!> \note User must ensure size consistency.
24732! **************************************************************************************************
24733 SUBROUTINE mp_alltoall_z54(sb, rb, count, comm)
24734
24735 COMPLEX(kind=real_8), &
24736 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
24737 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24738 INTENT(OUT) :: rb
24739 INTEGER, INTENT(IN) :: count
24740 CLASS(mp_comm_type), INTENT(IN) :: comm
24741
24742 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z54'
24743
24744 INTEGER :: handle
24745#if defined(__parallel)
24746 INTEGER :: ierr, msglen, np
24747#endif
24748
24749 CALL mp_timeset(routinen, handle)
24750
24751#if defined(__parallel)
24752 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24753 rb, count, mpi_double_complex, comm%handle, ierr)
24754 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24755 CALL mpi_comm_size(comm%handle, np, ierr)
24756 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24757 msglen = 2*count*np
24758 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24759#else
24760 mark_used(count)
24761 mark_used(comm)
24762 rb = reshape(sb, shape(rb))
24763#endif
24764 CALL mp_timestop(handle)
24765
24766 END SUBROUTINE mp_alltoall_z54
24767
24768! **************************************************************************************************
24769!> \brief Send one datum to another process
24770!> \param[in] msg Scalar to send
24771!> \param[in] dest Destination process
24772!> \param[in] tag Transfer identifier
24773!> \param[in] comm Message passing environment identifier
24774!> \par MPI mapping
24775!> mpi_send
24776! **************************************************************************************************
24777 SUBROUTINE mp_send_z (msg, dest, tag, comm)
24778 COMPLEX(kind=real_8), INTENT(IN) :: msg
24779 INTEGER, INTENT(IN) :: dest, tag
24780 CLASS(mp_comm_type), INTENT(IN) :: comm
24781
24782 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_z'
24783
24784 INTEGER :: handle
24785#if defined(__parallel)
24786 INTEGER :: ierr, msglen
24787#endif
24788
24789 CALL mp_timeset(routinen, handle)
24790
24791#if defined(__parallel)
24792 msglen = 1
24793 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24794 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24795 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24796#else
24797 mark_used(msg)
24798 mark_used(dest)
24799 mark_used(tag)
24800 mark_used(comm)
24801 ! only defined in parallel
24802 cpabort("not in parallel mode")
24803#endif
24804 CALL mp_timestop(handle)
24805 END SUBROUTINE mp_send_z
24806
24807! **************************************************************************************************
24808!> \brief Send rank-1 data to another process
24809!> \param[in] msg Rank-1 data to send
24810!> \param dest ...
24811!> \param tag ...
24812!> \param comm ...
24813!> \note see mp_send_z
24814! **************************************************************************************************
24815 SUBROUTINE mp_send_zv(msg, dest, tag, comm)
24816 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
24817 INTEGER, INTENT(IN) :: dest, tag
24818 CLASS(mp_comm_type), INTENT(IN) :: comm
24819
24820 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_zv'
24821
24822 INTEGER :: handle
24823#if defined(__parallel)
24824 INTEGER :: ierr, msglen
24825#endif
24826
24827 CALL mp_timeset(routinen, handle)
24828
24829#if defined(__parallel)
24830 msglen = SIZE(msg)
24831 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24832 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24833 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24834#else
24835 mark_used(msg)
24836 mark_used(dest)
24837 mark_used(tag)
24838 mark_used(comm)
24839 ! only defined in parallel
24840 cpabort("not in parallel mode")
24841#endif
24842 CALL mp_timestop(handle)
24843 END SUBROUTINE mp_send_zv
24844
24845! **************************************************************************************************
24846!> \brief Send rank-2 data to another process
24847!> \param[in] msg Rank-2 data to send
24848!> \param dest ...
24849!> \param tag ...
24850!> \param comm ...
24851!> \note see mp_send_z
24852! **************************************************************************************************
24853 SUBROUTINE mp_send_zm2(msg, dest, tag, comm)
24854 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
24855 INTEGER, INTENT(IN) :: dest, tag
24856 CLASS(mp_comm_type), INTENT(IN) :: comm
24857
24858 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_zm2'
24859
24860 INTEGER :: handle
24861#if defined(__parallel)
24862 INTEGER :: ierr, msglen
24863#endif
24864
24865 CALL mp_timeset(routinen, handle)
24866
24867#if defined(__parallel)
24868 msglen = SIZE(msg)
24869 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24870 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24871 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24872#else
24873 mark_used(msg)
24874 mark_used(dest)
24875 mark_used(tag)
24876 mark_used(comm)
24877 ! only defined in parallel
24878 cpabort("not in parallel mode")
24879#endif
24880 CALL mp_timestop(handle)
24881 END SUBROUTINE mp_send_zm2
24882
24883! **************************************************************************************************
24884!> \brief Send rank-3 data to another process
24885!> \param[in] msg Rank-3 data to send
24886!> \param dest ...
24887!> \param tag ...
24888!> \param comm ...
24889!> \note see mp_send_z
24890! **************************************************************************************************
24891 SUBROUTINE mp_send_zm3(msg, dest, tag, comm)
24892 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
24893 INTEGER, INTENT(IN) :: dest, tag
24894 CLASS(mp_comm_type), INTENT(IN) :: comm
24895
24896 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
24897
24898 INTEGER :: handle
24899#if defined(__parallel)
24900 INTEGER :: ierr, msglen
24901#endif
24902
24903 CALL mp_timeset(routinen, handle)
24904
24905#if defined(__parallel)
24906 msglen = SIZE(msg)
24907 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24908 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24909 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24910#else
24911 mark_used(msg)
24912 mark_used(dest)
24913 mark_used(tag)
24914 mark_used(comm)
24915 ! only defined in parallel
24916 cpabort("not in parallel mode")
24917#endif
24918 CALL mp_timestop(handle)
24919 END SUBROUTINE mp_send_zm3
24920
24921! **************************************************************************************************
24922!> \brief Receive one datum from another process
24923!> \param[in,out] msg Place received data into this variable
24924!> \param[in,out] source Process to receive from
24925!> \param[in,out] tag Transfer identifier
24926!> \param[in] comm Message passing environment identifier
24927!> \par MPI mapping
24928!> mpi_send
24929! **************************************************************************************************
24930 SUBROUTINE mp_recv_z (msg, source, tag, comm)
24931 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24932 INTEGER, INTENT(INOUT) :: source, tag
24933 CLASS(mp_comm_type), INTENT(IN) :: comm
24934
24935 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_z'
24936
24937 INTEGER :: handle
24938#if defined(__parallel)
24939 INTEGER :: ierr, msglen
24940 mpi_status_type :: status
24941#endif
24942
24943 CALL mp_timeset(routinen, handle)
24944
24945#if defined(__parallel)
24946 msglen = 1
24947 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24948 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24949 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24950 ELSE
24951 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24952 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24953 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24954 source = status mpi_status_extract(mpi_source)
24955 tag = status mpi_status_extract(mpi_tag)
24956 END IF
24957#else
24958 mark_used(msg)
24959 mark_used(source)
24960 mark_used(tag)
24961 mark_used(comm)
24962 ! only defined in parallel
24963 cpabort("not in parallel mode")
24964#endif
24965 CALL mp_timestop(handle)
24966 END SUBROUTINE mp_recv_z
24967
24968! **************************************************************************************************
24969!> \brief Receive rank-1 data from another process
24970!> \param[in,out] msg Place received data into this rank-1 array
24971!> \param source ...
24972!> \param tag ...
24973!> \param comm ...
24974!> \note see mp_recv_z
24975! **************************************************************************************************
24976 SUBROUTINE mp_recv_zv(msg, source, tag, comm)
24977 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24978 INTEGER, INTENT(INOUT) :: source, tag
24979 CLASS(mp_comm_type), INTENT(IN) :: comm
24980
24981 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zv'
24982
24983 INTEGER :: handle
24984#if defined(__parallel)
24985 INTEGER :: ierr, msglen
24986 mpi_status_type :: status
24987#endif
24988
24989 CALL mp_timeset(routinen, handle)
24990
24991#if defined(__parallel)
24992 msglen = SIZE(msg)
24993 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24994 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24995 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24996 ELSE
24997 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24998 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24999 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
25000 source = status mpi_status_extract(mpi_source)
25001 tag = status mpi_status_extract(mpi_tag)
25002 END IF
25003#else
25004 mark_used(msg)
25005 mark_used(source)
25006 mark_used(tag)
25007 mark_used(comm)
25008 ! only defined in parallel
25009 cpabort("not in parallel mode")
25010#endif
25011 CALL mp_timestop(handle)
25012 END SUBROUTINE mp_recv_zv
25013
25014! **************************************************************************************************
25015!> \brief Receive rank-2 data from another process
25016!> \param[in,out] msg Place received data into this rank-2 array
25017!> \param source ...
25018!> \param tag ...
25019!> \param comm ...
25020!> \note see mp_recv_z
25021! **************************************************************************************************
25022 SUBROUTINE mp_recv_zm2(msg, source, tag, comm)
25023 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25024 INTEGER, INTENT(INOUT) :: source, tag
25025 CLASS(mp_comm_type), INTENT(IN) :: comm
25026
25027 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zm2'
25028
25029 INTEGER :: handle
25030#if defined(__parallel)
25031 INTEGER :: ierr, msglen
25032 mpi_status_type :: status
25033#endif
25034
25035 CALL mp_timeset(routinen, handle)
25036
25037#if defined(__parallel)
25038 msglen = SIZE(msg)
25039 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
25040 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
25041 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
25042 ELSE
25043 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
25044 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
25045 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
25046 source = status mpi_status_extract(mpi_source)
25047 tag = status mpi_status_extract(mpi_tag)
25048 END IF
25049#else
25050 mark_used(msg)
25051 mark_used(source)
25052 mark_used(tag)
25053 mark_used(comm)
25054 ! only defined in parallel
25055 cpabort("not in parallel mode")
25056#endif
25057 CALL mp_timestop(handle)
25058 END SUBROUTINE mp_recv_zm2
25059
25060! **************************************************************************************************
25061!> \brief Receive rank-3 data from another process
25062!> \param[in,out] msg Place received data into this rank-3 array
25063!> \param source ...
25064!> \param tag ...
25065!> \param comm ...
25066!> \note see mp_recv_z
25067! **************************************************************************************************
25068 SUBROUTINE mp_recv_zm3(msg, source, tag, comm)
25069 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
25070 INTEGER, INTENT(INOUT) :: source, tag
25071 CLASS(mp_comm_type), INTENT(IN) :: comm
25072
25073 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zm3'
25074
25075 INTEGER :: handle
25076#if defined(__parallel)
25077 INTEGER :: ierr, msglen
25078 mpi_status_type :: status
25079#endif
25080
25081 CALL mp_timeset(routinen, handle)
25082
25083#if defined(__parallel)
25084 msglen = SIZE(msg)
25085 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
25086 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
25087 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
25088 ELSE
25089 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
25090 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
25091 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
25092 source = status mpi_status_extract(mpi_source)
25093 tag = status mpi_status_extract(mpi_tag)
25094 END IF
25095#else
25096 mark_used(msg)
25097 mark_used(source)
25098 mark_used(tag)
25099 mark_used(comm)
25100 ! only defined in parallel
25101 cpabort("not in parallel mode")
25102#endif
25103 CALL mp_timestop(handle)
25104 END SUBROUTINE mp_recv_zm3
25105
25106! **************************************************************************************************
25107!> \brief Broadcasts a datum to all processes.
25108!> \param[in] msg Datum to broadcast
25109!> \param[in] source Processes which broadcasts
25110!> \param[in] comm Message passing environment identifier
25111!> \par MPI mapping
25112!> mpi_bcast
25113! **************************************************************************************************
25114 SUBROUTINE mp_bcast_z (msg, source, comm)
25115 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25116 INTEGER, INTENT(IN) :: source
25117 CLASS(mp_comm_type), INTENT(IN) :: comm
25118
25119 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z'
25120
25121 INTEGER :: handle
25122#if defined(__parallel)
25123 INTEGER :: ierr, msglen
25124#endif
25125
25126 CALL mp_timeset(routinen, handle)
25127
25128#if defined(__parallel)
25129 msglen = 1
25130 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
25131 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25132 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25133#else
25134 mark_used(msg)
25135 mark_used(source)
25136 mark_used(comm)
25137#endif
25138 CALL mp_timestop(handle)
25139 END SUBROUTINE mp_bcast_z
25140
25141! **************************************************************************************************
25142!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
25143!> \param[in] msg Datum to broadcast
25144!> \param[in] comm Message passing environment identifier
25145!> \par MPI mapping
25146!> mpi_bcast
25147! **************************************************************************************************
25148 SUBROUTINE mp_bcast_z_src(msg, comm)
25149 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25150 CLASS(mp_comm_type), INTENT(IN) :: comm
25151
25152 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z_src'
25153
25154 INTEGER :: handle
25155#if defined(__parallel)
25156 INTEGER :: ierr, msglen
25157#endif
25158
25159 CALL mp_timeset(routinen, handle)
25160
25161#if defined(__parallel)
25162 msglen = 1
25163 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25164 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25165 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25166#else
25167 mark_used(msg)
25168 mark_used(comm)
25169#endif
25170 CALL mp_timestop(handle)
25171 END SUBROUTINE mp_bcast_z_src
25172
25173! **************************************************************************************************
25174!> \brief Broadcasts a datum to all processes.
25175!> \param[in] msg Datum to broadcast
25176!> \param[in] source Processes which broadcasts
25177!> \param[in] comm Message passing environment identifier
25178!> \par MPI mapping
25179!> mpi_bcast
25180! **************************************************************************************************
25181 SUBROUTINE mp_ibcast_z (msg, source, comm, request)
25182 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25183 INTEGER, INTENT(IN) :: source
25184 CLASS(mp_comm_type), INTENT(IN) :: comm
25185 TYPE(mp_request_type), INTENT(OUT) :: request
25186
25187 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_z'
25188
25189 INTEGER :: handle
25190#if defined(__parallel)
25191 INTEGER :: ierr, msglen
25192#endif
25193
25194 CALL mp_timeset(routinen, handle)
25195
25196#if defined(__parallel)
25197 msglen = 1
25198 CALL mpi_ibcast(msg, msglen, mpi_double_complex, source, comm%handle, request%handle, ierr)
25199 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
25200 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_8_size))
25201#else
25202 mark_used(msg)
25203 mark_used(source)
25204 mark_used(comm)
25205 request = mp_request_null
25206#endif
25207 CALL mp_timestop(handle)
25208 END SUBROUTINE mp_ibcast_z
25209
25210! **************************************************************************************************
25211!> \brief Broadcasts rank-1 data to all processes
25212!> \param[in] msg Data to broadcast
25213!> \param source ...
25214!> \param comm ...
25215!> \note see mp_bcast_z1
25216! **************************************************************************************************
25217 SUBROUTINE mp_bcast_zv(msg, source, comm)
25218 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25219 INTEGER, INTENT(IN) :: source
25220 CLASS(mp_comm_type), INTENT(IN) :: comm
25221
25222 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zv'
25223
25224 INTEGER :: handle
25225#if defined(__parallel)
25226 INTEGER :: ierr, msglen
25227#endif
25228
25229 CALL mp_timeset(routinen, handle)
25230
25231#if defined(__parallel)
25232 msglen = SIZE(msg)
25233 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
25234 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25235 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25236#else
25237 mark_used(msg)
25238 mark_used(source)
25239 mark_used(comm)
25240#endif
25241 CALL mp_timestop(handle)
25242 END SUBROUTINE mp_bcast_zv
25243
25244! **************************************************************************************************
25245!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
25246!> \param[in] msg Data to broadcast
25247!> \param comm ...
25248!> \note see mp_bcast_z1
25249! **************************************************************************************************
25250 SUBROUTINE mp_bcast_zv_src(msg, comm)
25251 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25252 CLASS(mp_comm_type), INTENT(IN) :: comm
25253
25254 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zv_src'
25255
25256 INTEGER :: handle
25257#if defined(__parallel)
25258 INTEGER :: ierr, msglen
25259#endif
25260
25261 CALL mp_timeset(routinen, handle)
25262
25263#if defined(__parallel)
25264 msglen = SIZE(msg)
25265 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25266 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25267 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25268#else
25269 mark_used(msg)
25270 mark_used(comm)
25271#endif
25272 CALL mp_timestop(handle)
25273 END SUBROUTINE mp_bcast_zv_src
25274
25275! **************************************************************************************************
25276!> \brief Broadcasts rank-1 data to all processes
25277!> \param[in] msg Data to broadcast
25278!> \param source ...
25279!> \param comm ...
25280!> \note see mp_bcast_z1
25281! **************************************************************************************************
25282 SUBROUTINE mp_ibcast_zv(msg, source, comm, request)
25283 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25284 INTEGER, INTENT(IN) :: source
25285 CLASS(mp_comm_type), INTENT(IN) :: comm
25286 TYPE(mp_request_type) :: request
25287
25288 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_zv'
25289
25290 INTEGER :: handle
25291#if defined(__parallel)
25292 INTEGER :: ierr, msglen
25293#endif
25294
25295 CALL mp_timeset(routinen, handle)
25296
25297#if defined(__parallel)
25298#if !defined(__GNUC__) || __GNUC__ >= 9
25299 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
25300#endif
25301 msglen = SIZE(msg)
25302 CALL mpi_ibcast(msg, msglen, mpi_double_complex, source, comm%handle, request%handle, ierr)
25303 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
25304 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_8_size))
25305#else
25306 mark_used(msg)
25307 mark_used(source)
25308 mark_used(comm)
25309 request = mp_request_null
25310#endif
25311 CALL mp_timestop(handle)
25312 END SUBROUTINE mp_ibcast_zv
25313
25314! **************************************************************************************************
25315!> \brief Broadcasts rank-2 data to all processes
25316!> \param[in] msg Data to broadcast
25317!> \param source ...
25318!> \param comm ...
25319!> \note see mp_bcast_z1
25320! **************************************************************************************************
25321 SUBROUTINE mp_bcast_zm(msg, source, comm)
25322 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25323 INTEGER, INTENT(IN) :: source
25324 CLASS(mp_comm_type), INTENT(IN) :: comm
25325
25326 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zm'
25327
25328 INTEGER :: handle
25329#if defined(__parallel)
25330 INTEGER :: ierr, msglen
25331#endif
25332
25333 CALL mp_timeset(routinen, handle)
25334
25335#if defined(__parallel)
25336 msglen = SIZE(msg)
25337 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
25338 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25339 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25340#else
25341 mark_used(msg)
25342 mark_used(source)
25343 mark_used(comm)
25344#endif
25345 CALL mp_timestop(handle)
25346 END SUBROUTINE mp_bcast_zm
25347
25348! **************************************************************************************************
25349!> \brief Broadcasts rank-2 data to all processes
25350!> \param[in] msg Data to broadcast
25351!> \param source ...
25352!> \param comm ...
25353!> \note see mp_bcast_z1
25354! **************************************************************************************************
25355 SUBROUTINE mp_bcast_zm_src(msg, comm)
25356 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25357 CLASS(mp_comm_type), INTENT(IN) :: comm
25358
25359 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zm_src'
25360
25361 INTEGER :: handle
25362#if defined(__parallel)
25363 INTEGER :: ierr, msglen
25364#endif
25365
25366 CALL mp_timeset(routinen, handle)
25367
25368#if defined(__parallel)
25369 msglen = SIZE(msg)
25370 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25371 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25372 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25373#else
25374 mark_used(msg)
25375 mark_used(comm)
25376#endif
25377 CALL mp_timestop(handle)
25378 END SUBROUTINE mp_bcast_zm_src
25379
25380! **************************************************************************************************
25381!> \brief Broadcasts rank-3 data to all processes
25382!> \param[in] msg Data to broadcast
25383!> \param source ...
25384!> \param comm ...
25385!> \note see mp_bcast_z1
25386! **************************************************************************************************
25387 SUBROUTINE mp_bcast_z3(msg, source, comm)
25388 COMPLEX(kind=real_8), CONTIGUOUS :: msg(:, :, :)
25389 INTEGER, INTENT(IN) :: source
25390 CLASS(mp_comm_type), INTENT(IN) :: comm
25391
25392 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z3'
25393
25394 INTEGER :: handle
25395#if defined(__parallel)
25396 INTEGER :: ierr, msglen
25397#endif
25398
25399 CALL mp_timeset(routinen, handle)
25400
25401#if defined(__parallel)
25402 msglen = SIZE(msg)
25403 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
25404 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25405 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25406#else
25407 mark_used(msg)
25408 mark_used(source)
25409 mark_used(comm)
25410#endif
25411 CALL mp_timestop(handle)
25412 END SUBROUTINE mp_bcast_z3
25413
25414! **************************************************************************************************
25415!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
25416!> \param[in] msg Data to broadcast
25417!> \param source ...
25418!> \param comm ...
25419!> \note see mp_bcast_z1
25420! **************************************************************************************************
25421 SUBROUTINE mp_bcast_z3_src(msg, comm)
25422 COMPLEX(kind=real_8), CONTIGUOUS :: msg(:, :, :)
25423 CLASS(mp_comm_type), INTENT(IN) :: comm
25424
25425 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z3_src'
25426
25427 INTEGER :: handle
25428#if defined(__parallel)
25429 INTEGER :: ierr, msglen
25430#endif
25431
25432 CALL mp_timeset(routinen, handle)
25433
25434#if defined(__parallel)
25435 msglen = SIZE(msg)
25436 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25437 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25438 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25439#else
25440 mark_used(msg)
25441 mark_used(comm)
25442#endif
25443 CALL mp_timestop(handle)
25444 END SUBROUTINE mp_bcast_z3_src
25445
25446! **************************************************************************************************
25447!> \brief Sums a datum from all processes with result left on all processes.
25448!> \param[in,out] msg Datum to sum (input) and result (output)
25449!> \param[in] comm Message passing environment identifier
25450!> \par MPI mapping
25451!> mpi_allreduce
25452! **************************************************************************************************
25453 SUBROUTINE mp_sum_z (msg, comm)
25454 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25455 CLASS(mp_comm_type), INTENT(IN) :: comm
25456
25457 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_z'
25458
25459 INTEGER :: handle
25460#if defined(__parallel)
25461 INTEGER :: ierr, msglen
25462 COMPLEX(kind=real_8) :: res
25463#endif
25464
25465 CALL mp_timeset(routinen, handle)
25466
25467#if defined(__parallel)
25468 msglen = 1
25469 IF (comm%num_pe > 1) THEN
25470 CALL mpi_allreduce(msg, res, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25471 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25472 msg = res
25473 END IF
25474 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25475#else
25476 mark_used(msg)
25477 mark_used(comm)
25478#endif
25479 CALL mp_timestop(handle)
25480 END SUBROUTINE mp_sum_z
25481
25482! **************************************************************************************************
25483!> \brief Element-wise sum of a rank-1 array on all processes.
25484!> \param[in,out] msg Vector to sum and result
25485!> \param comm ...
25486!> \note see mp_sum_z
25487! **************************************************************************************************
25488 SUBROUTINE mp_sum_zv(msg, comm)
25489 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25490 CLASS(mp_comm_type), INTENT(IN) :: comm
25491
25492 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zv'
25493
25494 INTEGER :: handle
25495#if defined(__parallel)
25496 INTEGER :: ierr, msglen
25497 COMPLEX(kind=real_8), ALLOCATABLE :: msgbuf(:)
25498#endif
25499
25500 CALL mp_timeset(routinen, handle)
25501
25502#if defined(__parallel)
25503 msglen = SIZE(msg)
25504 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
25505 ALLOCATE (msgbuf(msglen))
25506 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25507 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25508 msg = msgbuf
25509 END IF
25510 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25511#else
25512 mark_used(msg)
25513 mark_used(comm)
25514#endif
25515 CALL mp_timestop(handle)
25516 END SUBROUTINE mp_sum_zv
25517
25518! **************************************************************************************************
25519!> \brief Element-wise sum of a rank-1 array on all processes.
25520!> \param[in,out] msg Vector to sum and result
25521!> \param comm ...
25522!> \note see mp_sum_z
25523! **************************************************************************************************
25524 SUBROUTINE mp_isum_zv(msg, comm, request)
25525 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25526 CLASS(mp_comm_type), INTENT(IN) :: comm
25527 TYPE(mp_request_type), INTENT(OUT) :: request
25528
25529 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_zv'
25530
25531 INTEGER :: handle
25532#if defined(__parallel)
25533 INTEGER :: ierr, msglen
25534#endif
25535
25536 CALL mp_timeset(routinen, handle)
25537
25538#if defined(__parallel)
25539#if !defined(__GNUC__) || __GNUC__ >= 9
25540 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
25541#endif
25542 msglen = SIZE(msg)
25543 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
25544 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, request%handle, ierr)
25545 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
25546 ELSE
25547 request = mp_request_null
25548 END IF
25549 CALL add_perf(perf_id=23, count=1, msg_size=msglen*(2*real_8_size))
25550#else
25551 mark_used(msg)
25552 mark_used(comm)
25553 request = mp_request_null
25554#endif
25555 CALL mp_timestop(handle)
25556 END SUBROUTINE mp_isum_zv
25557
25558! **************************************************************************************************
25559!> \brief Element-wise sum of a rank-2 array on all processes.
25560!> \param[in] msg Matrix to sum and result
25561!> \param comm ...
25562!> \note see mp_sum_z
25563! **************************************************************************************************
25564 SUBROUTINE mp_sum_zm(msg, comm)
25565 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25566 CLASS(mp_comm_type), INTENT(IN) :: comm
25567
25568 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm'
25569
25570 INTEGER :: handle
25571#if defined(__parallel)
25572 INTEGER, PARAMETER :: max_msg = 2**25
25573 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
25574 COMPLEX(kind=real_8), ALLOCATABLE :: msgbuf(:)
25575#endif
25576
25577 CALL mp_timeset(routinen, handle)
25578
25579#if defined(__parallel)
25580 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
25581 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
25582 msglensum = 0
25583 DO m1 = lbound(msg, 2), ubound(msg, 2), step
25584 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
25585 msglensum = msglensum + msglen
25586 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
25587 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
25588 ALLOCATE (msgbuf(msglen))
25589 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25590 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25591 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
25592 DEALLOCATE (msgbuf)
25593 END IF
25594 END DO
25595 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_8_size))
25596#else
25597 mark_used(msg)
25598 mark_used(comm)
25599#endif
25600 CALL mp_timestop(handle)
25601 END SUBROUTINE mp_sum_zm
25602
25603! **************************************************************************************************
25604!> \brief Element-wise sum of a rank-3 array on all processes.
25605!> \param[in] msg Array to sum and result
25606!> \param comm ...
25607!> \note see mp_sum_z
25608! **************************************************************************************************
25609 SUBROUTINE mp_sum_zm3(msg, comm)
25610 COMPLEX(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
25611 CLASS(mp_comm_type), INTENT(IN) :: comm
25612
25613 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm3'
25614
25615 INTEGER :: handle
25616#if defined(__parallel)
25617 INTEGER :: ierr, msglen
25618 COMPLEX(kind=real_8), ALLOCATABLE :: msgbuf(:)
25619#endif
25620
25621 CALL mp_timeset(routinen, handle)
25622
25623#if defined(__parallel)
25624 msglen = SIZE(msg)
25625 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
25626 ALLOCATE (msgbuf(msglen))
25627 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25628 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25629 msg = reshape(msgbuf, shape(msg))
25630 END IF
25631 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25632#else
25633 mark_used(msg)
25634 mark_used(comm)
25635#endif
25636 CALL mp_timestop(handle)
25637 END SUBROUTINE mp_sum_zm3
25638
25639! **************************************************************************************************
25640!> \brief Element-wise sum of a rank-4 array on all processes.
25641!> \param[in] msg Array to sum and result
25642!> \param comm ...
25643!> \note see mp_sum_z
25644! **************************************************************************************************
25645 SUBROUTINE mp_sum_zm4(msg, comm)
25646 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
25647 CLASS(mp_comm_type), INTENT(IN) :: comm
25648
25649 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm4'
25650
25651 INTEGER :: handle
25652#if defined(__parallel)
25653 INTEGER :: ierr, msglen
25654 COMPLEX(kind=real_8), ALLOCATABLE :: msgbuf(:)
25655#endif
25656
25657 CALL mp_timeset(routinen, handle)
25658
25659#if defined(__parallel)
25660 msglen = SIZE(msg)
25661 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
25662 ALLOCATE (msgbuf(msglen))
25663 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25664 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25665 msg = reshape(msgbuf, shape(msg))
25666 END IF
25667 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25668#else
25669 mark_used(msg)
25670 mark_used(comm)
25671#endif
25672 CALL mp_timestop(handle)
25673 END SUBROUTINE mp_sum_zm4
25674
25675! **************************************************************************************************
25676!> \brief Element-wise sum of data from all processes with result left only on
25677!> one.
25678!> \param[in,out] msg Vector to sum (input) and (only on process root)
25679!> result (output)
25680!> \param root ...
25681!> \param[in] comm Message passing environment identifier
25682!> \par MPI mapping
25683!> mpi_reduce
25684! **************************************************************************************************
25685 SUBROUTINE mp_sum_root_zv(msg, root, comm)
25686 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25687 INTEGER, INTENT(IN) :: root
25688 CLASS(mp_comm_type), INTENT(IN) :: comm
25689
25690 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_zv'
25691
25692 INTEGER :: handle
25693#if defined(__parallel)
25694 INTEGER :: ierr, m1, msglen, taskid
25695 COMPLEX(kind=real_8), ALLOCATABLE :: res(:)
25696#endif
25697
25698 CALL mp_timeset(routinen, handle)
25699
25700#if defined(__parallel)
25701 msglen = SIZE(msg)
25702 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25703 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25704 IF (msglen > 0) THEN
25705 m1 = SIZE(msg, 1)
25706 ALLOCATE (res(m1))
25707 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_sum, &
25708 root, comm%handle, ierr)
25709 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25710 IF (taskid == root) THEN
25711 msg = res
25712 END IF
25713 DEALLOCATE (res)
25714 END IF
25715 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25716#else
25717 mark_used(msg)
25718 mark_used(root)
25719 mark_used(comm)
25720#endif
25721 CALL mp_timestop(handle)
25722 END SUBROUTINE mp_sum_root_zv
25723
25724! **************************************************************************************************
25725!> \brief Element-wise sum of data from all processes with result left only on
25726!> one.
25727!> \param[in,out] msg Matrix to sum (input) and (only on process root)
25728!> result (output)
25729!> \param root ...
25730!> \param comm ...
25731!> \note see mp_sum_root_zv
25732! **************************************************************************************************
25733 SUBROUTINE mp_sum_root_zm(msg, root, comm)
25734 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25735 INTEGER, INTENT(IN) :: root
25736 CLASS(mp_comm_type), INTENT(IN) :: comm
25737
25738 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
25739
25740 INTEGER :: handle
25741#if defined(__parallel)
25742 INTEGER :: ierr, m1, m2, msglen, taskid
25743 COMPLEX(kind=real_8), ALLOCATABLE :: res(:, :)
25744#endif
25745
25746 CALL mp_timeset(routinen, handle)
25747
25748#if defined(__parallel)
25749 msglen = SIZE(msg)
25750 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25751 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25752 IF (msglen > 0) THEN
25753 m1 = SIZE(msg, 1)
25754 m2 = SIZE(msg, 2)
25755 ALLOCATE (res(m1, m2))
25756 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_sum, root, comm%handle, ierr)
25757 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25758 IF (taskid == root) THEN
25759 msg = res
25760 END IF
25761 DEALLOCATE (res)
25762 END IF
25763 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25764#else
25765 mark_used(root)
25766 mark_used(msg)
25767 mark_used(comm)
25768#endif
25769 CALL mp_timestop(handle)
25770 END SUBROUTINE mp_sum_root_zm
25771
25772! **************************************************************************************************
25773!> \brief Partial sum of data from all processes with result on each process.
25774!> \param[in] msg Matrix to sum (input)
25775!> \param[out] res Matrix containing result (output)
25776!> \param[in] comm Message passing environment identifier
25777! **************************************************************************************************
25778 SUBROUTINE mp_sum_partial_zm(msg, res, comm)
25779 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
25780 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
25781 CLASS(mp_comm_type), INTENT(IN) :: comm
25782
25783 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_zm'
25784
25785 INTEGER :: handle
25786#if defined(__parallel)
25787 INTEGER :: ierr, msglen, taskid
25788#endif
25789
25790 CALL mp_timeset(routinen, handle)
25791
25792#if defined(__parallel)
25793 msglen = SIZE(msg)
25794 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25795 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25796 IF (msglen > 0) THEN
25797 CALL mpi_scan(msg, res, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25798 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
25799 END IF
25800 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25801 ! perf_id is same as for other summation routines
25802#else
25803 res = msg
25804 mark_used(comm)
25805#endif
25806 CALL mp_timestop(handle)
25807 END SUBROUTINE mp_sum_partial_zm
25808
25809! **************************************************************************************************
25810!> \brief Finds the maximum of a datum with the result left on all processes.
25811!> \param[in,out] msg Find maximum among these data (input) and
25812!> maximum (output)
25813!> \param[in] comm Message passing environment identifier
25814!> \par MPI mapping
25815!> mpi_allreduce
25816! **************************************************************************************************
25817 SUBROUTINE mp_max_z (msg, comm)
25818 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25819 CLASS(mp_comm_type), INTENT(IN) :: comm
25820
25821 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_z'
25822
25823 INTEGER :: handle
25824#if defined(__parallel)
25825 INTEGER :: ierr, msglen
25826 COMPLEX(kind=real_8) :: res
25827#endif
25828
25829 CALL mp_timeset(routinen, handle)
25830
25831#if defined(__parallel)
25832 msglen = 1
25833 IF (comm%num_pe > 1) THEN
25834 CALL mpi_allreduce(msg, res, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25835 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25836 msg = res
25837 END IF
25838 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25839#else
25840 mark_used(msg)
25841 mark_used(comm)
25842#endif
25843 CALL mp_timestop(handle)
25844 END SUBROUTINE mp_max_z
25845
25846! **************************************************************************************************
25847!> \brief Finds the maximum of a datum with the result left on all processes.
25848!> \param[in,out] msg Find maximum among these data (input) and
25849!> maximum (output)
25850!> \param[in] comm Message passing environment identifier
25851!> \par MPI mapping
25852!> mpi_allreduce
25853! **************************************************************************************************
25854 SUBROUTINE mp_max_root_z (msg, root, comm)
25855 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25856 INTEGER, INTENT(IN) :: root
25857 CLASS(mp_comm_type), INTENT(IN) :: comm
25858
25859 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_z'
25860
25861 INTEGER :: handle
25862#if defined(__parallel)
25863 INTEGER :: ierr, msglen
25864 COMPLEX(kind=real_8) :: res
25865#endif
25866
25867 CALL mp_timeset(routinen, handle)
25868
25869#if defined(__parallel)
25870 msglen = 1
25871 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_max, root, comm%handle, ierr)
25872 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25873 IF (root == comm%mepos) msg = res
25874 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25875#else
25876 mark_used(msg)
25877 mark_used(comm)
25878 mark_used(root)
25879#endif
25880 CALL mp_timestop(handle)
25881 END SUBROUTINE mp_max_root_z
25882
25883! **************************************************************************************************
25884!> \brief Finds the element-wise maximum of a vector with the result left on
25885!> all processes.
25886!> \param[in,out] msg Find maximum among these data (input) and
25887!> maximum (output)
25888!> \param comm ...
25889!> \note see mp_max_z
25890! **************************************************************************************************
25891 SUBROUTINE mp_max_zv(msg, comm)
25892 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25893 CLASS(mp_comm_type), INTENT(IN) :: comm
25894
25895 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_zv'
25896
25897 INTEGER :: handle
25898#if defined(__parallel)
25899 INTEGER :: ierr, msglen
25900 COMPLEX(kind=real_8), ALLOCATABLE :: msgbuf(:)
25901#endif
25902
25903 CALL mp_timeset(routinen, handle)
25904
25905#if defined(__parallel)
25906 msglen = SIZE(msg)
25907 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
25908 ALLOCATE (msgbuf(msglen))
25909 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25910 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25911 msg = msgbuf
25912 END IF
25913 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25914#else
25915 mark_used(msg)
25916 mark_used(comm)
25917#endif
25918 CALL mp_timestop(handle)
25919 END SUBROUTINE mp_max_zv
25920
25921! **************************************************************************************************
25922!> \brief Finds the element-wise maximum of a rank2-array with the result left on
25923!> all processes.
25924!> \param[in] msg Matrix - Find maximum among these data (input) and
25925!> maximum (output)
25926!> \param comm ...
25927!> \note see mp_max_z
25928! **************************************************************************************************
25929 SUBROUTINE mp_max_zm(msg, comm)
25930 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25931 CLASS(mp_comm_type), INTENT(IN) :: comm
25932
25933 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_zm'
25934
25935 INTEGER :: handle
25936#if defined(__parallel)
25937 INTEGER, PARAMETER :: max_msg = 2**25
25938 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
25939 COMPLEX(kind=real_8), ALLOCATABLE :: msgbuf(:)
25940#endif
25941
25942 CALL mp_timeset(routinen, handle)
25943
25944#if defined(__parallel)
25945 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
25946 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
25947 msglensum = 0
25948 DO m1 = lbound(msg, 2), ubound(msg, 2), step
25949 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
25950 msglensum = msglensum + msglen
25951 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
25952 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
25953 ALLOCATE (msgbuf(msglen))
25954 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25955 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25956 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
25957 DEALLOCATE (msgbuf)
25958 END IF
25959 END DO
25960 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_8_size))
25961#else
25962 mark_used(msg)
25963 mark_used(comm)
25964#endif
25965 CALL mp_timestop(handle)
25966 END SUBROUTINE mp_max_zm
25967
25968! **************************************************************************************************
25969!> \brief Finds the element-wise maximum of a vector with the result left on
25970!> all processes.
25971!> \param[in,out] msg Find maximum among these data (input) and
25972!> maximum (output)
25973!> \param comm ...
25974!> \note see mp_max_z
25975! **************************************************************************************************
25976 SUBROUTINE mp_max_root_zm(msg, root, comm)
25977 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25978 INTEGER :: root
25979 CLASS(mp_comm_type), INTENT(IN) :: comm
25980
25981 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_zm'
25982
25983 INTEGER :: handle
25984#if defined(__parallel)
25985 INTEGER :: ierr, msglen
25986 COMPLEX(kind=real_8) :: res(size(msg, 1), size(msg, 2))
25987#endif
25988
25989 CALL mp_timeset(routinen, handle)
25990
25991#if defined(__parallel)
25992 msglen = SIZE(msg)
25993 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_max, root, comm%handle, ierr)
25994 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25995 IF (root == comm%mepos) msg = res
25996 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25997#else
25998 mark_used(msg)
25999 mark_used(comm)
26000 mark_used(root)
26001#endif
26002 CALL mp_timestop(handle)
26003 END SUBROUTINE mp_max_root_zm
26004
26005! **************************************************************************************************
26006!> \brief Finds the minimum of a datum with the result left on all processes.
26007!> \param[in,out] msg Find minimum among these data (input) and
26008!> maximum (output)
26009!> \param[in] comm Message passing environment identifier
26010!> \par MPI mapping
26011!> mpi_allreduce
26012! **************************************************************************************************
26013 SUBROUTINE mp_min_z (msg, comm)
26014 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
26015 CLASS(mp_comm_type), INTENT(IN) :: comm
26016
26017 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_z'
26018
26019 INTEGER :: handle
26020#if defined(__parallel)
26021 INTEGER :: ierr, msglen
26022 COMPLEX(kind=real_8) :: res
26023#endif
26024
26025 CALL mp_timeset(routinen, handle)
26026
26027#if defined(__parallel)
26028 msglen = 1
26029 IF (comm%num_pe > 1) THEN
26030 CALL mpi_allreduce(msg, res, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
26031 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
26032 msg = res
26033 END IF
26034 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
26035#else
26036 mark_used(msg)
26037 mark_used(comm)
26038#endif
26039 CALL mp_timestop(handle)
26040 END SUBROUTINE mp_min_z
26041
26042! **************************************************************************************************
26043!> \brief Finds the element-wise minimum of vector with the result left on
26044!> all processes.
26045!> \param[in,out] msg Find minimum among these data (input) and
26046!> maximum (output)
26047!> \param comm ...
26048!> \par MPI mapping
26049!> mpi_allreduce
26050!> \note see mp_min_z
26051! **************************************************************************************************
26052 SUBROUTINE mp_min_zv(msg, comm)
26053 COMPLEX(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
26054 CLASS(mp_comm_type), INTENT(IN) :: comm
26055
26056 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_zv'
26057
26058 INTEGER :: handle
26059#if defined(__parallel)
26060 INTEGER :: ierr, msglen
26061 COMPLEX(kind=real_8), ALLOCATABLE :: msgbuf(:)
26062#endif
26063
26064 CALL mp_timeset(routinen, handle)
26065
26066#if defined(__parallel)
26067 msglen = SIZE(msg)
26068 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
26069 ALLOCATE (msgbuf(msglen))
26070 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
26071 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
26072 msg = msgbuf
26073 END IF
26074 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
26075#else
26076 mark_used(msg)
26077 mark_used(comm)
26078#endif
26079 CALL mp_timestop(handle)
26080 END SUBROUTINE mp_min_zv
26081
26082! **************************************************************************************************
26083!> \brief Finds the element-wise minimum of a rank2-array with the result left on
26084!> all processes.
26085!> \param[in] msg Matrix - Find maximum among these data (input) and
26086!> minimum (output)
26087!> \param comm ...
26088!> \note see mp_min_z
26089! **************************************************************************************************
26090 SUBROUTINE mp_min_zm(msg, comm)
26091 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
26092 CLASS(mp_comm_type), INTENT(IN) :: comm
26093
26094 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_zm'
26095
26096 INTEGER :: handle
26097#if defined(__parallel)
26098 INTEGER, PARAMETER :: max_msg = 2**25
26099 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
26100 COMPLEX(kind=real_8), ALLOCATABLE :: msgbuf(:)
26101#endif
26102
26103 CALL mp_timeset(routinen, handle)
26104
26105#if defined(__parallel)
26106 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
26107 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
26108 msglensum = 0
26109 DO m1 = lbound(msg, 2), ubound(msg, 2), step
26110 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
26111 msglensum = msglensum + msglen
26112 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
26113 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
26114 ALLOCATE (msgbuf(msglen))
26115 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
26116 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
26117 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
26118 DEALLOCATE (msgbuf)
26119 END IF
26120 END DO
26121 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_8_size))
26122#else
26123 mark_used(msg)
26124 mark_used(comm)
26125#endif
26126 CALL mp_timestop(handle)
26127 END SUBROUTINE mp_min_zm
26128
26129! **************************************************************************************************
26130!> \brief Multiplies a set of numbers scattered across a number of processes,
26131!> then replicates the result.
26132!> \param[in,out] msg a number to multiply (input) and result (output)
26133!> \param[in] comm message passing environment identifier
26134!> \par MPI mapping
26135!> mpi_allreduce
26136! **************************************************************************************************
26137 SUBROUTINE mp_prod_z (msg, comm)
26138 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
26139 CLASS(mp_comm_type), INTENT(IN) :: comm
26140
26141 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_z'
26142
26143 INTEGER :: handle
26144#if defined(__parallel)
26145 INTEGER :: ierr, msglen
26146 COMPLEX(kind=real_8) :: res
26147#endif
26148
26149 CALL mp_timeset(routinen, handle)
26150
26151#if defined(__parallel)
26152 msglen = 1
26153 IF (comm%num_pe > 1) THEN
26154 CALL mpi_allreduce(msg, res, msglen, mpi_double_complex, mpi_prod, comm%handle, ierr)
26155 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
26156 msg = res
26157 END IF
26158 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
26159#else
26160 mark_used(msg)
26161 mark_used(comm)
26162#endif
26163 CALL mp_timestop(handle)
26164 END SUBROUTINE mp_prod_z
26165
26166! **************************************************************************************************
26167!> \brief Scatters data from one processes to all others
26168!> \param[in] msg_scatter Data to scatter (for root process)
26169!> \param[out] msg Received data
26170!> \param[in] root Process which scatters data
26171!> \param[in] comm Message passing environment identifier
26172!> \par MPI mapping
26173!> mpi_scatter
26174! **************************************************************************************************
26175 SUBROUTINE mp_scatter_zv(msg_scatter, msg, root, comm)
26176 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
26177 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
26178 INTEGER, INTENT(IN) :: root
26179 CLASS(mp_comm_type), INTENT(IN) :: comm
26180
26181 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_zv'
26182
26183 INTEGER :: handle
26184#if defined(__parallel)
26185 INTEGER :: ierr, msglen
26186#endif
26187
26188 CALL mp_timeset(routinen, handle)
26189
26190#if defined(__parallel)
26191 msglen = SIZE(msg)
26192 CALL mpi_scatter(msg_scatter, msglen, mpi_double_complex, msg, &
26193 msglen, mpi_double_complex, root, comm%handle, ierr)
26194 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
26195 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26196#else
26197 mark_used(root)
26198 mark_used(comm)
26199 msg = msg_scatter
26200#endif
26201 CALL mp_timestop(handle)
26202 END SUBROUTINE mp_scatter_zv
26203
26204! **************************************************************************************************
26205!> \brief Scatters data from one processes to all others
26206!> \param[in] msg_scatter Data to scatter (for root process)
26207!> \param[in] root Process which scatters data
26208!> \param[in] comm Message passing environment identifier
26209!> \par MPI mapping
26210!> mpi_scatter
26211! **************************************************************************************************
26212 SUBROUTINE mp_iscatter_z (msg_scatter, msg, root, comm, request)
26213 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:)
26214 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
26215 INTEGER, INTENT(IN) :: root
26216 CLASS(mp_comm_type), INTENT(IN) :: comm
26217 TYPE(mp_request_type), INTENT(OUT) :: request
26218
26219 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_z'
26220
26221 INTEGER :: handle
26222#if defined(__parallel)
26223 INTEGER :: ierr, msglen
26224#endif
26225
26226 CALL mp_timeset(routinen, handle)
26227
26228#if defined(__parallel)
26229#if !defined(__GNUC__) || __GNUC__ >= 9
26230 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
26231#endif
26232 msglen = 1
26233 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_complex, msg, &
26234 msglen, mpi_double_complex, root, comm%handle, request%handle, ierr)
26235 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
26236 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
26237#else
26238 mark_used(root)
26239 mark_used(comm)
26240 msg = msg_scatter(1)
26241 request = mp_request_null
26242#endif
26243 CALL mp_timestop(handle)
26244 END SUBROUTINE mp_iscatter_z
26245
26246! **************************************************************************************************
26247!> \brief Scatters data from one processes to all others
26248!> \param[in] msg_scatter Data to scatter (for root process)
26249!> \param[in] root Process which scatters data
26250!> \param[in] comm Message passing environment identifier
26251!> \par MPI mapping
26252!> mpi_scatter
26253! **************************************************************************************************
26254 SUBROUTINE mp_iscatter_zv2(msg_scatter, msg, root, comm, request)
26255 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:, :)
26256 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
26257 INTEGER, INTENT(IN) :: root
26258 CLASS(mp_comm_type), INTENT(IN) :: comm
26259 TYPE(mp_request_type), INTENT(OUT) :: request
26260
26261 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_zv2'
26262
26263 INTEGER :: handle
26264#if defined(__parallel)
26265 INTEGER :: ierr, msglen
26266#endif
26267
26268 CALL mp_timeset(routinen, handle)
26269
26270#if defined(__parallel)
26271#if !defined(__GNUC__) || __GNUC__ >= 9
26272 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
26273#endif
26274 msglen = SIZE(msg)
26275 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_complex, msg, &
26276 msglen, mpi_double_complex, root, comm%handle, request%handle, ierr)
26277 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
26278 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
26279#else
26280 mark_used(root)
26281 mark_used(comm)
26282 msg(:) = msg_scatter(:, 1)
26283 request = mp_request_null
26284#endif
26285 CALL mp_timestop(handle)
26286 END SUBROUTINE mp_iscatter_zv2
26287
26288! **************************************************************************************************
26289!> \brief Scatters data from one processes to all others
26290!> \param[in] msg_scatter Data to scatter (for root process)
26291!> \param[in] root Process which scatters data
26292!> \param[in] comm Message passing environment identifier
26293!> \par MPI mapping
26294!> mpi_scatter
26295! **************************************************************************************************
26296 SUBROUTINE mp_iscatterv_zv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
26297 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:)
26298 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
26299 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
26300 INTEGER, INTENT(IN) :: recvcount, root
26301 CLASS(mp_comm_type), INTENT(IN) :: comm
26302 TYPE(mp_request_type), INTENT(OUT) :: request
26303
26304 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_zv'
26305
26306 INTEGER :: handle
26307#if defined(__parallel)
26308 INTEGER :: ierr
26309#endif
26310
26311 CALL mp_timeset(routinen, handle)
26312
26313#if defined(__parallel)
26314#if !defined(__GNUC__) || __GNUC__ >= 9
26315 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
26316 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
26317 cpassert(is_contiguous(sendcounts) .OR. SIZE(sendcounts) == 0)
26318 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
26319#endif
26320 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_double_complex, msg, &
26321 recvcount, mpi_double_complex, root, comm%handle, request%handle, ierr)
26322 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
26323 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
26324#else
26325 mark_used(sendcounts)
26326 mark_used(displs)
26327 mark_used(recvcount)
26328 mark_used(root)
26329 mark_used(comm)
26330 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
26331 request = mp_request_null
26332#endif
26333 CALL mp_timestop(handle)
26334 END SUBROUTINE mp_iscatterv_zv
26335
26336! **************************************************************************************************
26337!> \brief Gathers a datum from all processes to one
26338!> \param[in] msg Datum to send to root
26339!> \param[out] msg_gather Received data (on root)
26340!> \param[in] root Process which gathers the data
26341!> \param[in] comm Message passing environment identifier
26342!> \par MPI mapping
26343!> mpi_gather
26344! **************************************************************************************************
26345 SUBROUTINE mp_gather_z (msg, msg_gather, root, comm)
26346 COMPLEX(kind=real_8), INTENT(IN) :: msg
26347 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
26348 INTEGER, INTENT(IN) :: root
26349 CLASS(mp_comm_type), INTENT(IN) :: comm
26350
26351 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_z'
26352
26353 INTEGER :: handle
26354#if defined(__parallel)
26355 INTEGER :: ierr, msglen
26356#endif
26357
26358 CALL mp_timeset(routinen, handle)
26359
26360#if defined(__parallel)
26361 msglen = 1
26362 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26363 msglen, mpi_double_complex, root, comm%handle, ierr)
26364 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26365 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26366#else
26367 mark_used(root)
26368 mark_used(comm)
26369 msg_gather(1) = msg
26370#endif
26371 CALL mp_timestop(handle)
26372 END SUBROUTINE mp_gather_z
26373
26374! **************************************************************************************************
26375!> \brief Gathers a datum from all processes to one, uses the source process of comm
26376!> \param[in] msg Datum to send to root
26377!> \param[out] msg_gather Received data (on root)
26378!> \param[in] comm Message passing environment identifier
26379!> \par MPI mapping
26380!> mpi_gather
26381! **************************************************************************************************
26382 SUBROUTINE mp_gather_z_src(msg, msg_gather, comm)
26383 COMPLEX(kind=real_8), INTENT(IN) :: msg
26384 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
26385 CLASS(mp_comm_type), INTENT(IN) :: comm
26386
26387 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_z_src'
26388
26389 INTEGER :: handle
26390#if defined(__parallel)
26391 INTEGER :: ierr, msglen
26392#endif
26393
26394 CALL mp_timeset(routinen, handle)
26395
26396#if defined(__parallel)
26397 msglen = 1
26398 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26399 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
26400 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26401 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26402#else
26403 mark_used(comm)
26404 msg_gather(1) = msg
26405#endif
26406 CALL mp_timestop(handle)
26407 END SUBROUTINE mp_gather_z_src
26408
26409! **************************************************************************************************
26410!> \brief Gathers data from all processes to one
26411!> \param[in] msg Datum to send to root
26412!> \param msg_gather ...
26413!> \param root ...
26414!> \param comm ...
26415!> \par Data length
26416!> All data (msg) is equal-sized
26417!> \par MPI mapping
26418!> mpi_gather
26419!> \note see mp_gather_z
26420! **************************************************************************************************
26421 SUBROUTINE mp_gather_zv(msg, msg_gather, root, comm)
26422 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
26423 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
26424 INTEGER, INTENT(IN) :: root
26425 CLASS(mp_comm_type), INTENT(IN) :: comm
26426
26427 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zv'
26428
26429 INTEGER :: handle
26430#if defined(__parallel)
26431 INTEGER :: ierr, msglen
26432#endif
26433
26434 CALL mp_timeset(routinen, handle)
26435
26436#if defined(__parallel)
26437 msglen = SIZE(msg)
26438 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26439 msglen, mpi_double_complex, root, comm%handle, ierr)
26440 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26441 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26442#else
26443 mark_used(root)
26444 mark_used(comm)
26445 msg_gather = msg
26446#endif
26447 CALL mp_timestop(handle)
26448 END SUBROUTINE mp_gather_zv
26449
26450! **************************************************************************************************
26451!> \brief Gathers data from all processes to one. Gathers from comm%source
26452!> \param[in] msg Datum to send to root
26453!> \param msg_gather ...
26454!> \param comm ...
26455!> \par Data length
26456!> All data (msg) is equal-sized
26457!> \par MPI mapping
26458!> mpi_gather
26459!> \note see mp_gather_z
26460! **************************************************************************************************
26461 SUBROUTINE mp_gather_zv_src(msg, msg_gather, comm)
26462 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
26463 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
26464 CLASS(mp_comm_type), INTENT(IN) :: comm
26465
26466 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zv_src'
26467
26468 INTEGER :: handle
26469#if defined(__parallel)
26470 INTEGER :: ierr, msglen
26471#endif
26472
26473 CALL mp_timeset(routinen, handle)
26474
26475#if defined(__parallel)
26476 msglen = SIZE(msg)
26477 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26478 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
26479 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26480 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26481#else
26482 mark_used(comm)
26483 msg_gather = msg
26484#endif
26485 CALL mp_timestop(handle)
26486 END SUBROUTINE mp_gather_zv_src
26487
26488! **************************************************************************************************
26489!> \brief Gathers data from all processes to one
26490!> \param[in] msg Datum to send to root
26491!> \param msg_gather ...
26492!> \param root ...
26493!> \param comm ...
26494!> \par Data length
26495!> All data (msg) is equal-sized
26496!> \par MPI mapping
26497!> mpi_gather
26498!> \note see mp_gather_z
26499! **************************************************************************************************
26500 SUBROUTINE mp_gather_zm(msg, msg_gather, root, comm)
26501 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
26502 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
26503 INTEGER, INTENT(IN) :: root
26504 CLASS(mp_comm_type), INTENT(IN) :: comm
26505
26506 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zm'
26507
26508 INTEGER :: handle
26509#if defined(__parallel)
26510 INTEGER :: ierr, msglen
26511#endif
26512
26513 CALL mp_timeset(routinen, handle)
26514
26515#if defined(__parallel)
26516 msglen = SIZE(msg)
26517 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26518 msglen, mpi_double_complex, root, comm%handle, ierr)
26519 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26520 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26521#else
26522 mark_used(root)
26523 mark_used(comm)
26524 msg_gather = msg
26525#endif
26526 CALL mp_timestop(handle)
26527 END SUBROUTINE mp_gather_zm
26528
26529! **************************************************************************************************
26530!> \brief Gathers data from all processes to one. Gathers from comm%source
26531!> \param[in] msg Datum to send to root
26532!> \param msg_gather ...
26533!> \param comm ...
26534!> \par Data length
26535!> All data (msg) is equal-sized
26536!> \par MPI mapping
26537!> mpi_gather
26538!> \note see mp_gather_z
26539! **************************************************************************************************
26540 SUBROUTINE mp_gather_zm_src(msg, msg_gather, comm)
26541 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
26542 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
26543 CLASS(mp_comm_type), INTENT(IN) :: comm
26544
26545 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zm_src'
26546
26547 INTEGER :: handle
26548#if defined(__parallel)
26549 INTEGER :: ierr, msglen
26550#endif
26551
26552 CALL mp_timeset(routinen, handle)
26553
26554#if defined(__parallel)
26555 msglen = SIZE(msg)
26556 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26557 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
26558 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26559 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26560#else
26561 mark_used(comm)
26562 msg_gather = msg
26563#endif
26564 CALL mp_timestop(handle)
26565 END SUBROUTINE mp_gather_zm_src
26566
26567! **************************************************************************************************
26568!> \brief Gathers data from all processes to one.
26569!> \param[in] sendbuf Data to send to root
26570!> \param[out] recvbuf Received data (on root)
26571!> \param[in] recvcounts Sizes of data received from processes
26572!> \param[in] displs Offsets of data received from processes
26573!> \param[in] root Process which gathers the data
26574!> \param[in] comm Message passing environment identifier
26575!> \par Data length
26576!> Data can have different lengths
26577!> \par Offsets
26578!> Offsets start at 0
26579!> \par MPI mapping
26580!> mpi_gather
26581! **************************************************************************************************
26582 SUBROUTINE mp_gatherv_zv(sendbuf, recvbuf, recvcounts, displs, root, comm)
26583
26584 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
26585 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
26586 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26587 INTEGER, INTENT(IN) :: root
26588 CLASS(mp_comm_type), INTENT(IN) :: comm
26589
26590 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zv'
26591
26592 INTEGER :: handle
26593#if defined(__parallel)
26594 INTEGER :: ierr, sendcount
26595#endif
26596
26597 CALL mp_timeset(routinen, handle)
26598
26599#if defined(__parallel)
26600 sendcount = SIZE(sendbuf)
26601 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26602 recvbuf, recvcounts, displs, mpi_double_complex, &
26603 root, comm%handle, ierr)
26604 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26605 CALL add_perf(perf_id=4, &
26606 count=1, &
26607 msg_size=sendcount*(2*real_8_size))
26608#else
26609 mark_used(recvcounts)
26610 mark_used(root)
26611 mark_used(comm)
26612 recvbuf(1 + displs(1):) = sendbuf
26613#endif
26614 CALL mp_timestop(handle)
26615 END SUBROUTINE mp_gatherv_zv
26616
26617! **************************************************************************************************
26618!> \brief Gathers data from all processes to one. Gathers from comm%source
26619!> \param[in] sendbuf Data to send to root
26620!> \param[out] recvbuf Received data (on root)
26621!> \param[in] recvcounts Sizes of data received from processes
26622!> \param[in] displs Offsets of data received from processes
26623!> \param[in] comm Message passing environment identifier
26624!> \par Data length
26625!> Data can have different lengths
26626!> \par Offsets
26627!> Offsets start at 0
26628!> \par MPI mapping
26629!> mpi_gather
26630! **************************************************************************************************
26631 SUBROUTINE mp_gatherv_zv_src(sendbuf, recvbuf, recvcounts, displs, comm)
26632
26633 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
26634 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
26635 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26636 CLASS(mp_comm_type), INTENT(IN) :: comm
26637
26638 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zv_src'
26639
26640 INTEGER :: handle
26641#if defined(__parallel)
26642 INTEGER :: ierr, sendcount
26643#endif
26644
26645 CALL mp_timeset(routinen, handle)
26646
26647#if defined(__parallel)
26648 sendcount = SIZE(sendbuf)
26649 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26650 recvbuf, recvcounts, displs, mpi_double_complex, &
26651 comm%source, comm%handle, ierr)
26652 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26653 CALL add_perf(perf_id=4, &
26654 count=1, &
26655 msg_size=sendcount*(2*real_8_size))
26656#else
26657 mark_used(recvcounts)
26658 mark_used(comm)
26659 recvbuf(1 + displs(1):) = sendbuf
26660#endif
26661 CALL mp_timestop(handle)
26662 END SUBROUTINE mp_gatherv_zv_src
26663
26664! **************************************************************************************************
26665!> \brief Gathers data from all processes to one.
26666!> \param[in] sendbuf Data to send to root
26667!> \param[out] recvbuf Received data (on root)
26668!> \param[in] recvcounts Sizes of data received from processes
26669!> \param[in] displs Offsets of data received from processes
26670!> \param[in] root Process which gathers the data
26671!> \param[in] comm Message passing environment identifier
26672!> \par Data length
26673!> Data can have different lengths
26674!> \par Offsets
26675!> Offsets start at 0
26676!> \par MPI mapping
26677!> mpi_gather
26678! **************************************************************************************************
26679 SUBROUTINE mp_gatherv_zm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
26680
26681 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
26682 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
26683 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26684 INTEGER, INTENT(IN) :: root
26685 CLASS(mp_comm_type), INTENT(IN) :: comm
26686
26687 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zm2'
26688
26689 INTEGER :: handle
26690#if defined(__parallel)
26691 INTEGER :: ierr, sendcount
26692#endif
26693
26694 CALL mp_timeset(routinen, handle)
26695
26696#if defined(__parallel)
26697 sendcount = SIZE(sendbuf)
26698 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26699 recvbuf, recvcounts, displs, mpi_double_complex, &
26700 root, comm%handle, ierr)
26701 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26702 CALL add_perf(perf_id=4, &
26703 count=1, &
26704 msg_size=sendcount*(2*real_8_size))
26705#else
26706 mark_used(recvcounts)
26707 mark_used(root)
26708 mark_used(comm)
26709 recvbuf(:, 1 + displs(1):) = sendbuf
26710#endif
26711 CALL mp_timestop(handle)
26712 END SUBROUTINE mp_gatherv_zm2
26713
26714! **************************************************************************************************
26715!> \brief Gathers data from all processes to one.
26716!> \param[in] sendbuf Data to send to root
26717!> \param[out] recvbuf Received data (on root)
26718!> \param[in] recvcounts Sizes of data received from processes
26719!> \param[in] displs Offsets of data received from processes
26720!> \param[in] comm Message passing environment identifier
26721!> \par Data length
26722!> Data can have different lengths
26723!> \par Offsets
26724!> Offsets start at 0
26725!> \par MPI mapping
26726!> mpi_gather
26727! **************************************************************************************************
26728 SUBROUTINE mp_gatherv_zm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
26729
26730 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
26731 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
26732 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26733 CLASS(mp_comm_type), INTENT(IN) :: comm
26734
26735 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zm2_src'
26736
26737 INTEGER :: handle
26738#if defined(__parallel)
26739 INTEGER :: ierr, sendcount
26740#endif
26741
26742 CALL mp_timeset(routinen, handle)
26743
26744#if defined(__parallel)
26745 sendcount = SIZE(sendbuf)
26746 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26747 recvbuf, recvcounts, displs, mpi_double_complex, &
26748 comm%source, comm%handle, ierr)
26749 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26750 CALL add_perf(perf_id=4, &
26751 count=1, &
26752 msg_size=sendcount*(2*real_8_size))
26753#else
26754 mark_used(recvcounts)
26755 mark_used(comm)
26756 recvbuf(:, 1 + displs(1):) = sendbuf
26757#endif
26758 CALL mp_timestop(handle)
26759 END SUBROUTINE mp_gatherv_zm2_src
26760
26761! **************************************************************************************************
26762!> \brief Gathers data from all processes to one.
26763!> \param[in] sendbuf Data to send to root
26764!> \param[out] recvbuf Received data (on root)
26765!> \param[in] recvcounts Sizes of data received from processes
26766!> \param[in] displs Offsets of data received from processes
26767!> \param[in] root Process which gathers the data
26768!> \param[in] comm Message passing environment identifier
26769!> \par Data length
26770!> Data can have different lengths
26771!> \par Offsets
26772!> Offsets start at 0
26773!> \par MPI mapping
26774!> mpi_gather
26775! **************************************************************************************************
26776 SUBROUTINE mp_igatherv_zv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
26777 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: sendbuf
26778 COMPLEX(kind=real_8), DIMENSION(:), INTENT(OUT) :: recvbuf
26779 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26780 INTEGER, INTENT(IN) :: sendcount, root
26781 CLASS(mp_comm_type), INTENT(IN) :: comm
26782 TYPE(mp_request_type), INTENT(OUT) :: request
26783
26784 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_zv'
26785
26786 INTEGER :: handle
26787#if defined(__parallel)
26788 INTEGER :: ierr
26789#endif
26790
26791 CALL mp_timeset(routinen, handle)
26792
26793#if defined(__parallel)
26794#if !defined(__GNUC__) || __GNUC__ >= 9
26795 cpassert(is_contiguous(sendbuf) .OR. SIZE(sendbuf) == 0)
26796 cpassert(is_contiguous(recvbuf) .OR. SIZE(recvbuf) == 0)
26797 cpassert(is_contiguous(recvcounts) .OR. SIZE(recvcounts) == 0)
26798 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
26799#endif
26800 CALL mpi_igatherv(sendbuf, sendcount, mpi_double_complex, &
26801 recvbuf, recvcounts, displs, mpi_double_complex, &
26802 root, comm%handle, request%handle, ierr)
26803 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26804 CALL add_perf(perf_id=24, &
26805 count=1, &
26806 msg_size=sendcount*(2*real_8_size))
26807#else
26808 mark_used(sendcount)
26809 mark_used(recvcounts)
26810 mark_used(root)
26811 mark_used(comm)
26812 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
26813 request = mp_request_null
26814#endif
26815 CALL mp_timestop(handle)
26816 END SUBROUTINE mp_igatherv_zv
26817
26818! **************************************************************************************************
26819!> \brief Gathers a datum from all processes and all processes receive the
26820!> same data
26821!> \param[in] msgout Datum to send
26822!> \param[out] msgin Received data
26823!> \param[in] comm Message passing environment identifier
26824!> \par Data size
26825!> All processes send equal-sized data
26826!> \par MPI mapping
26827!> mpi_allgather
26828! **************************************************************************************************
26829 SUBROUTINE mp_allgather_z (msgout, msgin, comm)
26830 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26831 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
26832 CLASS(mp_comm_type), INTENT(IN) :: comm
26833
26834 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z'
26835
26836 INTEGER :: handle
26837#if defined(__parallel)
26838 INTEGER :: ierr, rcount, scount
26839#endif
26840
26841 CALL mp_timeset(routinen, handle)
26842
26843#if defined(__parallel)
26844 scount = 1
26845 rcount = 1
26846 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26847 msgin, rcount, mpi_double_complex, &
26848 comm%handle, ierr)
26849 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26850#else
26851 mark_used(comm)
26852 msgin = msgout
26853#endif
26854 CALL mp_timestop(handle)
26855 END SUBROUTINE mp_allgather_z
26856
26857! **************************************************************************************************
26858!> \brief Gathers a datum from all processes and all processes receive the
26859!> same data
26860!> \param[in] msgout Datum to send
26861!> \param[out] msgin Received data
26862!> \param[in] comm Message passing environment identifier
26863!> \par Data size
26864!> All processes send equal-sized data
26865!> \par MPI mapping
26866!> mpi_allgather
26867! **************************************************************************************************
26868 SUBROUTINE mp_allgather_z2(msgout, msgin, comm)
26869 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26870 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26871 CLASS(mp_comm_type), INTENT(IN) :: comm
26872
26873 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z2'
26874
26875 INTEGER :: handle
26876#if defined(__parallel)
26877 INTEGER :: ierr, rcount, scount
26878#endif
26879
26880 CALL mp_timeset(routinen, handle)
26881
26882#if defined(__parallel)
26883 scount = 1
26884 rcount = 1
26885 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26886 msgin, rcount, mpi_double_complex, &
26887 comm%handle, ierr)
26888 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26889#else
26890 mark_used(comm)
26891 msgin = msgout
26892#endif
26893 CALL mp_timestop(handle)
26894 END SUBROUTINE mp_allgather_z2
26895
26896! **************************************************************************************************
26897!> \brief Gathers a datum from all processes and all processes receive the
26898!> same data
26899!> \param[in] msgout Datum to send
26900!> \param[out] msgin Received data
26901!> \param[in] comm Message passing environment identifier
26902!> \par Data size
26903!> All processes send equal-sized data
26904!> \par MPI mapping
26905!> mpi_allgather
26906! **************************************************************************************************
26907 SUBROUTINE mp_iallgather_z (msgout, msgin, comm, request)
26908 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26909 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26910 CLASS(mp_comm_type), INTENT(IN) :: comm
26911 TYPE(mp_request_type), INTENT(OUT) :: request
26912
26913 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z'
26914
26915 INTEGER :: handle
26916#if defined(__parallel)
26917 INTEGER :: ierr, rcount, scount
26918#endif
26919
26920 CALL mp_timeset(routinen, handle)
26921
26922#if defined(__parallel)
26923#if !defined(__GNUC__) || __GNUC__ >= 9
26924 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
26925#endif
26926 scount = 1
26927 rcount = 1
26928 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26929 msgin, rcount, mpi_double_complex, &
26930 comm%handle, request%handle, ierr)
26931 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26932#else
26933 mark_used(comm)
26934 msgin = msgout
26935 request = mp_request_null
26936#endif
26937 CALL mp_timestop(handle)
26938 END SUBROUTINE mp_iallgather_z
26939
26940! **************************************************************************************************
26941!> \brief Gathers vector data from all processes and all processes receive the
26942!> same data
26943!> \param[in] msgout Rank-1 data to send
26944!> \param[out] msgin Received data
26945!> \param[in] comm Message passing environment identifier
26946!> \par Data size
26947!> All processes send equal-sized data
26948!> \par Ranks
26949!> The last rank counts the processes
26950!> \par MPI mapping
26951!> mpi_allgather
26952! **************************************************************************************************
26953 SUBROUTINE mp_allgather_z12(msgout, msgin, comm)
26954 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:)
26955 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26956 CLASS(mp_comm_type), INTENT(IN) :: comm
26957
26958 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z12'
26959
26960 INTEGER :: handle
26961#if defined(__parallel)
26962 INTEGER :: ierr, rcount, scount
26963#endif
26964
26965 CALL mp_timeset(routinen, handle)
26966
26967#if defined(__parallel)
26968 scount = SIZE(msgout(:))
26969 rcount = scount
26970 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26971 msgin, rcount, mpi_double_complex, &
26972 comm%handle, ierr)
26973 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26974#else
26975 mark_used(comm)
26976 msgin(:, 1) = msgout(:)
26977#endif
26978 CALL mp_timestop(handle)
26979 END SUBROUTINE mp_allgather_z12
26980
26981! **************************************************************************************************
26982!> \brief Gathers matrix data from all processes and all processes receive the
26983!> same data
26984!> \param[in] msgout Rank-2 data to send
26985!> \param msgin ...
26986!> \param comm ...
26987!> \note see mp_allgather_z12
26988! **************************************************************************************************
26989 SUBROUTINE mp_allgather_z23(msgout, msgin, comm)
26990 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
26991 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
26992 CLASS(mp_comm_type), INTENT(IN) :: comm
26993
26994 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z23'
26995
26996 INTEGER :: handle
26997#if defined(__parallel)
26998 INTEGER :: ierr, rcount, scount
26999#endif
27000
27001 CALL mp_timeset(routinen, handle)
27002
27003#if defined(__parallel)
27004 scount = SIZE(msgout(:, :))
27005 rcount = scount
27006 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
27007 msgin, rcount, mpi_double_complex, &
27008 comm%handle, ierr)
27009 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
27010#else
27011 mark_used(comm)
27012 msgin(:, :, 1) = msgout(:, :)
27013#endif
27014 CALL mp_timestop(handle)
27015 END SUBROUTINE mp_allgather_z23
27016
27017! **************************************************************************************************
27018!> \brief Gathers rank-3 data from all processes and all processes receive the
27019!> same data
27020!> \param[in] msgout Rank-3 data to send
27021!> \param msgin ...
27022!> \param comm ...
27023!> \note see mp_allgather_z12
27024! **************************************************************************************************
27025 SUBROUTINE mp_allgather_z34(msgout, msgin, comm)
27026 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
27027 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
27028 CLASS(mp_comm_type), INTENT(IN) :: comm
27029
27030 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z34'
27031
27032 INTEGER :: handle
27033#if defined(__parallel)
27034 INTEGER :: ierr, rcount, scount
27035#endif
27036
27037 CALL mp_timeset(routinen, handle)
27038
27039#if defined(__parallel)
27040 scount = SIZE(msgout(:, :, :))
27041 rcount = scount
27042 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
27043 msgin, rcount, mpi_double_complex, &
27044 comm%handle, ierr)
27045 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
27046#else
27047 mark_used(comm)
27048 msgin(:, :, :, 1) = msgout(:, :, :)
27049#endif
27050 CALL mp_timestop(handle)
27051 END SUBROUTINE mp_allgather_z34
27052
27053! **************************************************************************************************
27054!> \brief Gathers rank-2 data from all processes and all processes receive the
27055!> same data
27056!> \param[in] msgout Rank-2 data to send
27057!> \param msgin ...
27058!> \param comm ...
27059!> \note see mp_allgather_z12
27060! **************************************************************************************************
27061 SUBROUTINE mp_allgather_z22(msgout, msgin, comm)
27062 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
27063 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
27064 CLASS(mp_comm_type), INTENT(IN) :: comm
27065
27066 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z22'
27067
27068 INTEGER :: handle
27069#if defined(__parallel)
27070 INTEGER :: ierr, rcount, scount
27071#endif
27072
27073 CALL mp_timeset(routinen, handle)
27074
27075#if defined(__parallel)
27076 scount = SIZE(msgout(:, :))
27077 rcount = scount
27078 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
27079 msgin, rcount, mpi_double_complex, &
27080 comm%handle, ierr)
27081 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
27082#else
27083 mark_used(comm)
27084 msgin(:, :) = msgout(:, :)
27085#endif
27086 CALL mp_timestop(handle)
27087 END SUBROUTINE mp_allgather_z22
27088
27089! **************************************************************************************************
27090!> \brief Gathers rank-1 data from all processes and all processes receive the
27091!> same data
27092!> \param[in] msgout Rank-1 data to send
27093!> \param msgin ...
27094!> \param comm ...
27095!> \param request ...
27096!> \note see mp_allgather_z11
27097! **************************************************************************************************
27098 SUBROUTINE mp_iallgather_z11(msgout, msgin, comm, request)
27099 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
27100 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
27101 CLASS(mp_comm_type), INTENT(IN) :: comm
27102 TYPE(mp_request_type), INTENT(OUT) :: request
27103
27104 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z11'
27105
27106 INTEGER :: handle
27107#if defined(__parallel)
27108 INTEGER :: ierr, rcount, scount
27109#endif
27110
27111 CALL mp_timeset(routinen, handle)
27112
27113#if defined(__parallel)
27114#if !defined(__GNUC__) || __GNUC__ >= 9
27115 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
27116 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
27117#endif
27118 scount = SIZE(msgout(:))
27119 rcount = scount
27120 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
27121 msgin, rcount, mpi_double_complex, &
27122 comm%handle, request%handle, ierr)
27123 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
27124#else
27125 mark_used(comm)
27126 msgin = msgout
27127 request = mp_request_null
27128#endif
27129 CALL mp_timestop(handle)
27130 END SUBROUTINE mp_iallgather_z11
27131
27132! **************************************************************************************************
27133!> \brief Gathers rank-2 data from all processes and all processes receive the
27134!> same data
27135!> \param[in] msgout Rank-2 data to send
27136!> \param msgin ...
27137!> \param comm ...
27138!> \param request ...
27139!> \note see mp_allgather_z12
27140! **************************************************************************************************
27141 SUBROUTINE mp_iallgather_z13(msgout, msgin, comm, request)
27142 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
27143 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
27144 CLASS(mp_comm_type), INTENT(IN) :: comm
27145 TYPE(mp_request_type), INTENT(OUT) :: request
27146
27147 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z13'
27148
27149 INTEGER :: handle
27150#if defined(__parallel)
27151 INTEGER :: ierr, rcount, scount
27152#endif
27153
27154 CALL mp_timeset(routinen, handle)
27155
27156#if defined(__parallel)
27157#if !defined(__GNUC__) || __GNUC__ >= 9
27158 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
27159 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
27160#endif
27161
27162 scount = SIZE(msgout(:))
27163 rcount = scount
27164 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
27165 msgin, rcount, mpi_double_complex, &
27166 comm%handle, request%handle, ierr)
27167 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
27168#else
27169 mark_used(comm)
27170 msgin(:, 1, 1) = msgout(:)
27171 request = mp_request_null
27172#endif
27173 CALL mp_timestop(handle)
27174 END SUBROUTINE mp_iallgather_z13
27175
27176! **************************************************************************************************
27177!> \brief Gathers rank-2 data from all processes and all processes receive the
27178!> same data
27179!> \param[in] msgout Rank-2 data to send
27180!> \param msgin ...
27181!> \param comm ...
27182!> \param request ...
27183!> \note see mp_allgather_z12
27184! **************************************************************************************************
27185 SUBROUTINE mp_iallgather_z22(msgout, msgin, comm, request)
27186 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :)
27187 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :)
27188 CLASS(mp_comm_type), INTENT(IN) :: comm
27189 TYPE(mp_request_type), INTENT(OUT) :: request
27190
27191 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z22'
27192
27193 INTEGER :: handle
27194#if defined(__parallel)
27195 INTEGER :: ierr, rcount, scount
27196#endif
27197
27198 CALL mp_timeset(routinen, handle)
27199
27200#if defined(__parallel)
27201#if !defined(__GNUC__) || __GNUC__ >= 9
27202 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
27203 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
27204#endif
27205
27206 scount = SIZE(msgout(:, :))
27207 rcount = scount
27208 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
27209 msgin, rcount, mpi_double_complex, &
27210 comm%handle, request%handle, ierr)
27211 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
27212#else
27213 mark_used(comm)
27214 msgin(:, :) = msgout(:, :)
27215 request = mp_request_null
27216#endif
27217 CALL mp_timestop(handle)
27218 END SUBROUTINE mp_iallgather_z22
27219
27220! **************************************************************************************************
27221!> \brief Gathers rank-2 data from all processes and all processes receive the
27222!> same data
27223!> \param[in] msgout Rank-2 data to send
27224!> \param msgin ...
27225!> \param comm ...
27226!> \param request ...
27227!> \note see mp_allgather_z12
27228! **************************************************************************************************
27229 SUBROUTINE mp_iallgather_z24(msgout, msgin, comm, request)
27230 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :)
27231 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :, :)
27232 CLASS(mp_comm_type), INTENT(IN) :: comm
27233 TYPE(mp_request_type), INTENT(OUT) :: request
27234
27235 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z24'
27236
27237 INTEGER :: handle
27238#if defined(__parallel)
27239 INTEGER :: ierr, rcount, scount
27240#endif
27241
27242 CALL mp_timeset(routinen, handle)
27243
27244#if defined(__parallel)
27245#if !defined(__GNUC__) || __GNUC__ >= 9
27246 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
27247 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
27248#endif
27249
27250 scount = SIZE(msgout(:, :))
27251 rcount = scount
27252 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
27253 msgin, rcount, mpi_double_complex, &
27254 comm%handle, request%handle, ierr)
27255 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
27256#else
27257 mark_used(comm)
27258 msgin(:, :, 1, 1) = msgout(:, :)
27259 request = mp_request_null
27260#endif
27261 CALL mp_timestop(handle)
27262 END SUBROUTINE mp_iallgather_z24
27263
27264! **************************************************************************************************
27265!> \brief Gathers rank-3 data from all processes and all processes receive the
27266!> same data
27267!> \param[in] msgout Rank-3 data to send
27268!> \param msgin ...
27269!> \param comm ...
27270!> \param request ...
27271!> \note see mp_allgather_z12
27272! **************************************************************************************************
27273 SUBROUTINE mp_iallgather_z33(msgout, msgin, comm, request)
27274 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :, :)
27275 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
27276 CLASS(mp_comm_type), INTENT(IN) :: comm
27277 TYPE(mp_request_type), INTENT(OUT) :: request
27278
27279 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z33'
27280
27281 INTEGER :: handle
27282#if defined(__parallel)
27283 INTEGER :: ierr, rcount, scount
27284#endif
27285
27286 CALL mp_timeset(routinen, handle)
27287
27288#if defined(__parallel)
27289#if !defined(__GNUC__) || __GNUC__ >= 9
27290 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
27291 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
27292#endif
27293
27294 scount = SIZE(msgout(:, :, :))
27295 rcount = scount
27296 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
27297 msgin, rcount, mpi_double_complex, &
27298 comm%handle, request%handle, ierr)
27299 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
27300#else
27301 mark_used(comm)
27302 msgin(:, :, :) = msgout(:, :, :)
27303 request = mp_request_null
27304#endif
27305 CALL mp_timestop(handle)
27306 END SUBROUTINE mp_iallgather_z33
27307
27308! **************************************************************************************************
27309!> \brief Gathers vector data from all processes and all processes receive the
27310!> same data
27311!> \param[in] msgout Rank-1 data to send
27312!> \param[out] msgin Received data
27313!> \param[in] rcount Size of sent data for every process
27314!> \param[in] rdispl Offset of sent data for every process
27315!> \param[in] comm Message passing environment identifier
27316!> \par Data size
27317!> Processes can send different-sized data
27318!> \par Ranks
27319!> The last rank counts the processes
27320!> \par Offsets
27321!> Offsets are from 0
27322!> \par MPI mapping
27323!> mpi_allgather
27324! **************************************************************************************************
27325 SUBROUTINE mp_allgatherv_zv(msgout, msgin, rcount, rdispl, comm)
27326 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
27327 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
27328 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
27329 CLASS(mp_comm_type), INTENT(IN) :: comm
27330
27331 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_zv'
27332
27333 INTEGER :: handle
27334#if defined(__parallel)
27335 INTEGER :: ierr, scount
27336#endif
27337
27338 CALL mp_timeset(routinen, handle)
27339
27340#if defined(__parallel)
27341 scount = SIZE(msgout)
27342 CALL mpi_allgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
27343 rdispl, mpi_double_complex, comm%handle, ierr)
27344 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
27345#else
27346 mark_used(rcount)
27347 mark_used(rdispl)
27348 mark_used(comm)
27349 msgin = msgout
27350#endif
27351 CALL mp_timestop(handle)
27352 END SUBROUTINE mp_allgatherv_zv
27353
27354! **************************************************************************************************
27355!> \brief Gathers vector data from all processes and all processes receive the
27356!> same data
27357!> \param[in] msgout Rank-1 data to send
27358!> \param[out] msgin Received data
27359!> \param[in] rcount Size of sent data for every process
27360!> \param[in] rdispl Offset of sent data for every process
27361!> \param[in] comm Message passing environment identifier
27362!> \par Data size
27363!> Processes can send different-sized data
27364!> \par Ranks
27365!> The last rank counts the processes
27366!> \par Offsets
27367!> Offsets are from 0
27368!> \par MPI mapping
27369!> mpi_allgather
27370! **************************************************************************************************
27371 SUBROUTINE mp_allgatherv_zm2(msgout, msgin, rcount, rdispl, comm)
27372 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
27373 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
27374 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
27375 CLASS(mp_comm_type), INTENT(IN) :: comm
27376
27377 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_zv'
27378
27379 INTEGER :: handle
27380#if defined(__parallel)
27381 INTEGER :: ierr, scount
27382#endif
27383
27384 CALL mp_timeset(routinen, handle)
27385
27386#if defined(__parallel)
27387 scount = SIZE(msgout)
27388 CALL mpi_allgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
27389 rdispl, mpi_double_complex, comm%handle, ierr)
27390 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
27391#else
27392 mark_used(rcount)
27393 mark_used(rdispl)
27394 mark_used(comm)
27395 msgin = msgout
27396#endif
27397 CALL mp_timestop(handle)
27398 END SUBROUTINE mp_allgatherv_zm2
27399
27400! **************************************************************************************************
27401!> \brief Gathers vector data from all processes and all processes receive the
27402!> same data
27403!> \param[in] msgout Rank-1 data to send
27404!> \param[out] msgin Received data
27405!> \param[in] rcount Size of sent data for every process
27406!> \param[in] rdispl Offset of sent data for every process
27407!> \param[in] comm Message passing environment identifier
27408!> \par Data size
27409!> Processes can send different-sized data
27410!> \par Ranks
27411!> The last rank counts the processes
27412!> \par Offsets
27413!> Offsets are from 0
27414!> \par MPI mapping
27415!> mpi_allgather
27416! **************************************************************************************************
27417 SUBROUTINE mp_iallgatherv_zv(msgout, msgin, rcount, rdispl, comm, request)
27418 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
27419 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
27420 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
27421 CLASS(mp_comm_type), INTENT(IN) :: comm
27422 TYPE(mp_request_type), INTENT(OUT) :: request
27423
27424 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_zv'
27425
27426 INTEGER :: handle
27427#if defined(__parallel)
27428 INTEGER :: ierr, scount, rsize
27429#endif
27430
27431 CALL mp_timeset(routinen, handle)
27432
27433#if defined(__parallel)
27434#if !defined(__GNUC__) || __GNUC__ >= 9
27435 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
27436 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
27437 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
27438 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
27439#endif
27440
27441 scount = SIZE(msgout)
27442 rsize = SIZE(rcount)
27443 CALL mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, &
27444 rdispl, comm, request, ierr)
27445 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
27446#else
27447 mark_used(rcount)
27448 mark_used(rdispl)
27449 mark_used(comm)
27450 msgin = msgout
27451 request = mp_request_null
27452#endif
27453 CALL mp_timestop(handle)
27454 END SUBROUTINE mp_iallgatherv_zv
27455
27456! **************************************************************************************************
27457!> \brief Gathers vector data from all processes and all processes receive the
27458!> same data
27459!> \param[in] msgout Rank-1 data to send
27460!> \param[out] msgin Received data
27461!> \param[in] rcount Size of sent data for every process
27462!> \param[in] rdispl Offset of sent data for every process
27463!> \param[in] comm Message passing environment identifier
27464!> \par Data size
27465!> Processes can send different-sized data
27466!> \par Ranks
27467!> The last rank counts the processes
27468!> \par Offsets
27469!> Offsets are from 0
27470!> \par MPI mapping
27471!> mpi_allgather
27472! **************************************************************************************************
27473 SUBROUTINE mp_iallgatherv_zv2(msgout, msgin, rcount, rdispl, comm, request)
27474 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
27475 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
27476 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
27477 CLASS(mp_comm_type), INTENT(IN) :: comm
27478 TYPE(mp_request_type), INTENT(OUT) :: request
27479
27480 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_zv2'
27481
27482 INTEGER :: handle
27483#if defined(__parallel)
27484 INTEGER :: ierr, scount, rsize
27485#endif
27486
27487 CALL mp_timeset(routinen, handle)
27488
27489#if defined(__parallel)
27490#if !defined(__GNUC__) || __GNUC__ >= 9
27491 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
27492 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
27493 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
27494 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
27495#endif
27496
27497 scount = SIZE(msgout)
27498 rsize = SIZE(rcount)
27499 CALL mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, &
27500 rdispl, comm, request, ierr)
27501 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
27502#else
27503 mark_used(rcount)
27504 mark_used(rdispl)
27505 mark_used(comm)
27506 msgin = msgout
27507 request = mp_request_null
27508#endif
27509 CALL mp_timestop(handle)
27510 END SUBROUTINE mp_iallgatherv_zv2
27511
27512! **************************************************************************************************
27513!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
27514!> the issue is with the rank of rcount and rdispl
27515!> \param count ...
27516!> \param array_of_requests ...
27517!> \param array_of_statuses ...
27518!> \param ierr ...
27519!> \author Alfio Lazzaro
27520! **************************************************************************************************
27521#if defined(__parallel)
27522 SUBROUTINE mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
27523 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
27524 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
27525 INTEGER, INTENT(IN) :: rsize
27526 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
27527 CLASS(mp_comm_type), INTENT(IN) :: comm
27528 TYPE(mp_request_type), INTENT(OUT) :: request
27529 INTEGER, INTENT(INOUT) :: ierr
27530
27531 CALL mpi_iallgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
27532 rdispl, mpi_double_complex, comm%handle, request%handle, ierr)
27533
27534 END SUBROUTINE mp_iallgatherv_zv_internal
27535#endif
27536
27537! **************************************************************************************************
27538!> \brief Sums a vector and partitions the result among processes
27539!> \param[in] msgout Data to sum
27540!> \param[out] msgin Received portion of summed data
27541!> \param[in] rcount Partition sizes of the summed data for
27542!> every process
27543!> \param[in] comm Message passing environment identifier
27544! **************************************************************************************************
27545 SUBROUTINE mp_sum_scatter_zv(msgout, msgin, rcount, comm)
27546 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
27547 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
27548 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
27549 CLASS(mp_comm_type), INTENT(IN) :: comm
27550
27551 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_zv'
27552
27553 INTEGER :: handle
27554#if defined(__parallel)
27555 INTEGER :: ierr
27556#endif
27557
27558 CALL mp_timeset(routinen, handle)
27559
27560#if defined(__parallel)
27561 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_double_complex, mpi_sum, &
27562 comm%handle, ierr)
27563 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
27564
27565 CALL add_perf(perf_id=3, count=1, &
27566 msg_size=rcount(1)*2*(2*real_8_size))
27567#else
27568 mark_used(rcount)
27569 mark_used(comm)
27570 msgin = msgout(:, 1)
27571#endif
27572 CALL mp_timestop(handle)
27573 END SUBROUTINE mp_sum_scatter_zv
27574
27575! **************************************************************************************************
27576!> \brief Sends and receives vector data
27577!> \param[in] msgin Data to send
27578!> \param[in] dest Process to send data to
27579!> \param[out] msgout Received data
27580!> \param[in] source Process from which to receive
27581!> \param[in] comm Message passing environment identifier
27582!> \param[in] tag Send and recv tag (default: 0)
27583! **************************************************************************************************
27584 SUBROUTINE mp_sendrecv_z (msgin, dest, msgout, source, comm, tag)
27585 COMPLEX(kind=real_8), INTENT(IN) :: msgin
27586 INTEGER, INTENT(IN) :: dest
27587 COMPLEX(kind=real_8), INTENT(OUT) :: msgout
27588 INTEGER, INTENT(IN) :: source
27589 CLASS(mp_comm_type), INTENT(IN) :: comm
27590 INTEGER, INTENT(IN), OPTIONAL :: tag
27591
27592 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_z'
27593
27594 INTEGER :: handle
27595#if defined(__parallel)
27596 INTEGER :: ierr, msglen_in, msglen_out, &
27597 recv_tag, send_tag
27598#endif
27599
27600 CALL mp_timeset(routinen, handle)
27601
27602#if defined(__parallel)
27603 msglen_in = 1
27604 msglen_out = 1
27605 send_tag = 0 ! cannot think of something better here, this might be dangerous
27606 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27607 IF (PRESENT(tag)) THEN
27608 send_tag = tag
27609 recv_tag = tag
27610 END IF
27611 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27612 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27613 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27614 CALL add_perf(perf_id=7, count=1, &
27615 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27616#else
27617 mark_used(dest)
27618 mark_used(source)
27619 mark_used(comm)
27620 mark_used(tag)
27621 msgout = msgin
27622#endif
27623 CALL mp_timestop(handle)
27624 END SUBROUTINE mp_sendrecv_z
27625
27626! **************************************************************************************************
27627!> \brief Sends and receives vector data
27628!> \param[in] msgin Data to send
27629!> \param[in] dest Process to send data to
27630!> \param[out] msgout Received data
27631!> \param[in] source Process from which to receive
27632!> \param[in] comm Message passing environment identifier
27633!> \param[in] tag Send and recv tag (default: 0)
27634! **************************************************************************************************
27635 SUBROUTINE mp_sendrecv_zv(msgin, dest, msgout, source, comm, tag)
27636 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
27637 INTEGER, INTENT(IN) :: dest
27638 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
27639 INTEGER, INTENT(IN) :: source
27640 CLASS(mp_comm_type), INTENT(IN) :: comm
27641 INTEGER, INTENT(IN), OPTIONAL :: tag
27642
27643 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zv'
27644
27645 INTEGER :: handle
27646#if defined(__parallel)
27647 INTEGER :: ierr, msglen_in, msglen_out, &
27648 recv_tag, send_tag
27649#endif
27650
27651 CALL mp_timeset(routinen, handle)
27652
27653#if defined(__parallel)
27654 msglen_in = SIZE(msgin)
27655 msglen_out = SIZE(msgout)
27656 send_tag = 0 ! cannot think of something better here, this might be dangerous
27657 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27658 IF (PRESENT(tag)) THEN
27659 send_tag = tag
27660 recv_tag = tag
27661 END IF
27662 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27663 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27664 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27665 CALL add_perf(perf_id=7, count=1, &
27666 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27667#else
27668 mark_used(dest)
27669 mark_used(source)
27670 mark_used(comm)
27671 mark_used(tag)
27672 msgout = msgin
27673#endif
27674 CALL mp_timestop(handle)
27675 END SUBROUTINE mp_sendrecv_zv
27676
27677! **************************************************************************************************
27678!> \brief Sends and receives matrix data
27679!> \param msgin ...
27680!> \param dest ...
27681!> \param msgout ...
27682!> \param source ...
27683!> \param comm ...
27684!> \param tag ...
27685!> \note see mp_sendrecv_zv
27686! **************************************************************************************************
27687 SUBROUTINE mp_sendrecv_zm2(msgin, dest, msgout, source, comm, tag)
27688 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
27689 INTEGER, INTENT(IN) :: dest
27690 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
27691 INTEGER, INTENT(IN) :: source
27692 CLASS(mp_comm_type), INTENT(IN) :: comm
27693 INTEGER, INTENT(IN), OPTIONAL :: tag
27694
27695 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm2'
27696
27697 INTEGER :: handle
27698#if defined(__parallel)
27699 INTEGER :: ierr, msglen_in, msglen_out, &
27700 recv_tag, send_tag
27701#endif
27702
27703 CALL mp_timeset(routinen, handle)
27704
27705#if defined(__parallel)
27706 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
27707 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
27708 send_tag = 0 ! cannot think of something better here, this might be dangerous
27709 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27710 IF (PRESENT(tag)) THEN
27711 send_tag = tag
27712 recv_tag = tag
27713 END IF
27714 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27715 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27716 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27717 CALL add_perf(perf_id=7, count=1, &
27718 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27719#else
27720 mark_used(dest)
27721 mark_used(source)
27722 mark_used(comm)
27723 mark_used(tag)
27724 msgout = msgin
27725#endif
27726 CALL mp_timestop(handle)
27727 END SUBROUTINE mp_sendrecv_zm2
27728
27729! **************************************************************************************************
27730!> \brief Sends and receives rank-3 data
27731!> \param msgin ...
27732!> \param dest ...
27733!> \param msgout ...
27734!> \param source ...
27735!> \param comm ...
27736!> \note see mp_sendrecv_zv
27737! **************************************************************************************************
27738 SUBROUTINE mp_sendrecv_zm3(msgin, dest, msgout, source, comm, tag)
27739 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
27740 INTEGER, INTENT(IN) :: dest
27741 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
27742 INTEGER, INTENT(IN) :: source
27743 CLASS(mp_comm_type), INTENT(IN) :: comm
27744 INTEGER, INTENT(IN), OPTIONAL :: tag
27745
27746 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm3'
27747
27748 INTEGER :: handle
27749#if defined(__parallel)
27750 INTEGER :: ierr, msglen_in, msglen_out, &
27751 recv_tag, send_tag
27752#endif
27753
27754 CALL mp_timeset(routinen, handle)
27755
27756#if defined(__parallel)
27757 msglen_in = SIZE(msgin)
27758 msglen_out = SIZE(msgout)
27759 send_tag = 0 ! cannot think of something better here, this might be dangerous
27760 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27761 IF (PRESENT(tag)) THEN
27762 send_tag = tag
27763 recv_tag = tag
27764 END IF
27765 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27766 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27767 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27768 CALL add_perf(perf_id=7, count=1, &
27769 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27770#else
27771 mark_used(dest)
27772 mark_used(source)
27773 mark_used(comm)
27774 mark_used(tag)
27775 msgout = msgin
27776#endif
27777 CALL mp_timestop(handle)
27778 END SUBROUTINE mp_sendrecv_zm3
27779
27780! **************************************************************************************************
27781!> \brief Sends and receives rank-4 data
27782!> \param msgin ...
27783!> \param dest ...
27784!> \param msgout ...
27785!> \param source ...
27786!> \param comm ...
27787!> \note see mp_sendrecv_zv
27788! **************************************************************************************************
27789 SUBROUTINE mp_sendrecv_zm4(msgin, dest, msgout, source, comm, tag)
27790 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
27791 INTEGER, INTENT(IN) :: dest
27792 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
27793 INTEGER, INTENT(IN) :: source
27794 CLASS(mp_comm_type), INTENT(IN) :: comm
27795 INTEGER, INTENT(IN), OPTIONAL :: tag
27796
27797 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm4'
27798
27799 INTEGER :: handle
27800#if defined(__parallel)
27801 INTEGER :: ierr, msglen_in, msglen_out, &
27802 recv_tag, send_tag
27803#endif
27804
27805 CALL mp_timeset(routinen, handle)
27806
27807#if defined(__parallel)
27808 msglen_in = SIZE(msgin)
27809 msglen_out = SIZE(msgout)
27810 send_tag = 0 ! cannot think of something better here, this might be dangerous
27811 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27812 IF (PRESENT(tag)) THEN
27813 send_tag = tag
27814 recv_tag = tag
27815 END IF
27816 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27817 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27818 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27819 CALL add_perf(perf_id=7, count=1, &
27820 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27821#else
27822 mark_used(dest)
27823 mark_used(source)
27824 mark_used(comm)
27825 mark_used(tag)
27826 msgout = msgin
27827#endif
27828 CALL mp_timestop(handle)
27829 END SUBROUTINE mp_sendrecv_zm4
27830
27831! **************************************************************************************************
27832!> \brief Non-blocking send and receive of a scalar
27833!> \param[in] msgin Scalar data to send
27834!> \param[in] dest Which process to send to
27835!> \param[out] msgout Receive data into this pointer
27836!> \param[in] source Process to receive from
27837!> \param[in] comm Message passing environment identifier
27838!> \param[out] send_request Request handle for the send
27839!> \param[out] recv_request Request handle for the receive
27840!> \param[in] tag (optional) tag to differentiate requests
27841!> \par Implementation
27842!> Calls mpi_isend and mpi_irecv.
27843!> \par History
27844!> 02.2005 created [Alfio Lazzaro]
27845! **************************************************************************************************
27846 SUBROUTINE mp_isendrecv_z (msgin, dest, msgout, source, comm, send_request, &
27847 recv_request, tag)
27848 COMPLEX(kind=real_8), INTENT(IN) :: msgin
27849 INTEGER, INTENT(IN) :: dest
27850 COMPLEX(kind=real_8), INTENT(INOUT) :: msgout
27851 INTEGER, INTENT(IN) :: source
27852 CLASS(mp_comm_type), INTENT(IN) :: comm
27853 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
27854 INTEGER, INTENT(in), OPTIONAL :: tag
27855
27856 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_z'
27857
27858 INTEGER :: handle
27859#if defined(__parallel)
27860 INTEGER :: ierr, my_tag
27861#endif
27862
27863 CALL mp_timeset(routinen, handle)
27864
27865#if defined(__parallel)
27866 my_tag = 0
27867 IF (PRESENT(tag)) my_tag = tag
27868
27869 CALL mpi_irecv(msgout, 1, mpi_double_complex, source, my_tag, &
27870 comm%handle, recv_request%handle, ierr)
27871 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27872
27873 CALL mpi_isend(msgin, 1, mpi_double_complex, dest, my_tag, &
27874 comm%handle, send_request%handle, ierr)
27875 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27876
27877 CALL add_perf(perf_id=8, count=1, msg_size=2*(2*real_8_size))
27878#else
27879 mark_used(dest)
27880 mark_used(source)
27881 mark_used(comm)
27882 mark_used(tag)
27883 send_request = mp_request_null
27884 recv_request = mp_request_null
27885 msgout = msgin
27886#endif
27887 CALL mp_timestop(handle)
27888 END SUBROUTINE mp_isendrecv_z
27889
27890! **************************************************************************************************
27891!> \brief Non-blocking send and receive of a vector
27892!> \param[in] msgin Vector data to send
27893!> \param[in] dest Which process to send to
27894!> \param[out] msgout Receive data into this pointer
27895!> \param[in] source Process to receive from
27896!> \param[in] comm Message passing environment identifier
27897!> \param[out] send_request Request handle for the send
27898!> \param[out] recv_request Request handle for the receive
27899!> \param[in] tag (optional) tag to differentiate requests
27900!> \par Implementation
27901!> Calls mpi_isend and mpi_irecv.
27902!> \par History
27903!> 11.2004 created [Joost VandeVondele]
27904!> \note
27905!> arrays can be pointers or assumed shape, but they must be contiguous!
27906! **************************************************************************************************
27907 SUBROUTINE mp_isendrecv_zv(msgin, dest, msgout, source, comm, send_request, &
27908 recv_request, tag)
27909 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
27910 INTEGER, INTENT(IN) :: dest
27911 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
27912 INTEGER, INTENT(IN) :: source
27913 CLASS(mp_comm_type), INTENT(IN) :: comm
27914 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
27915 INTEGER, INTENT(in), OPTIONAL :: tag
27916
27917 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_zv'
27918
27919 INTEGER :: handle
27920#if defined(__parallel)
27921 INTEGER :: ierr, msglen, my_tag
27922 COMPLEX(kind=real_8) :: foo
27923#endif
27924
27925 CALL mp_timeset(routinen, handle)
27926
27927#if defined(__parallel)
27928#if !defined(__GNUC__) || __GNUC__ >= 9
27929 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
27930 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
27931#endif
27932
27933 my_tag = 0
27934 IF (PRESENT(tag)) my_tag = tag
27935
27936 msglen = SIZE(msgout, 1)
27937 IF (msglen > 0) THEN
27938 CALL mpi_irecv(msgout(1), msglen, mpi_double_complex, source, my_tag, &
27939 comm%handle, recv_request%handle, ierr)
27940 ELSE
27941 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27942 comm%handle, recv_request%handle, ierr)
27943 END IF
27944 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27945
27946 msglen = SIZE(msgin, 1)
27947 IF (msglen > 0) THEN
27948 CALL mpi_isend(msgin(1), msglen, mpi_double_complex, dest, my_tag, &
27949 comm%handle, send_request%handle, ierr)
27950 ELSE
27951 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27952 comm%handle, send_request%handle, ierr)
27953 END IF
27954 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27955
27956 msglen = (msglen + SIZE(msgout, 1) + 1)/2
27957 CALL add_perf(perf_id=8, count=1, msg_size=msglen*(2*real_8_size))
27958#else
27959 mark_used(dest)
27960 mark_used(source)
27961 mark_used(comm)
27962 mark_used(tag)
27963 send_request = mp_request_null
27964 recv_request = mp_request_null
27965 msgout = msgin
27966#endif
27967 CALL mp_timestop(handle)
27968 END SUBROUTINE mp_isendrecv_zv
27969
27970! **************************************************************************************************
27971!> \brief Non-blocking send of vector data
27972!> \param msgin ...
27973!> \param dest ...
27974!> \param comm ...
27975!> \param request ...
27976!> \param tag ...
27977!> \par History
27978!> 08.2003 created [f&j]
27979!> \note see mp_isendrecv_zv
27980!> \note
27981!> arrays can be pointers or assumed shape, but they must be contiguous!
27982! **************************************************************************************************
27983 SUBROUTINE mp_isend_zv(msgin, dest, comm, request, tag)
27984 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
27985 INTEGER, INTENT(IN) :: dest
27986 CLASS(mp_comm_type), INTENT(IN) :: comm
27987 TYPE(mp_request_type), INTENT(out) :: request
27988 INTEGER, INTENT(in), OPTIONAL :: tag
27989
27990 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zv'
27991
27992 INTEGER :: handle, ierr
27993#if defined(__parallel)
27994 INTEGER :: msglen, my_tag
27995 COMPLEX(kind=real_8) :: foo(1)
27996#endif
27997
27998 CALL mp_timeset(routinen, handle)
27999
28000#if defined(__parallel)
28001#if !defined(__GNUC__) || __GNUC__ >= 9
28002 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
28003#endif
28004 my_tag = 0
28005 IF (PRESENT(tag)) my_tag = tag
28006
28007 msglen = SIZE(msgin)
28008 IF (msglen > 0) THEN
28009 CALL mpi_isend(msgin(1), msglen, mpi_double_complex, dest, my_tag, &
28010 comm%handle, request%handle, ierr)
28011 ELSE
28012 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
28013 comm%handle, request%handle, ierr)
28014 END IF
28015 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
28016
28017 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
28018#else
28019 mark_used(msgin)
28020 mark_used(dest)
28021 mark_used(comm)
28022 mark_used(request)
28023 mark_used(tag)
28024 ierr = 1
28025 request = mp_request_null
28026 CALL mp_stop(ierr, "mp_isend called in non parallel case")
28027#endif
28028 CALL mp_timestop(handle)
28029 END SUBROUTINE mp_isend_zv
28030
28031! **************************************************************************************************
28032!> \brief Non-blocking send of matrix data
28033!> \param msgin ...
28034!> \param dest ...
28035!> \param comm ...
28036!> \param request ...
28037!> \param tag ...
28038!> \par History
28039!> 2009-11-25 [UB] Made type-generic for templates
28040!> \author fawzi
28041!> \note see mp_isendrecv_zv
28042!> \note see mp_isend_zv
28043!> \note
28044!> arrays can be pointers or assumed shape, but they must be contiguous!
28045! **************************************************************************************************
28046 SUBROUTINE mp_isend_zm2(msgin, dest, comm, request, tag)
28047 COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(IN) :: msgin
28048 INTEGER, INTENT(IN) :: dest
28049 CLASS(mp_comm_type), INTENT(IN) :: comm
28050 TYPE(mp_request_type), INTENT(out) :: request
28051 INTEGER, INTENT(in), OPTIONAL :: tag
28052
28053 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm2'
28054
28055 INTEGER :: handle, ierr
28056#if defined(__parallel)
28057 INTEGER :: msglen, my_tag
28058 COMPLEX(kind=real_8) :: foo(1)
28059#endif
28060
28061 CALL mp_timeset(routinen, handle)
28062
28063#if defined(__parallel)
28064#if !defined(__GNUC__) || __GNUC__ >= 9
28065 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
28066#endif
28067
28068 my_tag = 0
28069 IF (PRESENT(tag)) my_tag = tag
28070
28071 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
28072 IF (msglen > 0) THEN
28073 CALL mpi_isend(msgin(1, 1), msglen, mpi_double_complex, dest, my_tag, &
28074 comm%handle, request%handle, ierr)
28075 ELSE
28076 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
28077 comm%handle, request%handle, ierr)
28078 END IF
28079 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
28080
28081 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
28082#else
28083 mark_used(msgin)
28084 mark_used(dest)
28085 mark_used(comm)
28086 mark_used(request)
28087 mark_used(tag)
28088 ierr = 1
28089 request = mp_request_null
28090 CALL mp_stop(ierr, "mp_isend called in non parallel case")
28091#endif
28092 CALL mp_timestop(handle)
28093 END SUBROUTINE mp_isend_zm2
28094
28095! **************************************************************************************************
28096!> \brief Non-blocking send of rank-3 data
28097!> \param msgin ...
28098!> \param dest ...
28099!> \param comm ...
28100!> \param request ...
28101!> \param tag ...
28102!> \par History
28103!> 9.2008 added _rm3 subroutine [Iain Bethune]
28104!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
28105!> 2009-11-25 [UB] Made type-generic for templates
28106!> \author fawzi
28107!> \note see mp_isendrecv_zv
28108!> \note see mp_isend_zv
28109!> \note
28110!> arrays can be pointers or assumed shape, but they must be contiguous!
28111! **************************************************************************************************
28112 SUBROUTINE mp_isend_zm3(msgin, dest, comm, request, tag)
28113 COMPLEX(kind=real_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
28114 INTEGER, INTENT(IN) :: dest
28115 CLASS(mp_comm_type), INTENT(IN) :: comm
28116 TYPE(mp_request_type), INTENT(out) :: request
28117 INTEGER, INTENT(in), OPTIONAL :: tag
28118
28119 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm3'
28120
28121 INTEGER :: handle, ierr
28122#if defined(__parallel)
28123 INTEGER :: msglen, my_tag
28124 COMPLEX(kind=real_8) :: foo(1)
28125#endif
28126
28127 CALL mp_timeset(routinen, handle)
28128
28129#if defined(__parallel)
28130#if !defined(__GNUC__) || __GNUC__ >= 9
28131 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
28132#endif
28133
28134 my_tag = 0
28135 IF (PRESENT(tag)) my_tag = tag
28136
28137 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
28138 IF (msglen > 0) THEN
28139 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_double_complex, dest, my_tag, &
28140 comm%handle, request%handle, ierr)
28141 ELSE
28142 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
28143 comm%handle, request%handle, ierr)
28144 END IF
28145 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
28146
28147 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
28148#else
28149 mark_used(msgin)
28150 mark_used(dest)
28151 mark_used(comm)
28152 mark_used(request)
28153 mark_used(tag)
28154 ierr = 1
28155 request = mp_request_null
28156 CALL mp_stop(ierr, "mp_isend called in non parallel case")
28157#endif
28158 CALL mp_timestop(handle)
28159 END SUBROUTINE mp_isend_zm3
28160
28161! **************************************************************************************************
28162!> \brief Non-blocking send of rank-4 data
28163!> \param msgin the input message
28164!> \param dest the destination processor
28165!> \param comm the communicator object
28166!> \param request the communication request id
28167!> \param tag the message tag
28168!> \par History
28169!> 2.2016 added _zm4 subroutine [Nico Holmberg]
28170!> \author fawzi
28171!> \note see mp_isend_zv
28172!> \note
28173!> arrays can be pointers or assumed shape, but they must be contiguous!
28174! **************************************************************************************************
28175 SUBROUTINE mp_isend_zm4(msgin, dest, comm, request, tag)
28176 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
28177 INTEGER, INTENT(IN) :: dest
28178 CLASS(mp_comm_type), INTENT(IN) :: comm
28179 TYPE(mp_request_type), INTENT(out) :: request
28180 INTEGER, INTENT(in), OPTIONAL :: tag
28181
28182 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm4'
28183
28184 INTEGER :: handle, ierr
28185#if defined(__parallel)
28186 INTEGER :: msglen, my_tag
28187 COMPLEX(kind=real_8) :: foo(1)
28188#endif
28189
28190 CALL mp_timeset(routinen, handle)
28191
28192#if defined(__parallel)
28193#if !defined(__GNUC__) || __GNUC__ >= 9
28194 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
28195#endif
28196
28197 my_tag = 0
28198 IF (PRESENT(tag)) my_tag = tag
28199
28200 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
28201 IF (msglen > 0) THEN
28202 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_double_complex, dest, my_tag, &
28203 comm%handle, request%handle, ierr)
28204 ELSE
28205 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
28206 comm%handle, request%handle, ierr)
28207 END IF
28208 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
28209
28210 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
28211#else
28212 mark_used(msgin)
28213 mark_used(dest)
28214 mark_used(comm)
28215 mark_used(request)
28216 mark_used(tag)
28217 ierr = 1
28218 request = mp_request_null
28219 CALL mp_stop(ierr, "mp_isend called in non parallel case")
28220#endif
28221 CALL mp_timestop(handle)
28222 END SUBROUTINE mp_isend_zm4
28223
28224! **************************************************************************************************
28225!> \brief Non-blocking receive of vector data
28226!> \param msgout ...
28227!> \param source ...
28228!> \param comm ...
28229!> \param request ...
28230!> \param tag ...
28231!> \par History
28232!> 08.2003 created [f&j]
28233!> 2009-11-25 [UB] Made type-generic for templates
28234!> \note see mp_isendrecv_zv
28235!> \note
28236!> arrays can be pointers or assumed shape, but they must be contiguous!
28237! **************************************************************************************************
28238 SUBROUTINE mp_irecv_zv(msgout, source, comm, request, tag)
28239 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
28240 INTEGER, INTENT(IN) :: source
28241 CLASS(mp_comm_type), INTENT(IN) :: comm
28242 TYPE(mp_request_type), INTENT(out) :: request
28243 INTEGER, INTENT(in), OPTIONAL :: tag
28244
28245 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zv'
28246
28247 INTEGER :: handle
28248#if defined(__parallel)
28249 INTEGER :: ierr, msglen, my_tag
28250 COMPLEX(kind=real_8) :: foo(1)
28251#endif
28252
28253 CALL mp_timeset(routinen, handle)
28254
28255#if defined(__parallel)
28256#if !defined(__GNUC__) || __GNUC__ >= 9
28257 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
28258#endif
28259
28260 my_tag = 0
28261 IF (PRESENT(tag)) my_tag = tag
28262
28263 msglen = SIZE(msgout)
28264 IF (msglen > 0) THEN
28265 CALL mpi_irecv(msgout(1), msglen, mpi_double_complex, source, my_tag, &
28266 comm%handle, request%handle, ierr)
28267 ELSE
28268 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
28269 comm%handle, request%handle, ierr)
28270 END IF
28271 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
28272
28273 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
28274#else
28275 cpabort("mp_irecv called in non parallel case")
28276 mark_used(msgout)
28277 mark_used(source)
28278 mark_used(comm)
28279 mark_used(tag)
28280 request = mp_request_null
28281#endif
28282 CALL mp_timestop(handle)
28283 END SUBROUTINE mp_irecv_zv
28284
28285! **************************************************************************************************
28286!> \brief Non-blocking receive of matrix data
28287!> \param msgout ...
28288!> \param source ...
28289!> \param comm ...
28290!> \param request ...
28291!> \param tag ...
28292!> \par History
28293!> 2009-11-25 [UB] Made type-generic for templates
28294!> \author fawzi
28295!> \note see mp_isendrecv_zv
28296!> \note see mp_irecv_zv
28297!> \note
28298!> arrays can be pointers or assumed shape, but they must be contiguous!
28299! **************************************************************************************************
28300 SUBROUTINE mp_irecv_zm2(msgout, source, comm, request, tag)
28301 COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
28302 INTEGER, INTENT(IN) :: source
28303 CLASS(mp_comm_type), INTENT(IN) :: comm
28304 TYPE(mp_request_type), INTENT(out) :: request
28305 INTEGER, INTENT(in), OPTIONAL :: tag
28306
28307 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm2'
28308
28309 INTEGER :: handle
28310#if defined(__parallel)
28311 INTEGER :: ierr, msglen, my_tag
28312 COMPLEX(kind=real_8) :: foo(1)
28313#endif
28314
28315 CALL mp_timeset(routinen, handle)
28316
28317#if defined(__parallel)
28318#if !defined(__GNUC__) || __GNUC__ >= 9
28319 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
28320#endif
28321
28322 my_tag = 0
28323 IF (PRESENT(tag)) my_tag = tag
28324
28325 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
28326 IF (msglen > 0) THEN
28327 CALL mpi_irecv(msgout(1, 1), msglen, mpi_double_complex, source, my_tag, &
28328 comm%handle, request%handle, ierr)
28329 ELSE
28330 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
28331 comm%handle, request%handle, ierr)
28332 END IF
28333 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
28334
28335 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
28336#else
28337 mark_used(msgout)
28338 mark_used(source)
28339 mark_used(comm)
28340 mark_used(tag)
28341 request = mp_request_null
28342 cpabort("mp_irecv called in non parallel case")
28343#endif
28344 CALL mp_timestop(handle)
28345 END SUBROUTINE mp_irecv_zm2
28346
28347! **************************************************************************************************
28348!> \brief Non-blocking send of rank-3 data
28349!> \param msgout ...
28350!> \param source ...
28351!> \param comm ...
28352!> \param request ...
28353!> \param tag ...
28354!> \par History
28355!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
28356!> 2009-11-25 [UB] Made type-generic for templates
28357!> \author fawzi
28358!> \note see mp_isendrecv_zv
28359!> \note see mp_irecv_zv
28360!> \note
28361!> arrays can be pointers or assumed shape, but they must be contiguous!
28362! **************************************************************************************************
28363 SUBROUTINE mp_irecv_zm3(msgout, source, comm, request, tag)
28364 COMPLEX(kind=real_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
28365 INTEGER, INTENT(IN) :: source
28366 CLASS(mp_comm_type), INTENT(IN) :: comm
28367 TYPE(mp_request_type), INTENT(out) :: request
28368 INTEGER, INTENT(in), OPTIONAL :: tag
28369
28370 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm3'
28371
28372 INTEGER :: handle
28373#if defined(__parallel)
28374 INTEGER :: ierr, msglen, my_tag
28375 COMPLEX(kind=real_8) :: foo(1)
28376#endif
28377
28378 CALL mp_timeset(routinen, handle)
28379
28380#if defined(__parallel)
28381#if !defined(__GNUC__) || __GNUC__ >= 9
28382 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
28383#endif
28384
28385 my_tag = 0
28386 IF (PRESENT(tag)) my_tag = tag
28387
28388 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
28389 IF (msglen > 0) THEN
28390 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_double_complex, source, my_tag, &
28391 comm%handle, request%handle, ierr)
28392 ELSE
28393 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
28394 comm%handle, request%handle, ierr)
28395 END IF
28396 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
28397
28398 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
28399#else
28400 mark_used(msgout)
28401 mark_used(source)
28402 mark_used(comm)
28403 mark_used(tag)
28404 request = mp_request_null
28405 cpabort("mp_irecv called in non parallel case")
28406#endif
28407 CALL mp_timestop(handle)
28408 END SUBROUTINE mp_irecv_zm3
28409
28410! **************************************************************************************************
28411!> \brief Non-blocking receive of rank-4 data
28412!> \param msgout the output message
28413!> \param source the source processor
28414!> \param comm the communicator object
28415!> \param request the communication request id
28416!> \param tag the message tag
28417!> \par History
28418!> 2.2016 added _zm4 subroutine [Nico Holmberg]
28419!> \author fawzi
28420!> \note see mp_irecv_zv
28421!> \note
28422!> arrays can be pointers or assumed shape, but they must be contiguous!
28423! **************************************************************************************************
28424 SUBROUTINE mp_irecv_zm4(msgout, source, comm, request, tag)
28425 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
28426 INTEGER, INTENT(IN) :: source
28427 CLASS(mp_comm_type), INTENT(IN) :: comm
28428 TYPE(mp_request_type), INTENT(out) :: request
28429 INTEGER, INTENT(in), OPTIONAL :: tag
28430
28431 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm4'
28432
28433 INTEGER :: handle
28434#if defined(__parallel)
28435 INTEGER :: ierr, msglen, my_tag
28436 COMPLEX(kind=real_8) :: foo(1)
28437#endif
28438
28439 CALL mp_timeset(routinen, handle)
28440
28441#if defined(__parallel)
28442#if !defined(__GNUC__) || __GNUC__ >= 9
28443 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
28444#endif
28445
28446 my_tag = 0
28447 IF (PRESENT(tag)) my_tag = tag
28448
28449 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
28450 IF (msglen > 0) THEN
28451 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_double_complex, source, my_tag, &
28452 comm%handle, request%handle, ierr)
28453 ELSE
28454 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
28455 comm%handle, request%handle, ierr)
28456 END IF
28457 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
28458
28459 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
28460#else
28461 mark_used(msgout)
28462 mark_used(source)
28463 mark_used(comm)
28464 mark_used(tag)
28465 request = mp_request_null
28466 cpabort("mp_irecv called in non parallel case")
28467#endif
28468 CALL mp_timestop(handle)
28469 END SUBROUTINE mp_irecv_zm4
28470
28471! **************************************************************************************************
28472!> \brief Window initialization function for vector data
28473!> \param base ...
28474!> \param comm ...
28475!> \param win ...
28476!> \par History
28477!> 02.2015 created [Alfio Lazzaro]
28478!> \note
28479!> arrays can be pointers or assumed shape, but they must be contiguous!
28480! **************************************************************************************************
28481 SUBROUTINE mp_win_create_zv(base, comm, win)
28482 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
28483 TYPE(mp_comm_type), INTENT(IN) :: comm
28484 CLASS(mp_win_type), INTENT(INOUT) :: win
28485
28486 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_zv'
28487
28488 INTEGER :: handle
28489#if defined(__parallel)
28490 INTEGER :: ierr
28491 INTEGER(kind=mpi_address_kind) :: len
28492 COMPLEX(kind=real_8) :: foo(1)
28493#endif
28494
28495 CALL mp_timeset(routinen, handle)
28496
28497#if defined(__parallel)
28498
28499 len = SIZE(base)*(2*real_8_size)
28500 IF (len > 0) THEN
28501 CALL mpi_win_create(base(1), len, (2*real_8_size), mpi_info_null, comm%handle, win%handle, ierr)
28502 ELSE
28503 CALL mpi_win_create(foo, len, (2*real_8_size), mpi_info_null, comm%handle, win%handle, ierr)
28504 END IF
28505 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
28506
28507 CALL add_perf(perf_id=20, count=1)
28508#else
28509 mark_used(base)
28510 mark_used(comm)
28511 win%handle = mp_win_null_handle
28512#endif
28513 CALL mp_timestop(handle)
28514 END SUBROUTINE mp_win_create_zv
28515
28516! **************************************************************************************************
28517!> \brief Single-sided get function for vector data
28518!> \param base ...
28519!> \param comm ...
28520!> \param win ...
28521!> \par History
28522!> 02.2015 created [Alfio Lazzaro]
28523!> \note
28524!> arrays can be pointers or assumed shape, but they must be contiguous!
28525! **************************************************************************************************
28526 SUBROUTINE mp_rget_zv(base, source, win, win_data, myproc, disp, request, &
28527 origin_datatype, target_datatype)
28528 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
28529 INTEGER, INTENT(IN) :: source
28530 CLASS(mp_win_type), INTENT(IN) :: win
28531 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: win_data
28532 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
28533 TYPE(mp_request_type), INTENT(OUT) :: request
28534 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
28535
28536 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_zv'
28537
28538 INTEGER :: handle
28539#if defined(__parallel)
28540 INTEGER :: ierr, len, &
28541 origin_len, target_len
28542 LOGICAL :: do_local_copy
28543 INTEGER(kind=mpi_address_kind) :: disp_aint
28544 mpi_data_type :: handle_origin_datatype, handle_target_datatype
28545#endif
28546
28547 CALL mp_timeset(routinen, handle)
28548
28549#if defined(__parallel)
28550 len = SIZE(base)
28551 disp_aint = 0
28552 IF (PRESENT(disp)) THEN
28553 disp_aint = int(disp, kind=mpi_address_kind)
28554 END IF
28555 handle_origin_datatype = mpi_double_complex
28556 origin_len = len
28557 IF (PRESENT(origin_datatype)) THEN
28558 handle_origin_datatype = origin_datatype%type_handle
28559 origin_len = 1
28560 END IF
28561 handle_target_datatype = mpi_double_complex
28562 target_len = len
28563 IF (PRESENT(target_datatype)) THEN
28564 handle_target_datatype = target_datatype%type_handle
28565 target_len = 1
28566 END IF
28567 IF (len > 0) THEN
28568 do_local_copy = .false.
28569 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
28570 IF (myproc .EQ. source) do_local_copy = .true.
28571 END IF
28572 IF (do_local_copy) THEN
28573 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
28574 base(:) = win_data(disp_aint + 1:disp_aint + len)
28575 !$OMP END PARALLEL WORKSHARE
28576 request = mp_request_null
28577 ierr = 0
28578 ELSE
28579 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
28580 target_len, handle_target_datatype, win%handle, request%handle, ierr)
28581 END IF
28582 ELSE
28583 request = mp_request_null
28584 ierr = 0
28585 END IF
28586 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
28587
28588 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*(2*real_8_size))
28589#else
28590 mark_used(source)
28591 mark_used(win)
28592 mark_used(myproc)
28593 mark_used(origin_datatype)
28594 mark_used(target_datatype)
28595
28596 request = mp_request_null
28597 !
28598 IF (PRESENT(disp)) THEN
28599 base(:) = win_data(disp + 1:disp + SIZE(base))
28600 ELSE
28601 base(:) = win_data(:SIZE(base))
28602 END IF
28603
28604#endif
28605 CALL mp_timestop(handle)
28606 END SUBROUTINE mp_rget_zv
28607
28608! **************************************************************************************************
28609!> \brief ...
28610!> \param count ...
28611!> \param lengths ...
28612!> \param displs ...
28613!> \return ...
28614! ***************************************************************************
28615 FUNCTION mp_type_indexed_make_z (count, lengths, displs) &
28616 result(type_descriptor)
28617 INTEGER, INTENT(IN) :: count
28618 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
28619 TYPE(mp_type_descriptor_type) :: type_descriptor
28620
28621 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_z'
28622
28623 INTEGER :: handle
28624#if defined(__parallel)
28625 INTEGER :: ierr
28626#endif
28627
28628 CALL mp_timeset(routinen, handle)
28629
28630#if defined(__parallel)
28631 CALL mpi_type_indexed(count, lengths, displs, mpi_double_complex, &
28632 type_descriptor%type_handle, ierr)
28633 IF (ierr /= 0) &
28634 cpabort("MPI_Type_Indexed @ "//routinen)
28635 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
28636 IF (ierr /= 0) &
28637 cpabort("MPI_Type_commit @ "//routinen)
28638#else
28639 type_descriptor%type_handle = 7
28640#endif
28641 type_descriptor%length = count
28642 NULLIFY (type_descriptor%subtype)
28643 type_descriptor%vector_descriptor(1:2) = 1
28644 type_descriptor%has_indexing = .true.
28645 type_descriptor%index_descriptor%index => lengths
28646 type_descriptor%index_descriptor%chunks => displs
28647
28648 CALL mp_timestop(handle)
28649
28650 END FUNCTION mp_type_indexed_make_z
28651
28652! **************************************************************************************************
28653!> \brief Allocates special parallel memory
28654!> \param[in] DATA pointer to integer array to allocate
28655!> \param[in] len number of integers to allocate
28656!> \param[out] stat (optional) allocation status result
28657!> \author UB
28658! **************************************************************************************************
28659 SUBROUTINE mp_allocate_z (DATA, len, stat)
28660 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
28661 INTEGER, INTENT(IN) :: len
28662 INTEGER, INTENT(OUT), OPTIONAL :: stat
28663
28664 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_z'
28665
28666 INTEGER :: handle, ierr
28667
28668 CALL mp_timeset(routinen, handle)
28669
28670#if defined(__parallel)
28671 NULLIFY (data)
28672 CALL mp_alloc_mem(DATA, len, stat=ierr)
28673 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
28674 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
28675 CALL add_perf(perf_id=15, count=1)
28676#else
28677 ALLOCATE (DATA(len), stat=ierr)
28678 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
28679 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
28680#endif
28681 IF (PRESENT(stat)) stat = ierr
28682 CALL mp_timestop(handle)
28683 END SUBROUTINE mp_allocate_z
28684
28685! **************************************************************************************************
28686!> \brief Deallocates special parallel memory
28687!> \param[in] DATA pointer to special memory to deallocate
28688!> \param stat ...
28689!> \author UB
28690! **************************************************************************************************
28691 SUBROUTINE mp_deallocate_z (DATA, stat)
28692 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
28693 INTEGER, INTENT(OUT), OPTIONAL :: stat
28694
28695 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_z'
28696
28697 INTEGER :: handle
28698#if defined(__parallel)
28699 INTEGER :: ierr
28700#endif
28701
28702 CALL mp_timeset(routinen, handle)
28703
28704#if defined(__parallel)
28705 CALL mp_free_mem(DATA, ierr)
28706 IF (PRESENT(stat)) THEN
28707 stat = ierr
28708 ELSE
28709 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
28710 END IF
28711 NULLIFY (data)
28712 CALL add_perf(perf_id=15, count=1)
28713#else
28714 DEALLOCATE (data)
28715 IF (PRESENT(stat)) stat = 0
28716#endif
28717 CALL mp_timestop(handle)
28718 END SUBROUTINE mp_deallocate_z
28719
28720! **************************************************************************************************
28721!> \brief (parallel) Blocking individual file write using explicit offsets
28722!> (serial) Unformatted stream write
28723!> \param[in] fh file handle (file storage unit)
28724!> \param[in] offset file offset (position)
28725!> \param[in] msg data to be written to the file
28726!> \param msglen ...
28727!> \par MPI-I/O mapping mpi_file_write_at
28728!> \par STREAM-I/O mapping WRITE
28729!> \param[in](optional) msglen number of the elements of data
28730! **************************************************************************************************
28731 SUBROUTINE mp_file_write_at_zv(fh, offset, msg, msglen)
28732 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
28733 CLASS(mp_file_type), INTENT(IN) :: fh
28734 INTEGER, INTENT(IN), OPTIONAL :: msglen
28735 INTEGER(kind=file_offset), INTENT(IN) :: offset
28736
28737 INTEGER :: msg_len
28738#if defined(__parallel)
28739 INTEGER :: ierr
28740#endif
28741
28742 msg_len = SIZE(msg)
28743 IF (PRESENT(msglen)) msg_len = msglen
28744#if defined(__parallel)
28745 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28746 IF (ierr .NE. 0) &
28747 cpabort("mpi_file_write_at_zv @ mp_file_write_at_zv")
28748#else
28749 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28750#endif
28751 END SUBROUTINE mp_file_write_at_zv
28752
28753! **************************************************************************************************
28754!> \brief ...
28755!> \param fh ...
28756!> \param offset ...
28757!> \param msg ...
28758! **************************************************************************************************
28759 SUBROUTINE mp_file_write_at_z (fh, offset, msg)
28760 COMPLEX(kind=real_8), INTENT(IN) :: msg
28761 CLASS(mp_file_type), INTENT(IN) :: fh
28762 INTEGER(kind=file_offset), INTENT(IN) :: offset
28763
28764#if defined(__parallel)
28765 INTEGER :: ierr
28766
28767 ierr = 0
28768 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28769 IF (ierr .NE. 0) &
28770 cpabort("mpi_file_write_at_z @ mp_file_write_at_z")
28771#else
28772 WRITE (unit=fh%handle, pos=offset + 1) msg
28773#endif
28774 END SUBROUTINE mp_file_write_at_z
28775
28776! **************************************************************************************************
28777!> \brief (parallel) Blocking collective file write using explicit offsets
28778!> (serial) Unformatted stream write
28779!> \param fh ...
28780!> \param offset ...
28781!> \param msg ...
28782!> \param msglen ...
28783!> \par MPI-I/O mapping mpi_file_write_at_all
28784!> \par STREAM-I/O mapping WRITE
28785! **************************************************************************************************
28786 SUBROUTINE mp_file_write_at_all_zv(fh, offset, msg, msglen)
28787 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
28788 CLASS(mp_file_type), INTENT(IN) :: fh
28789 INTEGER, INTENT(IN), OPTIONAL :: msglen
28790 INTEGER(kind=file_offset), INTENT(IN) :: offset
28791
28792 INTEGER :: msg_len
28793#if defined(__parallel)
28794 INTEGER :: ierr
28795#endif
28796
28797 msg_len = SIZE(msg)
28798 IF (PRESENT(msglen)) msg_len = msglen
28799#if defined(__parallel)
28800 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28801 IF (ierr .NE. 0) &
28802 cpabort("mpi_file_write_at_all_zv @ mp_file_write_at_all_zv")
28803#else
28804 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28805#endif
28806 END SUBROUTINE mp_file_write_at_all_zv
28807
28808! **************************************************************************************************
28809!> \brief ...
28810!> \param fh ...
28811!> \param offset ...
28812!> \param msg ...
28813! **************************************************************************************************
28814 SUBROUTINE mp_file_write_at_all_z (fh, offset, msg)
28815 COMPLEX(kind=real_8), INTENT(IN) :: msg
28816 CLASS(mp_file_type), INTENT(IN) :: fh
28817 INTEGER(kind=file_offset), INTENT(IN) :: offset
28818
28819#if defined(__parallel)
28820 INTEGER :: ierr
28821
28822 ierr = 0
28823 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28824 IF (ierr .NE. 0) &
28825 cpabort("mpi_file_write_at_all_z @ mp_file_write_at_all_z")
28826#else
28827 WRITE (unit=fh%handle, pos=offset + 1) msg
28828#endif
28829 END SUBROUTINE mp_file_write_at_all_z
28830
28831! **************************************************************************************************
28832!> \brief (parallel) Blocking individual file read using explicit offsets
28833!> (serial) Unformatted stream read
28834!> \param[in] fh file handle (file storage unit)
28835!> \param[in] offset file offset (position)
28836!> \param[out] msg data to be read from the file
28837!> \param msglen ...
28838!> \par MPI-I/O mapping mpi_file_read_at
28839!> \par STREAM-I/O mapping READ
28840!> \param[in](optional) msglen number of elements of data
28841! **************************************************************************************************
28842 SUBROUTINE mp_file_read_at_zv(fh, offset, msg, msglen)
28843 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
28844 CLASS(mp_file_type), INTENT(IN) :: fh
28845 INTEGER, INTENT(IN), OPTIONAL :: msglen
28846 INTEGER(kind=file_offset), INTENT(IN) :: offset
28847
28848 INTEGER :: msg_len
28849#if defined(__parallel)
28850 INTEGER :: ierr
28851#endif
28852
28853 msg_len = SIZE(msg)
28854 IF (PRESENT(msglen)) msg_len = msglen
28855#if defined(__parallel)
28856 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28857 IF (ierr .NE. 0) &
28858 cpabort("mpi_file_read_at_zv @ mp_file_read_at_zv")
28859#else
28860 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28861#endif
28862 END SUBROUTINE mp_file_read_at_zv
28863
28864! **************************************************************************************************
28865!> \brief ...
28866!> \param fh ...
28867!> \param offset ...
28868!> \param msg ...
28869! **************************************************************************************************
28870 SUBROUTINE mp_file_read_at_z (fh, offset, msg)
28871 COMPLEX(kind=real_8), INTENT(OUT) :: msg
28872 CLASS(mp_file_type), INTENT(IN) :: fh
28873 INTEGER(kind=file_offset), INTENT(IN) :: offset
28874
28875#if defined(__parallel)
28876 INTEGER :: ierr
28877
28878 ierr = 0
28879 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28880 IF (ierr .NE. 0) &
28881 cpabort("mpi_file_read_at_z @ mp_file_read_at_z")
28882#else
28883 READ (unit=fh%handle, pos=offset + 1) msg
28884#endif
28885 END SUBROUTINE mp_file_read_at_z
28886
28887! **************************************************************************************************
28888!> \brief (parallel) Blocking collective file read using explicit offsets
28889!> (serial) Unformatted stream read
28890!> \param fh ...
28891!> \param offset ...
28892!> \param msg ...
28893!> \param msglen ...
28894!> \par MPI-I/O mapping mpi_file_read_at_all
28895!> \par STREAM-I/O mapping READ
28896! **************************************************************************************************
28897 SUBROUTINE mp_file_read_at_all_zv(fh, offset, msg, msglen)
28898 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
28899 CLASS(mp_file_type), INTENT(IN) :: fh
28900 INTEGER, INTENT(IN), OPTIONAL :: msglen
28901 INTEGER(kind=file_offset), INTENT(IN) :: offset
28902
28903 INTEGER :: msg_len
28904#if defined(__parallel)
28905 INTEGER :: ierr
28906#endif
28907
28908 msg_len = SIZE(msg)
28909 IF (PRESENT(msglen)) msg_len = msglen
28910#if defined(__parallel)
28911 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28912 IF (ierr .NE. 0) &
28913 cpabort("mpi_file_read_at_all_zv @ mp_file_read_at_all_zv")
28914#else
28915 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28916#endif
28917 END SUBROUTINE mp_file_read_at_all_zv
28918
28919! **************************************************************************************************
28920!> \brief ...
28921!> \param fh ...
28922!> \param offset ...
28923!> \param msg ...
28924! **************************************************************************************************
28925 SUBROUTINE mp_file_read_at_all_z (fh, offset, msg)
28926 COMPLEX(kind=real_8), INTENT(OUT) :: msg
28927 CLASS(mp_file_type), INTENT(IN) :: fh
28928 INTEGER(kind=file_offset), INTENT(IN) :: offset
28929
28930#if defined(__parallel)
28931 INTEGER :: ierr
28932
28933 ierr = 0
28934 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28935 IF (ierr .NE. 0) &
28936 cpabort("mpi_file_read_at_all_z @ mp_file_read_at_all_z")
28937#else
28938 READ (unit=fh%handle, pos=offset + 1) msg
28939#endif
28940 END SUBROUTINE mp_file_read_at_all_z
28941
28942! **************************************************************************************************
28943!> \brief ...
28944!> \param ptr ...
28945!> \param vector_descriptor ...
28946!> \param index_descriptor ...
28947!> \return ...
28948! **************************************************************************************************
28949 FUNCTION mp_type_make_z (ptr, &
28950 vector_descriptor, index_descriptor) &
28951 result(type_descriptor)
28952 COMPLEX(kind=real_8), DIMENSION(:), TARGET, asynchronous :: ptr
28953 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
28954 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
28955 TYPE(mp_type_descriptor_type) :: type_descriptor
28956
28957 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_z'
28958
28959#if defined(__parallel)
28960 INTEGER :: ierr
28961#if defined(__MPI_F08)
28962 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
28963 EXTERNAL :: mpi_get_address
28964#endif
28965#endif
28966
28967 NULLIFY (type_descriptor%subtype)
28968 type_descriptor%length = SIZE(ptr)
28969#if defined(__parallel)
28970 type_descriptor%type_handle = mpi_double_complex
28971 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
28972 IF (ierr /= 0) &
28973 cpabort("MPI_Get_address @ "//routinen)
28974#else
28975 type_descriptor%type_handle = 7
28976#endif
28977 type_descriptor%vector_descriptor(1:2) = 1
28978 type_descriptor%has_indexing = .false.
28979 type_descriptor%data_z => ptr
28980 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
28981 cpabort(routinen//": Vectors and indices NYI")
28982 END IF
28983 END FUNCTION mp_type_make_z
28984
28985! **************************************************************************************************
28986!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
28987!> as the Fortran version returns an integer, which we take to be a C_PTR
28988!> \param DATA data array to allocate
28989!> \param[in] len length (in data elements) of data array allocation
28990!> \param[out] stat (optional) allocation status result
28991! **************************************************************************************************
28992 SUBROUTINE mp_alloc_mem_z (DATA, len, stat)
28993 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: data
28994 INTEGER, INTENT(IN) :: len
28995 INTEGER, INTENT(OUT), OPTIONAL :: stat
28996
28997#if defined(__parallel)
28998 INTEGER :: size, ierr, length, &
28999 mp_res
29000 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
29001 TYPE(c_ptr) :: mp_baseptr
29002 mpi_info_type :: mp_info
29003
29004 length = max(len, 1)
29005 CALL mpi_type_size(mpi_double_complex, size, ierr)
29006 mp_size = int(length, kind=mpi_address_kind)*size
29007 IF (mp_size .GT. mp_max_memory_size) THEN
29008 cpabort("MPI cannot allocate more than 2 GiByte")
29009 END IF
29010 mp_info = mpi_info_null
29011 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
29012 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
29013 IF (PRESENT(stat)) stat = mp_res
29014#else
29015 INTEGER :: length, mystat
29016 length = max(len, 1)
29017 IF (PRESENT(stat)) THEN
29018 ALLOCATE (DATA(length), stat=mystat)
29019 stat = mystat ! show to convention checker that stat is used
29020 ELSE
29021 ALLOCATE (DATA(length))
29022 END IF
29023#endif
29024 END SUBROUTINE mp_alloc_mem_z
29025
29026! **************************************************************************************************
29027!> \brief Deallocates am array, ... this is hackish
29028!> as the Fortran version takes an integer, which we hope to get by reference
29029!> \param DATA data array to allocate
29030!> \param[out] stat (optional) allocation status result
29031! **************************************************************************************************
29032 SUBROUTINE mp_free_mem_z (DATA, stat)
29033 COMPLEX(kind=real_8), DIMENSION(:), &
29034 POINTER, asynchronous :: data
29035 INTEGER, INTENT(OUT), OPTIONAL :: stat
29036
29037#if defined(__parallel)
29038 INTEGER :: mp_res
29039 CALL mpi_free_mem(DATA, mp_res)
29040 IF (PRESENT(stat)) stat = mp_res
29041#else
29042 DEALLOCATE (data)
29043 IF (PRESENT(stat)) stat = 0
29044#endif
29045 END SUBROUTINE mp_free_mem_z
29046! **************************************************************************************************
29047!> \brief Shift around the data in msg
29048!> \param[in,out] msg Rank-2 data to shift
29049!> \param[in] comm message passing environment identifier
29050!> \param[in] displ_in displacements (?)
29051!> \par Example
29052!> msg will be moved from rank to rank+displ_in (in a circular way)
29053!> \par Limitations
29054!> * displ_in will be 1 by default (others not tested)
29055!> * the message array needs to be the same size on all processes
29056! **************************************************************************************************
29057 SUBROUTINE mp_shift_cm(msg, comm, displ_in)
29058
29059 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29060 CLASS(mp_comm_type), INTENT(IN) :: comm
29061 INTEGER, INTENT(IN), OPTIONAL :: displ_in
29062
29063 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_cm'
29064
29065 INTEGER :: handle, ierror
29066#if defined(__parallel)
29067 INTEGER :: displ, left, &
29068 msglen, myrank, nprocs, &
29069 right, tag
29070#endif
29071
29072 ierror = 0
29073 CALL mp_timeset(routinen, handle)
29074
29075#if defined(__parallel)
29076 CALL mpi_comm_rank(comm%handle, myrank, ierror)
29077 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
29078 CALL mpi_comm_size(comm%handle, nprocs, ierror)
29079 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
29080 IF (PRESENT(displ_in)) THEN
29081 displ = displ_in
29082 ELSE
29083 displ = 1
29084 END IF
29085 right = modulo(myrank + displ, nprocs)
29086 left = modulo(myrank - displ, nprocs)
29087 tag = 17
29088 msglen = SIZE(msg)
29089 CALL mpi_sendrecv_replace(msg, msglen, mpi_complex, right, tag, left, tag, &
29090 comm%handle, mpi_status_ignore, ierror)
29091 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
29092 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_4_size))
29093#else
29094 mark_used(msg)
29095 mark_used(comm)
29096 mark_used(displ_in)
29097#endif
29098 CALL mp_timestop(handle)
29099
29100 END SUBROUTINE mp_shift_cm
29101
29102! **************************************************************************************************
29103!> \brief Shift around the data in msg
29104!> \param[in,out] msg Data to shift
29105!> \param[in] comm message passing environment identifier
29106!> \param[in] displ_in displacements (?)
29107!> \par Example
29108!> msg will be moved from rank to rank+displ_in (in a circular way)
29109!> \par Limitations
29110!> * displ_in will be 1 by default (others not tested)
29111!> * the message array needs to be the same size on all processes
29112! **************************************************************************************************
29113 SUBROUTINE mp_shift_c (msg, comm, displ_in)
29114
29115 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29116 CLASS(mp_comm_type), INTENT(IN) :: comm
29117 INTEGER, INTENT(IN), OPTIONAL :: displ_in
29118
29119 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_c'
29120
29121 INTEGER :: handle, ierror
29122#if defined(__parallel)
29123 INTEGER :: displ, left, &
29124 msglen, myrank, nprocs, &
29125 right, tag
29126#endif
29127
29128 ierror = 0
29129 CALL mp_timeset(routinen, handle)
29130
29131#if defined(__parallel)
29132 CALL mpi_comm_rank(comm%handle, myrank, ierror)
29133 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
29134 CALL mpi_comm_size(comm%handle, nprocs, ierror)
29135 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
29136 IF (PRESENT(displ_in)) THEN
29137 displ = displ_in
29138 ELSE
29139 displ = 1
29140 END IF
29141 right = modulo(myrank + displ, nprocs)
29142 left = modulo(myrank - displ, nprocs)
29143 tag = 19
29144 msglen = SIZE(msg)
29145 CALL mpi_sendrecv_replace(msg, msglen, mpi_complex, right, tag, left, &
29146 tag, comm%handle, mpi_status_ignore, ierror)
29147 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
29148 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_4_size))
29149#else
29150 mark_used(msg)
29151 mark_used(comm)
29152 mark_used(displ_in)
29153#endif
29154 CALL mp_timestop(handle)
29155
29156 END SUBROUTINE mp_shift_c
29157
29158! **************************************************************************************************
29159!> \brief All-to-all data exchange, rank-1 data of different sizes
29160!> \param[in] sb Data to send
29161!> \param[in] scount Data counts for data sent to other processes
29162!> \param[in] sdispl Respective data offsets for data sent to process
29163!> \param[in,out] rb Buffer into which to receive data
29164!> \param[in] rcount Data counts for data received from other
29165!> processes
29166!> \param[in] rdispl Respective data offsets for data received from
29167!> other processes
29168!> \param[in] comm Message passing environment identifier
29169!> \par MPI mapping
29170!> mpi_alltoallv
29171!> \par Array sizes
29172!> The scount, rcount, and the sdispl and rdispl arrays have a
29173!> size equal to the number of processes.
29174!> \par Offsets
29175!> Values in sdispl and rdispl start with 0.
29176! **************************************************************************************************
29177 SUBROUTINE mp_alltoall_c11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
29178
29179 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
29180 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
29181 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
29182 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
29183 CLASS(mp_comm_type), INTENT(IN) :: comm
29184
29185 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c11v'
29186
29187 INTEGER :: handle
29188#if defined(__parallel)
29189 INTEGER :: ierr, msglen
29190#else
29191 INTEGER :: i
29192#endif
29193
29194 CALL mp_timeset(routinen, handle)
29195
29196#if defined(__parallel)
29197 CALL mpi_alltoallv(sb, scount, sdispl, mpi_complex, &
29198 rb, rcount, rdispl, mpi_complex, comm%handle, ierr)
29199 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
29200 msglen = sum(scount) + sum(rcount)
29201 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29202#else
29203 mark_used(comm)
29204 mark_used(scount)
29205 mark_used(sdispl)
29206 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
29207 DO i = 1, rcount(1)
29208 rb(rdispl(1) + i) = sb(sdispl(1) + i)
29209 END DO
29210#endif
29211 CALL mp_timestop(handle)
29212
29213 END SUBROUTINE mp_alltoall_c11v
29214
29215! **************************************************************************************************
29216!> \brief All-to-all data exchange, rank-2 data of different sizes
29217!> \param sb ...
29218!> \param scount ...
29219!> \param sdispl ...
29220!> \param rb ...
29221!> \param rcount ...
29222!> \param rdispl ...
29223!> \param comm ...
29224!> \par MPI mapping
29225!> mpi_alltoallv
29226!> \note see mp_alltoall_c11v
29227! **************************************************************************************************
29228 SUBROUTINE mp_alltoall_c22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
29229
29230 COMPLEX(kind=real_4), DIMENSION(:, :), &
29231 INTENT(IN), CONTIGUOUS :: sb
29232 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
29233 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, &
29234 INTENT(INOUT) :: rb
29235 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
29236 CLASS(mp_comm_type), INTENT(IN) :: comm
29237
29238 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c22v'
29239
29240 INTEGER :: handle
29241#if defined(__parallel)
29242 INTEGER :: ierr, msglen
29243#endif
29244
29245 CALL mp_timeset(routinen, handle)
29246
29247#if defined(__parallel)
29248 CALL mpi_alltoallv(sb, scount, sdispl, mpi_complex, &
29249 rb, rcount, rdispl, mpi_complex, comm%handle, ierr)
29250 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
29251 msglen = sum(scount) + sum(rcount)
29252 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*(2*real_4_size))
29253#else
29254 mark_used(comm)
29255 mark_used(scount)
29256 mark_used(sdispl)
29257 mark_used(rcount)
29258 mark_used(rdispl)
29259 rb = sb
29260#endif
29261 CALL mp_timestop(handle)
29262
29263 END SUBROUTINE mp_alltoall_c22v
29264
29265! **************************************************************************************************
29266!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
29267!> \param[in] sb array with data to send
29268!> \param[out] rb array into which data is received
29269!> \param[in] count number of elements to send/receive (product of the
29270!> extents of the first two dimensions)
29271!> \param[in] comm Message passing environment identifier
29272!> \par Index meaning
29273!> \par The first two indices specify the data while the last index counts
29274!> the processes
29275!> \par Sizes of ranks
29276!> All processes have the same data size.
29277!> \par MPI mapping
29278!> mpi_alltoall
29279! **************************************************************************************************
29280 SUBROUTINE mp_alltoall_c (sb, rb, count, comm)
29281
29282 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
29283 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
29284 INTEGER, INTENT(IN) :: count
29285 CLASS(mp_comm_type), INTENT(IN) :: comm
29286
29287 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c'
29288
29289 INTEGER :: handle
29290#if defined(__parallel)
29291 INTEGER :: ierr, msglen, np
29292#endif
29293
29294 CALL mp_timeset(routinen, handle)
29295
29296#if defined(__parallel)
29297 CALL mpi_alltoall(sb, count, mpi_complex, &
29298 rb, count, mpi_complex, comm%handle, ierr)
29299 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29300 CALL mpi_comm_size(comm%handle, np, ierr)
29301 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29302 msglen = 2*count*np
29303 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29304#else
29305 mark_used(count)
29306 mark_used(comm)
29307 rb = sb
29308#endif
29309 CALL mp_timestop(handle)
29310
29311 END SUBROUTINE mp_alltoall_c
29312
29313! **************************************************************************************************
29314!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
29315!> \param sb ...
29316!> \param rb ...
29317!> \param count ...
29318!> \param commp ...
29319!> \note see mp_alltoall_c
29320! **************************************************************************************************
29321 SUBROUTINE mp_alltoall_c22(sb, rb, count, comm)
29322
29323 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
29324 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
29325 INTEGER, INTENT(IN) :: count
29326 CLASS(mp_comm_type), INTENT(IN) :: comm
29327
29328 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c22'
29329
29330 INTEGER :: handle
29331#if defined(__parallel)
29332 INTEGER :: ierr, msglen, np
29333#endif
29334
29335 CALL mp_timeset(routinen, handle)
29336
29337#if defined(__parallel)
29338 CALL mpi_alltoall(sb, count, mpi_complex, &
29339 rb, count, mpi_complex, comm%handle, ierr)
29340 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29341 CALL mpi_comm_size(comm%handle, np, ierr)
29342 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29343 msglen = 2*SIZE(sb)*np
29344 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29345#else
29346 mark_used(count)
29347 mark_used(comm)
29348 rb = sb
29349#endif
29350 CALL mp_timestop(handle)
29351
29352 END SUBROUTINE mp_alltoall_c22
29353
29354! **************************************************************************************************
29355!> \brief All-to-all data exchange, rank-3 data with equal sizes
29356!> \param sb ...
29357!> \param rb ...
29358!> \param count ...
29359!> \param comm ...
29360!> \note see mp_alltoall_c
29361! **************************************************************************************************
29362 SUBROUTINE mp_alltoall_c33(sb, rb, count, comm)
29363
29364 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
29365 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
29366 INTEGER, INTENT(IN) :: count
29367 CLASS(mp_comm_type), INTENT(IN) :: comm
29368
29369 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c33'
29370
29371 INTEGER :: handle
29372#if defined(__parallel)
29373 INTEGER :: ierr, msglen, np
29374#endif
29375
29376 CALL mp_timeset(routinen, handle)
29377
29378#if defined(__parallel)
29379 CALL mpi_alltoall(sb, count, mpi_complex, &
29380 rb, count, mpi_complex, comm%handle, ierr)
29381 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29382 CALL mpi_comm_size(comm%handle, np, ierr)
29383 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29384 msglen = 2*count*np
29385 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29386#else
29387 mark_used(count)
29388 mark_used(comm)
29389 rb = sb
29390#endif
29391 CALL mp_timestop(handle)
29392
29393 END SUBROUTINE mp_alltoall_c33
29394
29395! **************************************************************************************************
29396!> \brief All-to-all data exchange, rank 4 data, equal sizes
29397!> \param sb ...
29398!> \param rb ...
29399!> \param count ...
29400!> \param comm ...
29401!> \note see mp_alltoall_c
29402! **************************************************************************************************
29403 SUBROUTINE mp_alltoall_c44(sb, rb, count, comm)
29404
29405 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29406 INTENT(IN) :: sb
29407 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29408 INTENT(OUT) :: rb
29409 INTEGER, INTENT(IN) :: count
29410 CLASS(mp_comm_type), INTENT(IN) :: comm
29411
29412 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c44'
29413
29414 INTEGER :: handle
29415#if defined(__parallel)
29416 INTEGER :: ierr, msglen, np
29417#endif
29418
29419 CALL mp_timeset(routinen, handle)
29420
29421#if defined(__parallel)
29422 CALL mpi_alltoall(sb, count, mpi_complex, &
29423 rb, count, mpi_complex, comm%handle, ierr)
29424 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29425 CALL mpi_comm_size(comm%handle, np, ierr)
29426 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29427 msglen = 2*count*np
29428 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29429#else
29430 mark_used(count)
29431 mark_used(comm)
29432 rb = sb
29433#endif
29434 CALL mp_timestop(handle)
29435
29436 END SUBROUTINE mp_alltoall_c44
29437
29438! **************************************************************************************************
29439!> \brief All-to-all data exchange, rank 5 data, equal sizes
29440!> \param sb ...
29441!> \param rb ...
29442!> \param count ...
29443!> \param comm ...
29444!> \note see mp_alltoall_c
29445! **************************************************************************************************
29446 SUBROUTINE mp_alltoall_c55(sb, rb, count, comm)
29447
29448 COMPLEX(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
29449 INTENT(IN) :: sb
29450 COMPLEX(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
29451 INTENT(OUT) :: rb
29452 INTEGER, INTENT(IN) :: count
29453 CLASS(mp_comm_type), INTENT(IN) :: comm
29454
29455 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c55'
29456
29457 INTEGER :: handle
29458#if defined(__parallel)
29459 INTEGER :: ierr, msglen, np
29460#endif
29461
29462 CALL mp_timeset(routinen, handle)
29463
29464#if defined(__parallel)
29465 CALL mpi_alltoall(sb, count, mpi_complex, &
29466 rb, count, mpi_complex, comm%handle, ierr)
29467 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29468 CALL mpi_comm_size(comm%handle, np, ierr)
29469 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29470 msglen = 2*count*np
29471 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29472#else
29473 mark_used(count)
29474 mark_used(comm)
29475 rb = sb
29476#endif
29477 CALL mp_timestop(handle)
29478
29479 END SUBROUTINE mp_alltoall_c55
29480
29481! **************************************************************************************************
29482!> \brief All-to-all data exchange, rank-4 data to rank-5 data
29483!> \param sb ...
29484!> \param rb ...
29485!> \param count ...
29486!> \param comm ...
29487!> \note see mp_alltoall_c
29488!> \note User must ensure size consistency.
29489! **************************************************************************************************
29490 SUBROUTINE mp_alltoall_c45(sb, rb, count, comm)
29491
29492 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29493 INTENT(IN) :: sb
29494 COMPLEX(kind=real_4), &
29495 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
29496 INTEGER, INTENT(IN) :: count
29497 CLASS(mp_comm_type), INTENT(IN) :: comm
29498
29499 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c45'
29500
29501 INTEGER :: handle
29502#if defined(__parallel)
29503 INTEGER :: ierr, msglen, np
29504#endif
29505
29506 CALL mp_timeset(routinen, handle)
29507
29508#if defined(__parallel)
29509 CALL mpi_alltoall(sb, count, mpi_complex, &
29510 rb, count, mpi_complex, comm%handle, ierr)
29511 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29512 CALL mpi_comm_size(comm%handle, np, ierr)
29513 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29514 msglen = 2*count*np
29515 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29516#else
29517 mark_used(count)
29518 mark_used(comm)
29519 rb = reshape(sb, shape(rb))
29520#endif
29521 CALL mp_timestop(handle)
29522
29523 END SUBROUTINE mp_alltoall_c45
29524
29525! **************************************************************************************************
29526!> \brief All-to-all data exchange, rank-3 data to rank-4 data
29527!> \param sb ...
29528!> \param rb ...
29529!> \param count ...
29530!> \param comm ...
29531!> \note see mp_alltoall_c
29532!> \note User must ensure size consistency.
29533! **************************************************************************************************
29534 SUBROUTINE mp_alltoall_c34(sb, rb, count, comm)
29535
29536 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, &
29537 INTENT(IN) :: sb
29538 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29539 INTENT(OUT) :: rb
29540 INTEGER, INTENT(IN) :: count
29541 CLASS(mp_comm_type), INTENT(IN) :: comm
29542
29543 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c34'
29544
29545 INTEGER :: handle
29546#if defined(__parallel)
29547 INTEGER :: ierr, msglen, np
29548#endif
29549
29550 CALL mp_timeset(routinen, handle)
29551
29552#if defined(__parallel)
29553 CALL mpi_alltoall(sb, count, mpi_complex, &
29554 rb, count, mpi_complex, comm%handle, ierr)
29555 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29556 CALL mpi_comm_size(comm%handle, np, ierr)
29557 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29558 msglen = 2*count*np
29559 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29560#else
29561 mark_used(count)
29562 mark_used(comm)
29563 rb = reshape(sb, shape(rb))
29564#endif
29565 CALL mp_timestop(handle)
29566
29567 END SUBROUTINE mp_alltoall_c34
29568
29569! **************************************************************************************************
29570!> \brief All-to-all data exchange, rank-5 data to rank-4 data
29571!> \param sb ...
29572!> \param rb ...
29573!> \param count ...
29574!> \param comm ...
29575!> \note see mp_alltoall_c
29576!> \note User must ensure size consistency.
29577! **************************************************************************************************
29578 SUBROUTINE mp_alltoall_c54(sb, rb, count, comm)
29579
29580 COMPLEX(kind=real_4), &
29581 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
29582 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29583 INTENT(OUT) :: rb
29584 INTEGER, INTENT(IN) :: count
29585 CLASS(mp_comm_type), INTENT(IN) :: comm
29586
29587 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c54'
29588
29589 INTEGER :: handle
29590#if defined(__parallel)
29591 INTEGER :: ierr, msglen, np
29592#endif
29593
29594 CALL mp_timeset(routinen, handle)
29595
29596#if defined(__parallel)
29597 CALL mpi_alltoall(sb, count, mpi_complex, &
29598 rb, count, mpi_complex, comm%handle, ierr)
29599 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29600 CALL mpi_comm_size(comm%handle, np, ierr)
29601 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29602 msglen = 2*count*np
29603 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29604#else
29605 mark_used(count)
29606 mark_used(comm)
29607 rb = reshape(sb, shape(rb))
29608#endif
29609 CALL mp_timestop(handle)
29610
29611 END SUBROUTINE mp_alltoall_c54
29612
29613! **************************************************************************************************
29614!> \brief Send one datum to another process
29615!> \param[in] msg Scalar to send
29616!> \param[in] dest Destination process
29617!> \param[in] tag Transfer identifier
29618!> \param[in] comm Message passing environment identifier
29619!> \par MPI mapping
29620!> mpi_send
29621! **************************************************************************************************
29622 SUBROUTINE mp_send_c (msg, dest, tag, comm)
29623 COMPLEX(kind=real_4), INTENT(IN) :: msg
29624 INTEGER, INTENT(IN) :: dest, tag
29625 CLASS(mp_comm_type), INTENT(IN) :: comm
29626
29627 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_c'
29628
29629 INTEGER :: handle
29630#if defined(__parallel)
29631 INTEGER :: ierr, msglen
29632#endif
29633
29634 CALL mp_timeset(routinen, handle)
29635
29636#if defined(__parallel)
29637 msglen = 1
29638 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29639 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29640 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29641#else
29642 mark_used(msg)
29643 mark_used(dest)
29644 mark_used(tag)
29645 mark_used(comm)
29646 ! only defined in parallel
29647 cpabort("not in parallel mode")
29648#endif
29649 CALL mp_timestop(handle)
29650 END SUBROUTINE mp_send_c
29651
29652! **************************************************************************************************
29653!> \brief Send rank-1 data to another process
29654!> \param[in] msg Rank-1 data to send
29655!> \param dest ...
29656!> \param tag ...
29657!> \param comm ...
29658!> \note see mp_send_c
29659! **************************************************************************************************
29660 SUBROUTINE mp_send_cv(msg, dest, tag, comm)
29661 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
29662 INTEGER, INTENT(IN) :: dest, tag
29663 CLASS(mp_comm_type), INTENT(IN) :: comm
29664
29665 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_cv'
29666
29667 INTEGER :: handle
29668#if defined(__parallel)
29669 INTEGER :: ierr, msglen
29670#endif
29671
29672 CALL mp_timeset(routinen, handle)
29673
29674#if defined(__parallel)
29675 msglen = SIZE(msg)
29676 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29677 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29678 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29679#else
29680 mark_used(msg)
29681 mark_used(dest)
29682 mark_used(tag)
29683 mark_used(comm)
29684 ! only defined in parallel
29685 cpabort("not in parallel mode")
29686#endif
29687 CALL mp_timestop(handle)
29688 END SUBROUTINE mp_send_cv
29689
29690! **************************************************************************************************
29691!> \brief Send rank-2 data to another process
29692!> \param[in] msg Rank-2 data to send
29693!> \param dest ...
29694!> \param tag ...
29695!> \param comm ...
29696!> \note see mp_send_c
29697! **************************************************************************************************
29698 SUBROUTINE mp_send_cm2(msg, dest, tag, comm)
29699 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
29700 INTEGER, INTENT(IN) :: dest, tag
29701 CLASS(mp_comm_type), INTENT(IN) :: comm
29702
29703 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_cm2'
29704
29705 INTEGER :: handle
29706#if defined(__parallel)
29707 INTEGER :: ierr, msglen
29708#endif
29709
29710 CALL mp_timeset(routinen, handle)
29711
29712#if defined(__parallel)
29713 msglen = SIZE(msg)
29714 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29715 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29716 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29717#else
29718 mark_used(msg)
29719 mark_used(dest)
29720 mark_used(tag)
29721 mark_used(comm)
29722 ! only defined in parallel
29723 cpabort("not in parallel mode")
29724#endif
29725 CALL mp_timestop(handle)
29726 END SUBROUTINE mp_send_cm2
29727
29728! **************************************************************************************************
29729!> \brief Send rank-3 data to another process
29730!> \param[in] msg Rank-3 data to send
29731!> \param dest ...
29732!> \param tag ...
29733!> \param comm ...
29734!> \note see mp_send_c
29735! **************************************************************************************************
29736 SUBROUTINE mp_send_cm3(msg, dest, tag, comm)
29737 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
29738 INTEGER, INTENT(IN) :: dest, tag
29739 CLASS(mp_comm_type), INTENT(IN) :: comm
29740
29741 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
29742
29743 INTEGER :: handle
29744#if defined(__parallel)
29745 INTEGER :: ierr, msglen
29746#endif
29747
29748 CALL mp_timeset(routinen, handle)
29749
29750#if defined(__parallel)
29751 msglen = SIZE(msg)
29752 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29753 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29754 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29755#else
29756 mark_used(msg)
29757 mark_used(dest)
29758 mark_used(tag)
29759 mark_used(comm)
29760 ! only defined in parallel
29761 cpabort("not in parallel mode")
29762#endif
29763 CALL mp_timestop(handle)
29764 END SUBROUTINE mp_send_cm3
29765
29766! **************************************************************************************************
29767!> \brief Receive one datum from another process
29768!> \param[in,out] msg Place received data into this variable
29769!> \param[in,out] source Process to receive from
29770!> \param[in,out] tag Transfer identifier
29771!> \param[in] comm Message passing environment identifier
29772!> \par MPI mapping
29773!> mpi_send
29774! **************************************************************************************************
29775 SUBROUTINE mp_recv_c (msg, source, tag, comm)
29776 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29777 INTEGER, INTENT(INOUT) :: source, tag
29778 CLASS(mp_comm_type), INTENT(IN) :: comm
29779
29780 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_c'
29781
29782 INTEGER :: handle
29783#if defined(__parallel)
29784 INTEGER :: ierr, msglen
29785 mpi_status_type :: status
29786#endif
29787
29788 CALL mp_timeset(routinen, handle)
29789
29790#if defined(__parallel)
29791 msglen = 1
29792 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29793 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29794 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29795 ELSE
29796 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29797 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29798 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29799 source = status mpi_status_extract(mpi_source)
29800 tag = status mpi_status_extract(mpi_tag)
29801 END IF
29802#else
29803 mark_used(msg)
29804 mark_used(source)
29805 mark_used(tag)
29806 mark_used(comm)
29807 ! only defined in parallel
29808 cpabort("not in parallel mode")
29809#endif
29810 CALL mp_timestop(handle)
29811 END SUBROUTINE mp_recv_c
29812
29813! **************************************************************************************************
29814!> \brief Receive rank-1 data from another process
29815!> \param[in,out] msg Place received data into this rank-1 array
29816!> \param source ...
29817!> \param tag ...
29818!> \param comm ...
29819!> \note see mp_recv_c
29820! **************************************************************************************************
29821 SUBROUTINE mp_recv_cv(msg, source, tag, comm)
29822 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29823 INTEGER, INTENT(INOUT) :: source, tag
29824 CLASS(mp_comm_type), INTENT(IN) :: comm
29825
29826 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cv'
29827
29828 INTEGER :: handle
29829#if defined(__parallel)
29830 INTEGER :: ierr, msglen
29831 mpi_status_type :: status
29832#endif
29833
29834 CALL mp_timeset(routinen, handle)
29835
29836#if defined(__parallel)
29837 msglen = SIZE(msg)
29838 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29839 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29840 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29841 ELSE
29842 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29843 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29844 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29845 source = status mpi_status_extract(mpi_source)
29846 tag = status mpi_status_extract(mpi_tag)
29847 END IF
29848#else
29849 mark_used(msg)
29850 mark_used(source)
29851 mark_used(tag)
29852 mark_used(comm)
29853 ! only defined in parallel
29854 cpabort("not in parallel mode")
29855#endif
29856 CALL mp_timestop(handle)
29857 END SUBROUTINE mp_recv_cv
29858
29859! **************************************************************************************************
29860!> \brief Receive rank-2 data from another process
29861!> \param[in,out] msg Place received data into this rank-2 array
29862!> \param source ...
29863!> \param tag ...
29864!> \param comm ...
29865!> \note see mp_recv_c
29866! **************************************************************************************************
29867 SUBROUTINE mp_recv_cm2(msg, source, tag, comm)
29868 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29869 INTEGER, INTENT(INOUT) :: source, tag
29870 CLASS(mp_comm_type), INTENT(IN) :: comm
29871
29872 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cm2'
29873
29874 INTEGER :: handle
29875#if defined(__parallel)
29876 INTEGER :: ierr, msglen
29877 mpi_status_type :: status
29878#endif
29879
29880 CALL mp_timeset(routinen, handle)
29881
29882#if defined(__parallel)
29883 msglen = SIZE(msg)
29884 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29885 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29886 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29887 ELSE
29888 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29889 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29890 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29891 source = status mpi_status_extract(mpi_source)
29892 tag = status mpi_status_extract(mpi_tag)
29893 END IF
29894#else
29895 mark_used(msg)
29896 mark_used(source)
29897 mark_used(tag)
29898 mark_used(comm)
29899 ! only defined in parallel
29900 cpabort("not in parallel mode")
29901#endif
29902 CALL mp_timestop(handle)
29903 END SUBROUTINE mp_recv_cm2
29904
29905! **************************************************************************************************
29906!> \brief Receive rank-3 data from another process
29907!> \param[in,out] msg Place received data into this rank-3 array
29908!> \param source ...
29909!> \param tag ...
29910!> \param comm ...
29911!> \note see mp_recv_c
29912! **************************************************************************************************
29913 SUBROUTINE mp_recv_cm3(msg, source, tag, comm)
29914 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
29915 INTEGER, INTENT(INOUT) :: source, tag
29916 CLASS(mp_comm_type), INTENT(IN) :: comm
29917
29918 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cm3'
29919
29920 INTEGER :: handle
29921#if defined(__parallel)
29922 INTEGER :: ierr, msglen
29923 mpi_status_type :: status
29924#endif
29925
29926 CALL mp_timeset(routinen, handle)
29927
29928#if defined(__parallel)
29929 msglen = SIZE(msg)
29930 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29931 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29932 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29933 ELSE
29934 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29935 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29936 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29937 source = status mpi_status_extract(mpi_source)
29938 tag = status mpi_status_extract(mpi_tag)
29939 END IF
29940#else
29941 mark_used(msg)
29942 mark_used(source)
29943 mark_used(tag)
29944 mark_used(comm)
29945 ! only defined in parallel
29946 cpabort("not in parallel mode")
29947#endif
29948 CALL mp_timestop(handle)
29949 END SUBROUTINE mp_recv_cm3
29950
29951! **************************************************************************************************
29952!> \brief Broadcasts a datum to all processes.
29953!> \param[in] msg Datum to broadcast
29954!> \param[in] source Processes which broadcasts
29955!> \param[in] comm Message passing environment identifier
29956!> \par MPI mapping
29957!> mpi_bcast
29958! **************************************************************************************************
29959 SUBROUTINE mp_bcast_c (msg, source, comm)
29960 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29961 INTEGER, INTENT(IN) :: source
29962 CLASS(mp_comm_type), INTENT(IN) :: comm
29963
29964 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c'
29965
29966 INTEGER :: handle
29967#if defined(__parallel)
29968 INTEGER :: ierr, msglen
29969#endif
29970
29971 CALL mp_timeset(routinen, handle)
29972
29973#if defined(__parallel)
29974 msglen = 1
29975 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29976 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29977 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29978#else
29979 mark_used(msg)
29980 mark_used(source)
29981 mark_used(comm)
29982#endif
29983 CALL mp_timestop(handle)
29984 END SUBROUTINE mp_bcast_c
29985
29986! **************************************************************************************************
29987!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
29988!> \param[in] msg Datum to broadcast
29989!> \param[in] comm Message passing environment identifier
29990!> \par MPI mapping
29991!> mpi_bcast
29992! **************************************************************************************************
29993 SUBROUTINE mp_bcast_c_src(msg, comm)
29994 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29995 CLASS(mp_comm_type), INTENT(IN) :: comm
29996
29997 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c_src'
29998
29999 INTEGER :: handle
30000#if defined(__parallel)
30001 INTEGER :: ierr, msglen
30002#endif
30003
30004 CALL mp_timeset(routinen, handle)
30005
30006#if defined(__parallel)
30007 msglen = 1
30008 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
30009 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
30010 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
30011#else
30012 mark_used(msg)
30013 mark_used(comm)
30014#endif
30015 CALL mp_timestop(handle)
30016 END SUBROUTINE mp_bcast_c_src
30017
30018! **************************************************************************************************
30019!> \brief Broadcasts a datum to all processes.
30020!> \param[in] msg Datum to broadcast
30021!> \param[in] source Processes which broadcasts
30022!> \param[in] comm Message passing environment identifier
30023!> \par MPI mapping
30024!> mpi_bcast
30025! **************************************************************************************************
30026 SUBROUTINE mp_ibcast_c (msg, source, comm, request)
30027 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30028 INTEGER, INTENT(IN) :: source
30029 CLASS(mp_comm_type), INTENT(IN) :: comm
30030 TYPE(mp_request_type), INTENT(OUT) :: request
30031
30032 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_c'
30033
30034 INTEGER :: handle
30035#if defined(__parallel)
30036 INTEGER :: ierr, msglen
30037#endif
30038
30039 CALL mp_timeset(routinen, handle)
30040
30041#if defined(__parallel)
30042 msglen = 1
30043 CALL mpi_ibcast(msg, msglen, mpi_complex, source, comm%handle, request%handle, ierr)
30044 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
30045 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_4_size))
30046#else
30047 mark_used(msg)
30048 mark_used(source)
30049 mark_used(comm)
30050 request = mp_request_null
30051#endif
30052 CALL mp_timestop(handle)
30053 END SUBROUTINE mp_ibcast_c
30054
30055! **************************************************************************************************
30056!> \brief Broadcasts rank-1 data to all processes
30057!> \param[in] msg Data to broadcast
30058!> \param source ...
30059!> \param comm ...
30060!> \note see mp_bcast_c1
30061! **************************************************************************************************
30062 SUBROUTINE mp_bcast_cv(msg, source, comm)
30063 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30064 INTEGER, INTENT(IN) :: source
30065 CLASS(mp_comm_type), INTENT(IN) :: comm
30066
30067 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cv'
30068
30069 INTEGER :: handle
30070#if defined(__parallel)
30071 INTEGER :: ierr, msglen
30072#endif
30073
30074 CALL mp_timeset(routinen, handle)
30075
30076#if defined(__parallel)
30077 msglen = SIZE(msg)
30078 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
30079 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
30080 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
30081#else
30082 mark_used(msg)
30083 mark_used(source)
30084 mark_used(comm)
30085#endif
30086 CALL mp_timestop(handle)
30087 END SUBROUTINE mp_bcast_cv
30088
30089! **************************************************************************************************
30090!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
30091!> \param[in] msg Data to broadcast
30092!> \param comm ...
30093!> \note see mp_bcast_c1
30094! **************************************************************************************************
30095 SUBROUTINE mp_bcast_cv_src(msg, comm)
30096 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30097 CLASS(mp_comm_type), INTENT(IN) :: comm
30098
30099 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cv_src'
30100
30101 INTEGER :: handle
30102#if defined(__parallel)
30103 INTEGER :: ierr, msglen
30104#endif
30105
30106 CALL mp_timeset(routinen, handle)
30107
30108#if defined(__parallel)
30109 msglen = SIZE(msg)
30110 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
30111 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
30112 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
30113#else
30114 mark_used(msg)
30115 mark_used(comm)
30116#endif
30117 CALL mp_timestop(handle)
30118 END SUBROUTINE mp_bcast_cv_src
30119
30120! **************************************************************************************************
30121!> \brief Broadcasts rank-1 data to all processes
30122!> \param[in] msg Data to broadcast
30123!> \param source ...
30124!> \param comm ...
30125!> \note see mp_bcast_c1
30126! **************************************************************************************************
30127 SUBROUTINE mp_ibcast_cv(msg, source, comm, request)
30128 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
30129 INTEGER, INTENT(IN) :: source
30130 CLASS(mp_comm_type), INTENT(IN) :: comm
30131 TYPE(mp_request_type) :: request
30132
30133 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_cv'
30134
30135 INTEGER :: handle
30136#if defined(__parallel)
30137 INTEGER :: ierr, msglen
30138#endif
30139
30140 CALL mp_timeset(routinen, handle)
30141
30142#if defined(__parallel)
30143#if !defined(__GNUC__) || __GNUC__ >= 9
30144 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
30145#endif
30146 msglen = SIZE(msg)
30147 CALL mpi_ibcast(msg, msglen, mpi_complex, source, comm%handle, request%handle, ierr)
30148 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
30149 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_4_size))
30150#else
30151 mark_used(msg)
30152 mark_used(source)
30153 mark_used(comm)
30154 request = mp_request_null
30155#endif
30156 CALL mp_timestop(handle)
30157 END SUBROUTINE mp_ibcast_cv
30158
30159! **************************************************************************************************
30160!> \brief Broadcasts rank-2 data to all processes
30161!> \param[in] msg Data to broadcast
30162!> \param source ...
30163!> \param comm ...
30164!> \note see mp_bcast_c1
30165! **************************************************************************************************
30166 SUBROUTINE mp_bcast_cm(msg, source, comm)
30167 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30168 INTEGER, INTENT(IN) :: source
30169 CLASS(mp_comm_type), INTENT(IN) :: comm
30170
30171 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cm'
30172
30173 INTEGER :: handle
30174#if defined(__parallel)
30175 INTEGER :: ierr, msglen
30176#endif
30177
30178 CALL mp_timeset(routinen, handle)
30179
30180#if defined(__parallel)
30181 msglen = SIZE(msg)
30182 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
30183 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
30184 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
30185#else
30186 mark_used(msg)
30187 mark_used(source)
30188 mark_used(comm)
30189#endif
30190 CALL mp_timestop(handle)
30191 END SUBROUTINE mp_bcast_cm
30192
30193! **************************************************************************************************
30194!> \brief Broadcasts rank-2 data to all processes
30195!> \param[in] msg Data to broadcast
30196!> \param source ...
30197!> \param comm ...
30198!> \note see mp_bcast_c1
30199! **************************************************************************************************
30200 SUBROUTINE mp_bcast_cm_src(msg, comm)
30201 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30202 CLASS(mp_comm_type), INTENT(IN) :: comm
30203
30204 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cm_src'
30205
30206 INTEGER :: handle
30207#if defined(__parallel)
30208 INTEGER :: ierr, msglen
30209#endif
30210
30211 CALL mp_timeset(routinen, handle)
30212
30213#if defined(__parallel)
30214 msglen = SIZE(msg)
30215 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
30216 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
30217 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
30218#else
30219 mark_used(msg)
30220 mark_used(comm)
30221#endif
30222 CALL mp_timestop(handle)
30223 END SUBROUTINE mp_bcast_cm_src
30224
30225! **************************************************************************************************
30226!> \brief Broadcasts rank-3 data to all processes
30227!> \param[in] msg Data to broadcast
30228!> \param source ...
30229!> \param comm ...
30230!> \note see mp_bcast_c1
30231! **************************************************************************************************
30232 SUBROUTINE mp_bcast_c3(msg, source, comm)
30233 COMPLEX(kind=real_4), CONTIGUOUS :: msg(:, :, :)
30234 INTEGER, INTENT(IN) :: source
30235 CLASS(mp_comm_type), INTENT(IN) :: comm
30236
30237 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c3'
30238
30239 INTEGER :: handle
30240#if defined(__parallel)
30241 INTEGER :: ierr, msglen
30242#endif
30243
30244 CALL mp_timeset(routinen, handle)
30245
30246#if defined(__parallel)
30247 msglen = SIZE(msg)
30248 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
30249 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
30250 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
30251#else
30252 mark_used(msg)
30253 mark_used(source)
30254 mark_used(comm)
30255#endif
30256 CALL mp_timestop(handle)
30257 END SUBROUTINE mp_bcast_c3
30258
30259! **************************************************************************************************
30260!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
30261!> \param[in] msg Data to broadcast
30262!> \param source ...
30263!> \param comm ...
30264!> \note see mp_bcast_c1
30265! **************************************************************************************************
30266 SUBROUTINE mp_bcast_c3_src(msg, comm)
30267 COMPLEX(kind=real_4), CONTIGUOUS :: msg(:, :, :)
30268 CLASS(mp_comm_type), INTENT(IN) :: comm
30269
30270 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c3_src'
30271
30272 INTEGER :: handle
30273#if defined(__parallel)
30274 INTEGER :: ierr, msglen
30275#endif
30276
30277 CALL mp_timeset(routinen, handle)
30278
30279#if defined(__parallel)
30280 msglen = SIZE(msg)
30281 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
30282 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
30283 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
30284#else
30285 mark_used(msg)
30286 mark_used(comm)
30287#endif
30288 CALL mp_timestop(handle)
30289 END SUBROUTINE mp_bcast_c3_src
30290
30291! **************************************************************************************************
30292!> \brief Sums a datum from all processes with result left on all processes.
30293!> \param[in,out] msg Datum to sum (input) and result (output)
30294!> \param[in] comm Message passing environment identifier
30295!> \par MPI mapping
30296!> mpi_allreduce
30297! **************************************************************************************************
30298 SUBROUTINE mp_sum_c (msg, comm)
30299 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30300 CLASS(mp_comm_type), INTENT(IN) :: comm
30301
30302 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_c'
30303
30304 INTEGER :: handle
30305#if defined(__parallel)
30306 INTEGER :: ierr, msglen
30307 COMPLEX(kind=real_4) :: res
30308#endif
30309
30310 CALL mp_timeset(routinen, handle)
30311
30312#if defined(__parallel)
30313 msglen = 1
30314 IF (comm%num_pe > 1) THEN
30315 CALL mpi_allreduce(msg, res, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
30316 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30317 msg = res
30318 END IF
30319 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30320#else
30321 mark_used(msg)
30322 mark_used(comm)
30323#endif
30324 CALL mp_timestop(handle)
30325 END SUBROUTINE mp_sum_c
30326
30327! **************************************************************************************************
30328!> \brief Element-wise sum of a rank-1 array on all processes.
30329!> \param[in,out] msg Vector to sum and result
30330!> \param comm ...
30331!> \note see mp_sum_c
30332! **************************************************************************************************
30333 SUBROUTINE mp_sum_cv(msg, comm)
30334 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30335 CLASS(mp_comm_type), INTENT(IN) :: comm
30336
30337 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cv'
30338
30339 INTEGER :: handle
30340#if defined(__parallel)
30341 INTEGER :: ierr, msglen
30342 COMPLEX(kind=real_4), ALLOCATABLE :: msgbuf(:)
30343#endif
30344
30345 CALL mp_timeset(routinen, handle)
30346
30347#if defined(__parallel)
30348 msglen = SIZE(msg)
30349 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30350 ALLOCATE (msgbuf(msglen))
30351 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
30352 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30353 msg = msgbuf
30354 END IF
30355 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30356#else
30357 mark_used(msg)
30358 mark_used(comm)
30359#endif
30360 CALL mp_timestop(handle)
30361 END SUBROUTINE mp_sum_cv
30362
30363! **************************************************************************************************
30364!> \brief Element-wise sum of a rank-1 array on all processes.
30365!> \param[in,out] msg Vector to sum and result
30366!> \param comm ...
30367!> \note see mp_sum_c
30368! **************************************************************************************************
30369 SUBROUTINE mp_isum_cv(msg, comm, request)
30370 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
30371 CLASS(mp_comm_type), INTENT(IN) :: comm
30372 TYPE(mp_request_type), INTENT(OUT) :: request
30373
30374 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_cv'
30375
30376 INTEGER :: handle
30377#if defined(__parallel)
30378 INTEGER :: ierr, msglen
30379#endif
30380
30381 CALL mp_timeset(routinen, handle)
30382
30383#if defined(__parallel)
30384#if !defined(__GNUC__) || __GNUC__ >= 9
30385 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
30386#endif
30387 msglen = SIZE(msg)
30388 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30389 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, request%handle, ierr)
30390 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
30391 ELSE
30392 request = mp_request_null
30393 END IF
30394 CALL add_perf(perf_id=23, count=1, msg_size=msglen*(2*real_4_size))
30395#else
30396 mark_used(msg)
30397 mark_used(comm)
30398 request = mp_request_null
30399#endif
30400 CALL mp_timestop(handle)
30401 END SUBROUTINE mp_isum_cv
30402
30403! **************************************************************************************************
30404!> \brief Element-wise sum of a rank-2 array on all processes.
30405!> \param[in] msg Matrix to sum and result
30406!> \param comm ...
30407!> \note see mp_sum_c
30408! **************************************************************************************************
30409 SUBROUTINE mp_sum_cm(msg, comm)
30410 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30411 CLASS(mp_comm_type), INTENT(IN) :: comm
30412
30413 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm'
30414
30415 INTEGER :: handle
30416#if defined(__parallel)
30417 INTEGER, PARAMETER :: max_msg = 2**25
30418 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
30419 COMPLEX(kind=real_4), ALLOCATABLE :: msgbuf(:)
30420#endif
30421
30422 CALL mp_timeset(routinen, handle)
30423
30424#if defined(__parallel)
30425 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
30426 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
30427 msglensum = 0
30428 DO m1 = lbound(msg, 2), ubound(msg, 2), step
30429 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
30430 msglensum = msglensum + msglen
30431 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30432 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
30433 ALLOCATE (msgbuf(msglen))
30434 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
30435 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30436 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
30437 DEALLOCATE (msgbuf)
30438 END IF
30439 END DO
30440 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_4_size))
30441#else
30442 mark_used(msg)
30443 mark_used(comm)
30444#endif
30445 CALL mp_timestop(handle)
30446 END SUBROUTINE mp_sum_cm
30447
30448! **************************************************************************************************
30449!> \brief Element-wise sum of a rank-3 array on all processes.
30450!> \param[in] msg Array to sum and result
30451!> \param comm ...
30452!> \note see mp_sum_c
30453! **************************************************************************************************
30454 SUBROUTINE mp_sum_cm3(msg, comm)
30455 COMPLEX(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
30456 CLASS(mp_comm_type), INTENT(IN) :: comm
30457
30458 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm3'
30459
30460 INTEGER :: handle
30461#if defined(__parallel)
30462 INTEGER :: ierr, msglen
30463 COMPLEX(kind=real_4), ALLOCATABLE :: msgbuf(:)
30464#endif
30465
30466 CALL mp_timeset(routinen, handle)
30467
30468#if defined(__parallel)
30469 msglen = SIZE(msg)
30470 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30471 ALLOCATE (msgbuf(msglen))
30472 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
30473 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30474 msg = reshape(msgbuf, shape(msg))
30475 END IF
30476 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30477#else
30478 mark_used(msg)
30479 mark_used(comm)
30480#endif
30481 CALL mp_timestop(handle)
30482 END SUBROUTINE mp_sum_cm3
30483
30484! **************************************************************************************************
30485!> \brief Element-wise sum of a rank-4 array on all processes.
30486!> \param[in] msg Array to sum and result
30487!> \param comm ...
30488!> \note see mp_sum_c
30489! **************************************************************************************************
30490 SUBROUTINE mp_sum_cm4(msg, comm)
30491 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
30492 CLASS(mp_comm_type), INTENT(IN) :: comm
30493
30494 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm4'
30495
30496 INTEGER :: handle
30497#if defined(__parallel)
30498 INTEGER :: ierr, msglen
30499 COMPLEX(kind=real_4), ALLOCATABLE :: msgbuf(:)
30500#endif
30501
30502 CALL mp_timeset(routinen, handle)
30503
30504#if defined(__parallel)
30505 msglen = SIZE(msg)
30506 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30507 ALLOCATE (msgbuf(msglen))
30508 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
30509 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30510 msg = reshape(msgbuf, shape(msg))
30511 END IF
30512 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30513#else
30514 mark_used(msg)
30515 mark_used(comm)
30516#endif
30517 CALL mp_timestop(handle)
30518 END SUBROUTINE mp_sum_cm4
30519
30520! **************************************************************************************************
30521!> \brief Element-wise sum of data from all processes with result left only on
30522!> one.
30523!> \param[in,out] msg Vector to sum (input) and (only on process root)
30524!> result (output)
30525!> \param root ...
30526!> \param[in] comm Message passing environment identifier
30527!> \par MPI mapping
30528!> mpi_reduce
30529! **************************************************************************************************
30530 SUBROUTINE mp_sum_root_cv(msg, root, comm)
30531 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30532 INTEGER, INTENT(IN) :: root
30533 CLASS(mp_comm_type), INTENT(IN) :: comm
30534
30535 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_cv'
30536
30537 INTEGER :: handle
30538#if defined(__parallel)
30539 INTEGER :: ierr, m1, msglen, taskid
30540 COMPLEX(kind=real_4), ALLOCATABLE :: res(:)
30541#endif
30542
30543 CALL mp_timeset(routinen, handle)
30544
30545#if defined(__parallel)
30546 msglen = SIZE(msg)
30547 CALL mpi_comm_rank(comm%handle, taskid, ierr)
30548 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
30549 IF (msglen > 0) THEN
30550 m1 = SIZE(msg, 1)
30551 ALLOCATE (res(m1))
30552 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_sum, &
30553 root, comm%handle, ierr)
30554 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30555 IF (taskid == root) THEN
30556 msg = res
30557 END IF
30558 DEALLOCATE (res)
30559 END IF
30560 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30561#else
30562 mark_used(msg)
30563 mark_used(root)
30564 mark_used(comm)
30565#endif
30566 CALL mp_timestop(handle)
30567 END SUBROUTINE mp_sum_root_cv
30568
30569! **************************************************************************************************
30570!> \brief Element-wise sum of data from all processes with result left only on
30571!> one.
30572!> \param[in,out] msg Matrix to sum (input) and (only on process root)
30573!> result (output)
30574!> \param root ...
30575!> \param comm ...
30576!> \note see mp_sum_root_cv
30577! **************************************************************************************************
30578 SUBROUTINE mp_sum_root_cm(msg, root, comm)
30579 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30580 INTEGER, INTENT(IN) :: root
30581 CLASS(mp_comm_type), INTENT(IN) :: comm
30582
30583 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
30584
30585 INTEGER :: handle
30586#if defined(__parallel)
30587 INTEGER :: ierr, m1, m2, msglen, taskid
30588 COMPLEX(kind=real_4), ALLOCATABLE :: res(:, :)
30589#endif
30590
30591 CALL mp_timeset(routinen, handle)
30592
30593#if defined(__parallel)
30594 msglen = SIZE(msg)
30595 CALL mpi_comm_rank(comm%handle, taskid, ierr)
30596 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
30597 IF (msglen > 0) THEN
30598 m1 = SIZE(msg, 1)
30599 m2 = SIZE(msg, 2)
30600 ALLOCATE (res(m1, m2))
30601 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_sum, root, comm%handle, ierr)
30602 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30603 IF (taskid == root) THEN
30604 msg = res
30605 END IF
30606 DEALLOCATE (res)
30607 END IF
30608 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30609#else
30610 mark_used(root)
30611 mark_used(msg)
30612 mark_used(comm)
30613#endif
30614 CALL mp_timestop(handle)
30615 END SUBROUTINE mp_sum_root_cm
30616
30617! **************************************************************************************************
30618!> \brief Partial sum of data from all processes with result on each process.
30619!> \param[in] msg Matrix to sum (input)
30620!> \param[out] res Matrix containing result (output)
30621!> \param[in] comm Message passing environment identifier
30622! **************************************************************************************************
30623 SUBROUTINE mp_sum_partial_cm(msg, res, comm)
30624 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30625 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
30626 CLASS(mp_comm_type), INTENT(IN) :: comm
30627
30628 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_cm'
30629
30630 INTEGER :: handle
30631#if defined(__parallel)
30632 INTEGER :: ierr, msglen, taskid
30633#endif
30634
30635 CALL mp_timeset(routinen, handle)
30636
30637#if defined(__parallel)
30638 msglen = SIZE(msg)
30639 CALL mpi_comm_rank(comm%handle, taskid, ierr)
30640 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
30641 IF (msglen > 0) THEN
30642 CALL mpi_scan(msg, res, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
30643 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
30644 END IF
30645 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30646 ! perf_id is same as for other summation routines
30647#else
30648 res = msg
30649 mark_used(comm)
30650#endif
30651 CALL mp_timestop(handle)
30652 END SUBROUTINE mp_sum_partial_cm
30653
30654! **************************************************************************************************
30655!> \brief Finds the maximum of a datum with the result left on all processes.
30656!> \param[in,out] msg Find maximum among these data (input) and
30657!> maximum (output)
30658!> \param[in] comm Message passing environment identifier
30659!> \par MPI mapping
30660!> mpi_allreduce
30661! **************************************************************************************************
30662 SUBROUTINE mp_max_c (msg, comm)
30663 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30664 CLASS(mp_comm_type), INTENT(IN) :: comm
30665
30666 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_c'
30667
30668 INTEGER :: handle
30669#if defined(__parallel)
30670 INTEGER :: ierr, msglen
30671 COMPLEX(kind=real_4) :: res
30672#endif
30673
30674 CALL mp_timeset(routinen, handle)
30675
30676#if defined(__parallel)
30677 msglen = 1
30678 IF (comm%num_pe > 1) THEN
30679 CALL mpi_allreduce(msg, res, msglen, mpi_complex, mpi_max, comm%handle, ierr)
30680 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30681 msg = res
30682 END IF
30683 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30684#else
30685 mark_used(msg)
30686 mark_used(comm)
30687#endif
30688 CALL mp_timestop(handle)
30689 END SUBROUTINE mp_max_c
30690
30691! **************************************************************************************************
30692!> \brief Finds the maximum of a datum with the result left on all processes.
30693!> \param[in,out] msg Find maximum among these data (input) and
30694!> maximum (output)
30695!> \param[in] comm Message passing environment identifier
30696!> \par MPI mapping
30697!> mpi_allreduce
30698! **************************************************************************************************
30699 SUBROUTINE mp_max_root_c (msg, root, comm)
30700 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30701 INTEGER, INTENT(IN) :: root
30702 CLASS(mp_comm_type), INTENT(IN) :: comm
30703
30704 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_c'
30705
30706 INTEGER :: handle
30707#if defined(__parallel)
30708 INTEGER :: ierr, msglen
30709 COMPLEX(kind=real_4) :: res
30710#endif
30711
30712 CALL mp_timeset(routinen, handle)
30713
30714#if defined(__parallel)
30715 msglen = 1
30716 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_max, root, comm%handle, ierr)
30717 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30718 IF (root == comm%mepos) msg = res
30719 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30720#else
30721 mark_used(msg)
30722 mark_used(comm)
30723 mark_used(root)
30724#endif
30725 CALL mp_timestop(handle)
30726 END SUBROUTINE mp_max_root_c
30727
30728! **************************************************************************************************
30729!> \brief Finds the element-wise maximum of a vector with the result left on
30730!> all processes.
30731!> \param[in,out] msg Find maximum among these data (input) and
30732!> maximum (output)
30733!> \param comm ...
30734!> \note see mp_max_c
30735! **************************************************************************************************
30736 SUBROUTINE mp_max_cv(msg, comm)
30737 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30738 CLASS(mp_comm_type), INTENT(IN) :: comm
30739
30740 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_cv'
30741
30742 INTEGER :: handle
30743#if defined(__parallel)
30744 INTEGER :: ierr, msglen
30745 COMPLEX(kind=real_4), ALLOCATABLE :: msgbuf(:)
30746#endif
30747
30748 CALL mp_timeset(routinen, handle)
30749
30750#if defined(__parallel)
30751 msglen = SIZE(msg)
30752 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30753 ALLOCATE (msgbuf(msglen))
30754 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_complex, mpi_max, comm%handle, ierr)
30755 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30756 msg = msgbuf
30757 END IF
30758 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30759#else
30760 mark_used(msg)
30761 mark_used(comm)
30762#endif
30763 CALL mp_timestop(handle)
30764 END SUBROUTINE mp_max_cv
30765
30766! **************************************************************************************************
30767!> \brief Finds the element-wise maximum of a rank2-array with the result left on
30768!> all processes.
30769!> \param[in] msg Matrix - Find maximum among these data (input) and
30770!> maximum (output)
30771!> \param comm ...
30772!> \note see mp_max_c
30773! **************************************************************************************************
30774 SUBROUTINE mp_max_cm(msg, comm)
30775 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30776 CLASS(mp_comm_type), INTENT(IN) :: comm
30777
30778 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_cm'
30779
30780 INTEGER :: handle
30781#if defined(__parallel)
30782 INTEGER, PARAMETER :: max_msg = 2**25
30783 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
30784 COMPLEX(kind=real_4), ALLOCATABLE :: msgbuf(:)
30785#endif
30786
30787 CALL mp_timeset(routinen, handle)
30788
30789#if defined(__parallel)
30790 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
30791 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
30792 msglensum = 0
30793 DO m1 = lbound(msg, 2), ubound(msg, 2), step
30794 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
30795 msglensum = msglensum + msglen
30796 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30797 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
30798 ALLOCATE (msgbuf(msglen))
30799 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_complex, mpi_max, comm%handle, ierr)
30800 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30801 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
30802 DEALLOCATE (msgbuf)
30803 END IF
30804 END DO
30805 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_4_size))
30806#else
30807 mark_used(msg)
30808 mark_used(comm)
30809#endif
30810 CALL mp_timestop(handle)
30811 END SUBROUTINE mp_max_cm
30812
30813! **************************************************************************************************
30814!> \brief Finds the element-wise maximum of a vector with the result left on
30815!> all processes.
30816!> \param[in,out] msg Find maximum among these data (input) and
30817!> maximum (output)
30818!> \param comm ...
30819!> \note see mp_max_c
30820! **************************************************************************************************
30821 SUBROUTINE mp_max_root_cm(msg, root, comm)
30822 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30823 INTEGER :: root
30824 CLASS(mp_comm_type), INTENT(IN) :: comm
30825
30826 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_cm'
30827
30828 INTEGER :: handle
30829#if defined(__parallel)
30830 INTEGER :: ierr, msglen
30831 COMPLEX(kind=real_4) :: res(size(msg, 1), size(msg, 2))
30832#endif
30833
30834 CALL mp_timeset(routinen, handle)
30835
30836#if defined(__parallel)
30837 msglen = SIZE(msg)
30838 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_max, root, comm%handle, ierr)
30839 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30840 IF (root == comm%mepos) msg = res
30841 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30842#else
30843 mark_used(msg)
30844 mark_used(comm)
30845 mark_used(root)
30846#endif
30847 CALL mp_timestop(handle)
30848 END SUBROUTINE mp_max_root_cm
30849
30850! **************************************************************************************************
30851!> \brief Finds the minimum of a datum with the result left on all processes.
30852!> \param[in,out] msg Find minimum among these data (input) and
30853!> maximum (output)
30854!> \param[in] comm Message passing environment identifier
30855!> \par MPI mapping
30856!> mpi_allreduce
30857! **************************************************************************************************
30858 SUBROUTINE mp_min_c (msg, comm)
30859 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30860 CLASS(mp_comm_type), INTENT(IN) :: comm
30861
30862 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_c'
30863
30864 INTEGER :: handle
30865#if defined(__parallel)
30866 INTEGER :: ierr, msglen
30867 COMPLEX(kind=real_4) :: res
30868#endif
30869
30870 CALL mp_timeset(routinen, handle)
30871
30872#if defined(__parallel)
30873 msglen = 1
30874 IF (comm%num_pe > 1) THEN
30875 CALL mpi_allreduce(msg, res, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30876 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30877 msg = res
30878 END IF
30879 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30880#else
30881 mark_used(msg)
30882 mark_used(comm)
30883#endif
30884 CALL mp_timestop(handle)
30885 END SUBROUTINE mp_min_c
30886
30887! **************************************************************************************************
30888!> \brief Finds the element-wise minimum of vector with the result left on
30889!> all processes.
30890!> \param[in,out] msg Find minimum among these data (input) and
30891!> maximum (output)
30892!> \param comm ...
30893!> \par MPI mapping
30894!> mpi_allreduce
30895!> \note see mp_min_c
30896! **************************************************************************************************
30897 SUBROUTINE mp_min_cv(msg, comm)
30898 COMPLEX(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
30899 CLASS(mp_comm_type), INTENT(IN) :: comm
30900
30901 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_cv'
30902
30903 INTEGER :: handle
30904#if defined(__parallel)
30905 INTEGER :: ierr, msglen
30906 COMPLEX(kind=real_4), ALLOCATABLE :: msgbuf(:)
30907#endif
30908
30909 CALL mp_timeset(routinen, handle)
30910
30911#if defined(__parallel)
30912 msglen = SIZE(msg)
30913 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30914 ALLOCATE (msgbuf(msglen))
30915 CALL mpi_allreduce(msg, msgbuf, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30916 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30917 msg = msgbuf
30918 END IF
30919 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30920#else
30921 mark_used(msg)
30922 mark_used(comm)
30923#endif
30924 CALL mp_timestop(handle)
30925 END SUBROUTINE mp_min_cv
30926
30927! **************************************************************************************************
30928!> \brief Finds the element-wise minimum of a rank2-array with the result left on
30929!> all processes.
30930!> \param[in] msg Matrix - Find maximum among these data (input) and
30931!> minimum (output)
30932!> \param comm ...
30933!> \note see mp_min_c
30934! **************************************************************************************************
30935 SUBROUTINE mp_min_cm(msg, comm)
30936 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30937 CLASS(mp_comm_type), INTENT(IN) :: comm
30938
30939 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_cm'
30940
30941 INTEGER :: handle
30942#if defined(__parallel)
30943 INTEGER, PARAMETER :: max_msg = 2**25
30944 INTEGER :: ierr, m1, msglen, ncols, step, msglensum
30945 COMPLEX(kind=real_4), ALLOCATABLE :: msgbuf(:)
30946#endif
30947
30948 CALL mp_timeset(routinen, handle)
30949
30950#if defined(__parallel)
30951 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
30952 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
30953 msglensum = 0
30954 DO m1 = lbound(msg, 2), ubound(msg, 2), step
30955 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
30956 msglensum = msglensum + msglen
30957 IF (msglen > 0 .AND. comm%num_pe > 1) THEN
30958 ncols = min(ubound(msg, 2), m1 + step - 1) - m1 + 1
30959 ALLOCATE (msgbuf(msglen))
30960 CALL mpi_allreduce(msg(lbound(msg, 1), m1), msgbuf, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30961 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30962 msg(:, m1:m1 + ncols - 1) = reshape(msgbuf, [SIZE(msg, 1), ncols])
30963 DEALLOCATE (msgbuf)
30964 END IF
30965 END DO
30966 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_4_size))
30967#else
30968 mark_used(msg)
30969 mark_used(comm)
30970#endif
30971 CALL mp_timestop(handle)
30972 END SUBROUTINE mp_min_cm
30973
30974! **************************************************************************************************
30975!> \brief Multiplies a set of numbers scattered across a number of processes,
30976!> then replicates the result.
30977!> \param[in,out] msg a number to multiply (input) and result (output)
30978!> \param[in] comm message passing environment identifier
30979!> \par MPI mapping
30980!> mpi_allreduce
30981! **************************************************************************************************
30982 SUBROUTINE mp_prod_c (msg, comm)
30983 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30984 CLASS(mp_comm_type), INTENT(IN) :: comm
30985
30986 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_c'
30987
30988 INTEGER :: handle
30989#if defined(__parallel)
30990 INTEGER :: ierr, msglen
30991 COMPLEX(kind=real_4) :: res
30992#endif
30993
30994 CALL mp_timeset(routinen, handle)
30995
30996#if defined(__parallel)
30997 msglen = 1
30998 IF (comm%num_pe > 1) THEN
30999 CALL mpi_allreduce(msg, res, msglen, mpi_complex, mpi_prod, comm%handle, ierr)
31000 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
31001 msg = res
31002 END IF
31003 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
31004#else
31005 mark_used(msg)
31006 mark_used(comm)
31007#endif
31008 CALL mp_timestop(handle)
31009 END SUBROUTINE mp_prod_c
31010
31011! **************************************************************************************************
31012!> \brief Scatters data from one processes to all others
31013!> \param[in] msg_scatter Data to scatter (for root process)
31014!> \param[out] msg Received data
31015!> \param[in] root Process which scatters data
31016!> \param[in] comm Message passing environment identifier
31017!> \par MPI mapping
31018!> mpi_scatter
31019! **************************************************************************************************
31020 SUBROUTINE mp_scatter_cv(msg_scatter, msg, root, comm)
31021 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
31022 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
31023 INTEGER, INTENT(IN) :: root
31024 CLASS(mp_comm_type), INTENT(IN) :: comm
31025
31026 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_cv'
31027
31028 INTEGER :: handle
31029#if defined(__parallel)
31030 INTEGER :: ierr, msglen
31031#endif
31032
31033 CALL mp_timeset(routinen, handle)
31034
31035#if defined(__parallel)
31036 msglen = SIZE(msg)
31037 CALL mpi_scatter(msg_scatter, msglen, mpi_complex, msg, &
31038 msglen, mpi_complex, root, comm%handle, ierr)
31039 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
31040 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
31041#else
31042 mark_used(root)
31043 mark_used(comm)
31044 msg = msg_scatter
31045#endif
31046 CALL mp_timestop(handle)
31047 END SUBROUTINE mp_scatter_cv
31048
31049! **************************************************************************************************
31050!> \brief Scatters data from one processes to all others
31051!> \param[in] msg_scatter Data to scatter (for root process)
31052!> \param[in] root Process which scatters data
31053!> \param[in] comm Message passing environment identifier
31054!> \par MPI mapping
31055!> mpi_scatter
31056! **************************************************************************************************
31057 SUBROUTINE mp_iscatter_c (msg_scatter, msg, root, comm, request)
31058 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:)
31059 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
31060 INTEGER, INTENT(IN) :: root
31061 CLASS(mp_comm_type), INTENT(IN) :: comm
31062 TYPE(mp_request_type), INTENT(OUT) :: request
31063
31064 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_c'
31065
31066 INTEGER :: handle
31067#if defined(__parallel)
31068 INTEGER :: ierr, msglen
31069#endif
31070
31071 CALL mp_timeset(routinen, handle)
31072
31073#if defined(__parallel)
31074#if !defined(__GNUC__) || __GNUC__ >= 9
31075 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
31076#endif
31077 msglen = 1
31078 CALL mpi_iscatter(msg_scatter, msglen, mpi_complex, msg, &
31079 msglen, mpi_complex, root, comm%handle, request%handle, ierr)
31080 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
31081 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
31082#else
31083 mark_used(root)
31084 mark_used(comm)
31085 msg = msg_scatter(1)
31086 request = mp_request_null
31087#endif
31088 CALL mp_timestop(handle)
31089 END SUBROUTINE mp_iscatter_c
31090
31091! **************************************************************************************************
31092!> \brief Scatters data from one processes to all others
31093!> \param[in] msg_scatter Data to scatter (for root process)
31094!> \param[in] root Process which scatters data
31095!> \param[in] comm Message passing environment identifier
31096!> \par MPI mapping
31097!> mpi_scatter
31098! **************************************************************************************************
31099 SUBROUTINE mp_iscatter_cv2(msg_scatter, msg, root, comm, request)
31100 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:, :)
31101 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
31102 INTEGER, INTENT(IN) :: root
31103 CLASS(mp_comm_type), INTENT(IN) :: comm
31104 TYPE(mp_request_type), INTENT(OUT) :: request
31105
31106 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_cv2'
31107
31108 INTEGER :: handle
31109#if defined(__parallel)
31110 INTEGER :: ierr, msglen
31111#endif
31112
31113 CALL mp_timeset(routinen, handle)
31114
31115#if defined(__parallel)
31116#if !defined(__GNUC__) || __GNUC__ >= 9
31117 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
31118#endif
31119 msglen = SIZE(msg)
31120 CALL mpi_iscatter(msg_scatter, msglen, mpi_complex, msg, &
31121 msglen, mpi_complex, root, comm%handle, request%handle, ierr)
31122 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
31123 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
31124#else
31125 mark_used(root)
31126 mark_used(comm)
31127 msg(:) = msg_scatter(:, 1)
31128 request = mp_request_null
31129#endif
31130 CALL mp_timestop(handle)
31131 END SUBROUTINE mp_iscatter_cv2
31132
31133! **************************************************************************************************
31134!> \brief Scatters data from one processes to all others
31135!> \param[in] msg_scatter Data to scatter (for root process)
31136!> \param[in] root Process which scatters data
31137!> \param[in] comm Message passing environment identifier
31138!> \par MPI mapping
31139!> mpi_scatter
31140! **************************************************************************************************
31141 SUBROUTINE mp_iscatterv_cv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
31142 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:)
31143 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
31144 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
31145 INTEGER, INTENT(IN) :: recvcount, root
31146 CLASS(mp_comm_type), INTENT(IN) :: comm
31147 TYPE(mp_request_type), INTENT(OUT) :: request
31148
31149 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_cv'
31150
31151 INTEGER :: handle
31152#if defined(__parallel)
31153 INTEGER :: ierr
31154#endif
31155
31156 CALL mp_timeset(routinen, handle)
31157
31158#if defined(__parallel)
31159#if !defined(__GNUC__) || __GNUC__ >= 9
31160 cpassert(is_contiguous(msg_scatter) .OR. SIZE(msg_scatter) == 0)
31161 cpassert(is_contiguous(msg) .OR. SIZE(msg) == 0)
31162 cpassert(is_contiguous(sendcounts) .OR. SIZE(sendcounts) == 0)
31163 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
31164#endif
31165 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_complex, msg, &
31166 recvcount, mpi_complex, root, comm%handle, request%handle, ierr)
31167 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
31168 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
31169#else
31170 mark_used(sendcounts)
31171 mark_used(displs)
31172 mark_used(recvcount)
31173 mark_used(root)
31174 mark_used(comm)
31175 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
31176 request = mp_request_null
31177#endif
31178 CALL mp_timestop(handle)
31179 END SUBROUTINE mp_iscatterv_cv
31180
31181! **************************************************************************************************
31182!> \brief Gathers a datum from all processes to one
31183!> \param[in] msg Datum to send to root
31184!> \param[out] msg_gather Received data (on root)
31185!> \param[in] root Process which gathers the data
31186!> \param[in] comm Message passing environment identifier
31187!> \par MPI mapping
31188!> mpi_gather
31189! **************************************************************************************************
31190 SUBROUTINE mp_gather_c (msg, msg_gather, root, comm)
31191 COMPLEX(kind=real_4), INTENT(IN) :: msg
31192 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
31193 INTEGER, INTENT(IN) :: root
31194 CLASS(mp_comm_type), INTENT(IN) :: comm
31195
31196 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_c'
31197
31198 INTEGER :: handle
31199#if defined(__parallel)
31200 INTEGER :: ierr, msglen
31201#endif
31202
31203 CALL mp_timeset(routinen, handle)
31204
31205#if defined(__parallel)
31206 msglen = 1
31207 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
31208 msglen, mpi_complex, root, comm%handle, ierr)
31209 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
31210 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
31211#else
31212 mark_used(root)
31213 mark_used(comm)
31214 msg_gather(1) = msg
31215#endif
31216 CALL mp_timestop(handle)
31217 END SUBROUTINE mp_gather_c
31218
31219! **************************************************************************************************
31220!> \brief Gathers a datum from all processes to one, uses the source process of comm
31221!> \param[in] msg Datum to send to root
31222!> \param[out] msg_gather Received data (on root)
31223!> \param[in] comm Message passing environment identifier
31224!> \par MPI mapping
31225!> mpi_gather
31226! **************************************************************************************************
31227 SUBROUTINE mp_gather_c_src(msg, msg_gather, comm)
31228 COMPLEX(kind=real_4), INTENT(IN) :: msg
31229 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
31230 CLASS(mp_comm_type), INTENT(IN) :: comm
31231
31232 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_c_src'
31233
31234 INTEGER :: handle
31235#if defined(__parallel)
31236 INTEGER :: ierr, msglen
31237#endif
31238
31239 CALL mp_timeset(routinen, handle)
31240
31241#if defined(__parallel)
31242 msglen = 1
31243 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
31244 msglen, mpi_complex, comm%source, comm%handle, ierr)
31245 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
31246 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
31247#else
31248 mark_used(comm)
31249 msg_gather(1) = msg
31250#endif
31251 CALL mp_timestop(handle)
31252 END SUBROUTINE mp_gather_c_src
31253
31254! **************************************************************************************************
31255!> \brief Gathers data from all processes to one
31256!> \param[in] msg Datum to send to root
31257!> \param msg_gather ...
31258!> \param root ...
31259!> \param comm ...
31260!> \par Data length
31261!> All data (msg) is equal-sized
31262!> \par MPI mapping
31263!> mpi_gather
31264!> \note see mp_gather_c
31265! **************************************************************************************************
31266 SUBROUTINE mp_gather_cv(msg, msg_gather, root, comm)
31267 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
31268 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
31269 INTEGER, INTENT(IN) :: root
31270 CLASS(mp_comm_type), INTENT(IN) :: comm
31271
31272 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cv'
31273
31274 INTEGER :: handle
31275#if defined(__parallel)
31276 INTEGER :: ierr, msglen
31277#endif
31278
31279 CALL mp_timeset(routinen, handle)
31280
31281#if defined(__parallel)
31282 msglen = SIZE(msg)
31283 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
31284 msglen, mpi_complex, root, comm%handle, ierr)
31285 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
31286 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
31287#else
31288 mark_used(root)
31289 mark_used(comm)
31290 msg_gather = msg
31291#endif
31292 CALL mp_timestop(handle)
31293 END SUBROUTINE mp_gather_cv
31294
31295! **************************************************************************************************
31296!> \brief Gathers data from all processes to one. Gathers from comm%source
31297!> \param[in] msg Datum to send to root
31298!> \param msg_gather ...
31299!> \param comm ...
31300!> \par Data length
31301!> All data (msg) is equal-sized
31302!> \par MPI mapping
31303!> mpi_gather
31304!> \note see mp_gather_c
31305! **************************************************************************************************
31306 SUBROUTINE mp_gather_cv_src(msg, msg_gather, comm)
31307 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
31308 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
31309 CLASS(mp_comm_type), INTENT(IN) :: comm
31310
31311 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cv_src'
31312
31313 INTEGER :: handle
31314#if defined(__parallel)
31315 INTEGER :: ierr, msglen
31316#endif
31317
31318 CALL mp_timeset(routinen, handle)
31319
31320#if defined(__parallel)
31321 msglen = SIZE(msg)
31322 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
31323 msglen, mpi_complex, comm%source, comm%handle, ierr)
31324 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
31325 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
31326#else
31327 mark_used(comm)
31328 msg_gather = msg
31329#endif
31330 CALL mp_timestop(handle)
31331 END SUBROUTINE mp_gather_cv_src
31332
31333! **************************************************************************************************
31334!> \brief Gathers data from all processes to one
31335!> \param[in] msg Datum to send to root
31336!> \param msg_gather ...
31337!> \param root ...
31338!> \param comm ...
31339!> \par Data length
31340!> All data (msg) is equal-sized
31341!> \par MPI mapping
31342!> mpi_gather
31343!> \note see mp_gather_c
31344! **************************************************************************************************
31345 SUBROUTINE mp_gather_cm(msg, msg_gather, root, comm)
31346 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
31347 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
31348 INTEGER, INTENT(IN) :: root
31349 CLASS(mp_comm_type), INTENT(IN) :: comm
31350
31351 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cm'
31352
31353 INTEGER :: handle
31354#if defined(__parallel)
31355 INTEGER :: ierr, msglen
31356#endif
31357
31358 CALL mp_timeset(routinen, handle)
31359
31360#if defined(__parallel)
31361 msglen = SIZE(msg)
31362 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
31363 msglen, mpi_complex, root, comm%handle, ierr)
31364 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
31365 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
31366#else
31367 mark_used(root)
31368 mark_used(comm)
31369 msg_gather = msg
31370#endif
31371 CALL mp_timestop(handle)
31372 END SUBROUTINE mp_gather_cm
31373
31374! **************************************************************************************************
31375!> \brief Gathers data from all processes to one. Gathers from comm%source
31376!> \param[in] msg Datum to send to root
31377!> \param msg_gather ...
31378!> \param comm ...
31379!> \par Data length
31380!> All data (msg) is equal-sized
31381!> \par MPI mapping
31382!> mpi_gather
31383!> \note see mp_gather_c
31384! **************************************************************************************************
31385 SUBROUTINE mp_gather_cm_src(msg, msg_gather, comm)
31386 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
31387 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
31388 CLASS(mp_comm_type), INTENT(IN) :: comm
31389
31390 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cm_src'
31391
31392 INTEGER :: handle
31393#if defined(__parallel)
31394 INTEGER :: ierr, msglen
31395#endif
31396
31397 CALL mp_timeset(routinen, handle)
31398
31399#if defined(__parallel)
31400 msglen = SIZE(msg)
31401 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
31402 msglen, mpi_complex, comm%source, comm%handle, ierr)
31403 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
31404 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
31405#else
31406 mark_used(comm)
31407 msg_gather = msg
31408#endif
31409 CALL mp_timestop(handle)
31410 END SUBROUTINE mp_gather_cm_src
31411
31412! **************************************************************************************************
31413!> \brief Gathers data from all processes to one.
31414!> \param[in] sendbuf Data to send to root
31415!> \param[out] recvbuf Received data (on root)
31416!> \param[in] recvcounts Sizes of data received from processes
31417!> \param[in] displs Offsets of data received from processes
31418!> \param[in] root Process which gathers the data
31419!> \param[in] comm Message passing environment identifier
31420!> \par Data length
31421!> Data can have different lengths
31422!> \par Offsets
31423!> Offsets start at 0
31424!> \par MPI mapping
31425!> mpi_gather
31426! **************************************************************************************************
31427 SUBROUTINE mp_gatherv_cv(sendbuf, recvbuf, recvcounts, displs, root, comm)
31428
31429 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
31430 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
31431 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
31432 INTEGER, INTENT(IN) :: root
31433 CLASS(mp_comm_type), INTENT(IN) :: comm
31434
31435 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cv'
31436
31437 INTEGER :: handle
31438#if defined(__parallel)
31439 INTEGER :: ierr, sendcount
31440#endif
31441
31442 CALL mp_timeset(routinen, handle)
31443
31444#if defined(__parallel)
31445 sendcount = SIZE(sendbuf)
31446 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
31447 recvbuf, recvcounts, displs, mpi_complex, &
31448 root, comm%handle, ierr)
31449 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
31450 CALL add_perf(perf_id=4, &
31451 count=1, &
31452 msg_size=sendcount*(2*real_4_size))
31453#else
31454 mark_used(recvcounts)
31455 mark_used(root)
31456 mark_used(comm)
31457 recvbuf(1 + displs(1):) = sendbuf
31458#endif
31459 CALL mp_timestop(handle)
31460 END SUBROUTINE mp_gatherv_cv
31461
31462! **************************************************************************************************
31463!> \brief Gathers data from all processes to one. Gathers from comm%source
31464!> \param[in] sendbuf Data to send to root
31465!> \param[out] recvbuf Received data (on root)
31466!> \param[in] recvcounts Sizes of data received from processes
31467!> \param[in] displs Offsets of data received from processes
31468!> \param[in] comm Message passing environment identifier
31469!> \par Data length
31470!> Data can have different lengths
31471!> \par Offsets
31472!> Offsets start at 0
31473!> \par MPI mapping
31474!> mpi_gather
31475! **************************************************************************************************
31476 SUBROUTINE mp_gatherv_cv_src(sendbuf, recvbuf, recvcounts, displs, comm)
31477
31478 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
31479 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
31480 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
31481 CLASS(mp_comm_type), INTENT(IN) :: comm
31482
31483 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cv_src'
31484
31485 INTEGER :: handle
31486#if defined(__parallel)
31487 INTEGER :: ierr, sendcount
31488#endif
31489
31490 CALL mp_timeset(routinen, handle)
31491
31492#if defined(__parallel)
31493 sendcount = SIZE(sendbuf)
31494 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
31495 recvbuf, recvcounts, displs, mpi_complex, &
31496 comm%source, comm%handle, ierr)
31497 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
31498 CALL add_perf(perf_id=4, &
31499 count=1, &
31500 msg_size=sendcount*(2*real_4_size))
31501#else
31502 mark_used(recvcounts)
31503 mark_used(comm)
31504 recvbuf(1 + displs(1):) = sendbuf
31505#endif
31506 CALL mp_timestop(handle)
31507 END SUBROUTINE mp_gatherv_cv_src
31508
31509! **************************************************************************************************
31510!> \brief Gathers data from all processes to one.
31511!> \param[in] sendbuf Data to send to root
31512!> \param[out] recvbuf Received data (on root)
31513!> \param[in] recvcounts Sizes of data received from processes
31514!> \param[in] displs Offsets of data received from processes
31515!> \param[in] root Process which gathers the data
31516!> \param[in] comm Message passing environment identifier
31517!> \par Data length
31518!> Data can have different lengths
31519!> \par Offsets
31520!> Offsets start at 0
31521!> \par MPI mapping
31522!> mpi_gather
31523! **************************************************************************************************
31524 SUBROUTINE mp_gatherv_cm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
31525
31526 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
31527 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
31528 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
31529 INTEGER, INTENT(IN) :: root
31530 CLASS(mp_comm_type), INTENT(IN) :: comm
31531
31532 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cm2'
31533
31534 INTEGER :: handle
31535#if defined(__parallel)
31536 INTEGER :: ierr, sendcount
31537#endif
31538
31539 CALL mp_timeset(routinen, handle)
31540
31541#if defined(__parallel)
31542 sendcount = SIZE(sendbuf)
31543 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
31544 recvbuf, recvcounts, displs, mpi_complex, &
31545 root, comm%handle, ierr)
31546 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
31547 CALL add_perf(perf_id=4, &
31548 count=1, &
31549 msg_size=sendcount*(2*real_4_size))
31550#else
31551 mark_used(recvcounts)
31552 mark_used(root)
31553 mark_used(comm)
31554 recvbuf(:, 1 + displs(1):) = sendbuf
31555#endif
31556 CALL mp_timestop(handle)
31557 END SUBROUTINE mp_gatherv_cm2
31558
31559! **************************************************************************************************
31560!> \brief Gathers data from all processes to one.
31561!> \param[in] sendbuf Data to send to root
31562!> \param[out] recvbuf Received data (on root)
31563!> \param[in] recvcounts Sizes of data received from processes
31564!> \param[in] displs Offsets of data received from processes
31565!> \param[in] comm Message passing environment identifier
31566!> \par Data length
31567!> Data can have different lengths
31568!> \par Offsets
31569!> Offsets start at 0
31570!> \par MPI mapping
31571!> mpi_gather
31572! **************************************************************************************************
31573 SUBROUTINE mp_gatherv_cm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
31574
31575 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
31576 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
31577 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
31578 CLASS(mp_comm_type), INTENT(IN) :: comm
31579
31580 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cm2_src'
31581
31582 INTEGER :: handle
31583#if defined(__parallel)
31584 INTEGER :: ierr, sendcount
31585#endif
31586
31587 CALL mp_timeset(routinen, handle)
31588
31589#if defined(__parallel)
31590 sendcount = SIZE(sendbuf)
31591 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
31592 recvbuf, recvcounts, displs, mpi_complex, &
31593 comm%source, comm%handle, ierr)
31594 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
31595 CALL add_perf(perf_id=4, &
31596 count=1, &
31597 msg_size=sendcount*(2*real_4_size))
31598#else
31599 mark_used(recvcounts)
31600 mark_used(comm)
31601 recvbuf(:, 1 + displs(1):) = sendbuf
31602#endif
31603 CALL mp_timestop(handle)
31604 END SUBROUTINE mp_gatherv_cm2_src
31605
31606! **************************************************************************************************
31607!> \brief Gathers data from all processes to one.
31608!> \param[in] sendbuf Data to send to root
31609!> \param[out] recvbuf Received data (on root)
31610!> \param[in] recvcounts Sizes of data received from processes
31611!> \param[in] displs Offsets of data received from processes
31612!> \param[in] root Process which gathers the data
31613!> \param[in] comm Message passing environment identifier
31614!> \par Data length
31615!> Data can have different lengths
31616!> \par Offsets
31617!> Offsets start at 0
31618!> \par MPI mapping
31619!> mpi_gather
31620! **************************************************************************************************
31621 SUBROUTINE mp_igatherv_cv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
31622 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: sendbuf
31623 COMPLEX(kind=real_4), DIMENSION(:), INTENT(OUT) :: recvbuf
31624 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
31625 INTEGER, INTENT(IN) :: sendcount, root
31626 CLASS(mp_comm_type), INTENT(IN) :: comm
31627 TYPE(mp_request_type), INTENT(OUT) :: request
31628
31629 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_cv'
31630
31631 INTEGER :: handle
31632#if defined(__parallel)
31633 INTEGER :: ierr
31634#endif
31635
31636 CALL mp_timeset(routinen, handle)
31637
31638#if defined(__parallel)
31639#if !defined(__GNUC__) || __GNUC__ >= 9
31640 cpassert(is_contiguous(sendbuf) .OR. SIZE(sendbuf) == 0)
31641 cpassert(is_contiguous(recvbuf) .OR. SIZE(recvbuf) == 0)
31642 cpassert(is_contiguous(recvcounts) .OR. SIZE(recvcounts) == 0)
31643 cpassert(is_contiguous(displs) .OR. SIZE(displs) == 0)
31644#endif
31645 CALL mpi_igatherv(sendbuf, sendcount, mpi_complex, &
31646 recvbuf, recvcounts, displs, mpi_complex, &
31647 root, comm%handle, request%handle, ierr)
31648 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
31649 CALL add_perf(perf_id=24, &
31650 count=1, &
31651 msg_size=sendcount*(2*real_4_size))
31652#else
31653 mark_used(sendcount)
31654 mark_used(recvcounts)
31655 mark_used(root)
31656 mark_used(comm)
31657 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
31658 request = mp_request_null
31659#endif
31660 CALL mp_timestop(handle)
31661 END SUBROUTINE mp_igatherv_cv
31662
31663! **************************************************************************************************
31664!> \brief Gathers a datum from all processes and all processes receive the
31665!> same data
31666!> \param[in] msgout Datum to send
31667!> \param[out] msgin Received data
31668!> \param[in] comm Message passing environment identifier
31669!> \par Data size
31670!> All processes send equal-sized data
31671!> \par MPI mapping
31672!> mpi_allgather
31673! **************************************************************************************************
31674 SUBROUTINE mp_allgather_c (msgout, msgin, comm)
31675 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31676 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
31677 CLASS(mp_comm_type), INTENT(IN) :: comm
31678
31679 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c'
31680
31681 INTEGER :: handle
31682#if defined(__parallel)
31683 INTEGER :: ierr, rcount, scount
31684#endif
31685
31686 CALL mp_timeset(routinen, handle)
31687
31688#if defined(__parallel)
31689 scount = 1
31690 rcount = 1
31691 CALL mpi_allgather(msgout, scount, mpi_complex, &
31692 msgin, rcount, mpi_complex, &
31693 comm%handle, ierr)
31694 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31695#else
31696 mark_used(comm)
31697 msgin = msgout
31698#endif
31699 CALL mp_timestop(handle)
31700 END SUBROUTINE mp_allgather_c
31701
31702! **************************************************************************************************
31703!> \brief Gathers a datum from all processes and all processes receive the
31704!> same data
31705!> \param[in] msgout Datum to send
31706!> \param[out] msgin Received data
31707!> \param[in] comm Message passing environment identifier
31708!> \par Data size
31709!> All processes send equal-sized data
31710!> \par MPI mapping
31711!> mpi_allgather
31712! **************************************************************************************************
31713 SUBROUTINE mp_allgather_c2(msgout, msgin, comm)
31714 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31715 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31716 CLASS(mp_comm_type), INTENT(IN) :: comm
31717
31718 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c2'
31719
31720 INTEGER :: handle
31721#if defined(__parallel)
31722 INTEGER :: ierr, rcount, scount
31723#endif
31724
31725 CALL mp_timeset(routinen, handle)
31726
31727#if defined(__parallel)
31728 scount = 1
31729 rcount = 1
31730 CALL mpi_allgather(msgout, scount, mpi_complex, &
31731 msgin, rcount, mpi_complex, &
31732 comm%handle, ierr)
31733 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31734#else
31735 mark_used(comm)
31736 msgin = msgout
31737#endif
31738 CALL mp_timestop(handle)
31739 END SUBROUTINE mp_allgather_c2
31740
31741! **************************************************************************************************
31742!> \brief Gathers a datum from all processes and all processes receive the
31743!> same data
31744!> \param[in] msgout Datum to send
31745!> \param[out] msgin Received data
31746!> \param[in] comm Message passing environment identifier
31747!> \par Data size
31748!> All processes send equal-sized data
31749!> \par MPI mapping
31750!> mpi_allgather
31751! **************************************************************************************************
31752 SUBROUTINE mp_iallgather_c (msgout, msgin, comm, request)
31753 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31754 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31755 CLASS(mp_comm_type), INTENT(IN) :: comm
31756 TYPE(mp_request_type), INTENT(OUT) :: request
31757
31758 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c'
31759
31760 INTEGER :: handle
31761#if defined(__parallel)
31762 INTEGER :: ierr, rcount, scount
31763#endif
31764
31765 CALL mp_timeset(routinen, handle)
31766
31767#if defined(__parallel)
31768#if !defined(__GNUC__) || __GNUC__ >= 9
31769 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
31770#endif
31771 scount = 1
31772 rcount = 1
31773 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31774 msgin, rcount, mpi_complex, &
31775 comm%handle, request%handle, ierr)
31776 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31777#else
31778 mark_used(comm)
31779 msgin = msgout
31780 request = mp_request_null
31781#endif
31782 CALL mp_timestop(handle)
31783 END SUBROUTINE mp_iallgather_c
31784
31785! **************************************************************************************************
31786!> \brief Gathers vector data from all processes and all processes receive the
31787!> same data
31788!> \param[in] msgout Rank-1 data to send
31789!> \param[out] msgin Received data
31790!> \param[in] comm Message passing environment identifier
31791!> \par Data size
31792!> All processes send equal-sized data
31793!> \par Ranks
31794!> The last rank counts the processes
31795!> \par MPI mapping
31796!> mpi_allgather
31797! **************************************************************************************************
31798 SUBROUTINE mp_allgather_c12(msgout, msgin, comm)
31799 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:)
31800 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31801 CLASS(mp_comm_type), INTENT(IN) :: comm
31802
31803 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c12'
31804
31805 INTEGER :: handle
31806#if defined(__parallel)
31807 INTEGER :: ierr, rcount, scount
31808#endif
31809
31810 CALL mp_timeset(routinen, handle)
31811
31812#if defined(__parallel)
31813 scount = SIZE(msgout(:))
31814 rcount = scount
31815 CALL mpi_allgather(msgout, scount, mpi_complex, &
31816 msgin, rcount, mpi_complex, &
31817 comm%handle, ierr)
31818 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31819#else
31820 mark_used(comm)
31821 msgin(:, 1) = msgout(:)
31822#endif
31823 CALL mp_timestop(handle)
31824 END SUBROUTINE mp_allgather_c12
31825
31826! **************************************************************************************************
31827!> \brief Gathers matrix data from all processes and all processes receive the
31828!> same data
31829!> \param[in] msgout Rank-2 data to send
31830!> \param msgin ...
31831!> \param comm ...
31832!> \note see mp_allgather_c12
31833! **************************************************************************************************
31834 SUBROUTINE mp_allgather_c23(msgout, msgin, comm)
31835 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
31836 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
31837 CLASS(mp_comm_type), INTENT(IN) :: comm
31838
31839 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c23'
31840
31841 INTEGER :: handle
31842#if defined(__parallel)
31843 INTEGER :: ierr, rcount, scount
31844#endif
31845
31846 CALL mp_timeset(routinen, handle)
31847
31848#if defined(__parallel)
31849 scount = SIZE(msgout(:, :))
31850 rcount = scount
31851 CALL mpi_allgather(msgout, scount, mpi_complex, &
31852 msgin, rcount, mpi_complex, &
31853 comm%handle, ierr)
31854 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31855#else
31856 mark_used(comm)
31857 msgin(:, :, 1) = msgout(:, :)
31858#endif
31859 CALL mp_timestop(handle)
31860 END SUBROUTINE mp_allgather_c23
31861
31862! **************************************************************************************************
31863!> \brief Gathers rank-3 data from all processes and all processes receive the
31864!> same data
31865!> \param[in] msgout Rank-3 data to send
31866!> \param msgin ...
31867!> \param comm ...
31868!> \note see mp_allgather_c12
31869! **************************************************************************************************
31870 SUBROUTINE mp_allgather_c34(msgout, msgin, comm)
31871 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
31872 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
31873 CLASS(mp_comm_type), INTENT(IN) :: comm
31874
31875 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c34'
31876
31877 INTEGER :: handle
31878#if defined(__parallel)
31879 INTEGER :: ierr, rcount, scount
31880#endif
31881
31882 CALL mp_timeset(routinen, handle)
31883
31884#if defined(__parallel)
31885 scount = SIZE(msgout(:, :, :))
31886 rcount = scount
31887 CALL mpi_allgather(msgout, scount, mpi_complex, &
31888 msgin, rcount, mpi_complex, &
31889 comm%handle, ierr)
31890 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31891#else
31892 mark_used(comm)
31893 msgin(:, :, :, 1) = msgout(:, :, :)
31894#endif
31895 CALL mp_timestop(handle)
31896 END SUBROUTINE mp_allgather_c34
31897
31898! **************************************************************************************************
31899!> \brief Gathers rank-2 data from all processes and all processes receive the
31900!> same data
31901!> \param[in] msgout Rank-2 data to send
31902!> \param msgin ...
31903!> \param comm ...
31904!> \note see mp_allgather_c12
31905! **************************************************************************************************
31906 SUBROUTINE mp_allgather_c22(msgout, msgin, comm)
31907 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
31908 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31909 CLASS(mp_comm_type), INTENT(IN) :: comm
31910
31911 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c22'
31912
31913 INTEGER :: handle
31914#if defined(__parallel)
31915 INTEGER :: ierr, rcount, scount
31916#endif
31917
31918 CALL mp_timeset(routinen, handle)
31919
31920#if defined(__parallel)
31921 scount = SIZE(msgout(:, :))
31922 rcount = scount
31923 CALL mpi_allgather(msgout, scount, mpi_complex, &
31924 msgin, rcount, mpi_complex, &
31925 comm%handle, ierr)
31926 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31927#else
31928 mark_used(comm)
31929 msgin(:, :) = msgout(:, :)
31930#endif
31931 CALL mp_timestop(handle)
31932 END SUBROUTINE mp_allgather_c22
31933
31934! **************************************************************************************************
31935!> \brief Gathers rank-1 data from all processes and all processes receive the
31936!> same data
31937!> \param[in] msgout Rank-1 data to send
31938!> \param msgin ...
31939!> \param comm ...
31940!> \param request ...
31941!> \note see mp_allgather_c11
31942! **************************************************************************************************
31943 SUBROUTINE mp_iallgather_c11(msgout, msgin, comm, request)
31944 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31945 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31946 CLASS(mp_comm_type), INTENT(IN) :: comm
31947 TYPE(mp_request_type), INTENT(OUT) :: request
31948
31949 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c11'
31950
31951 INTEGER :: handle
31952#if defined(__parallel)
31953 INTEGER :: ierr, rcount, scount
31954#endif
31955
31956 CALL mp_timeset(routinen, handle)
31957
31958#if defined(__parallel)
31959#if !defined(__GNUC__) || __GNUC__ >= 9
31960 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
31961 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
31962#endif
31963 scount = SIZE(msgout(:))
31964 rcount = scount
31965 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31966 msgin, rcount, mpi_complex, &
31967 comm%handle, request%handle, ierr)
31968 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31969#else
31970 mark_used(comm)
31971 msgin = msgout
31972 request = mp_request_null
31973#endif
31974 CALL mp_timestop(handle)
31975 END SUBROUTINE mp_iallgather_c11
31976
31977! **************************************************************************************************
31978!> \brief Gathers rank-2 data from all processes and all processes receive the
31979!> same data
31980!> \param[in] msgout Rank-2 data to send
31981!> \param msgin ...
31982!> \param comm ...
31983!> \param request ...
31984!> \note see mp_allgather_c12
31985! **************************************************************************************************
31986 SUBROUTINE mp_iallgather_c13(msgout, msgin, comm, request)
31987 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31988 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
31989 CLASS(mp_comm_type), INTENT(IN) :: comm
31990 TYPE(mp_request_type), INTENT(OUT) :: request
31991
31992 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c13'
31993
31994 INTEGER :: handle
31995#if defined(__parallel)
31996 INTEGER :: ierr, rcount, scount
31997#endif
31998
31999 CALL mp_timeset(routinen, handle)
32000
32001#if defined(__parallel)
32002#if !defined(__GNUC__) || __GNUC__ >= 9
32003 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
32004 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32005#endif
32006
32007 scount = SIZE(msgout(:))
32008 rcount = scount
32009 CALL mpi_iallgather(msgout, scount, mpi_complex, &
32010 msgin, rcount, mpi_complex, &
32011 comm%handle, request%handle, ierr)
32012 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
32013#else
32014 mark_used(comm)
32015 msgin(:, 1, 1) = msgout(:)
32016 request = mp_request_null
32017#endif
32018 CALL mp_timestop(handle)
32019 END SUBROUTINE mp_iallgather_c13
32020
32021! **************************************************************************************************
32022!> \brief Gathers rank-2 data from all processes and all processes receive the
32023!> same data
32024!> \param[in] msgout Rank-2 data to send
32025!> \param msgin ...
32026!> \param comm ...
32027!> \param request ...
32028!> \note see mp_allgather_c12
32029! **************************************************************************************************
32030 SUBROUTINE mp_iallgather_c22(msgout, msgin, comm, request)
32031 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :)
32032 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :)
32033 CLASS(mp_comm_type), INTENT(IN) :: comm
32034 TYPE(mp_request_type), INTENT(OUT) :: request
32035
32036 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c22'
32037
32038 INTEGER :: handle
32039#if defined(__parallel)
32040 INTEGER :: ierr, rcount, scount
32041#endif
32042
32043 CALL mp_timeset(routinen, handle)
32044
32045#if defined(__parallel)
32046#if !defined(__GNUC__) || __GNUC__ >= 9
32047 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
32048 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32049#endif
32050
32051 scount = SIZE(msgout(:, :))
32052 rcount = scount
32053 CALL mpi_iallgather(msgout, scount, mpi_complex, &
32054 msgin, rcount, mpi_complex, &
32055 comm%handle, request%handle, ierr)
32056 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
32057#else
32058 mark_used(comm)
32059 msgin(:, :) = msgout(:, :)
32060 request = mp_request_null
32061#endif
32062 CALL mp_timestop(handle)
32063 END SUBROUTINE mp_iallgather_c22
32064
32065! **************************************************************************************************
32066!> \brief Gathers rank-2 data from all processes and all processes receive the
32067!> same data
32068!> \param[in] msgout Rank-2 data to send
32069!> \param msgin ...
32070!> \param comm ...
32071!> \param request ...
32072!> \note see mp_allgather_c12
32073! **************************************************************************************************
32074 SUBROUTINE mp_iallgather_c24(msgout, msgin, comm, request)
32075 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :)
32076 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :, :)
32077 CLASS(mp_comm_type), INTENT(IN) :: comm
32078 TYPE(mp_request_type), INTENT(OUT) :: request
32079
32080 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c24'
32081
32082 INTEGER :: handle
32083#if defined(__parallel)
32084 INTEGER :: ierr, rcount, scount
32085#endif
32086
32087 CALL mp_timeset(routinen, handle)
32088
32089#if defined(__parallel)
32090#if !defined(__GNUC__) || __GNUC__ >= 9
32091 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
32092 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32093#endif
32094
32095 scount = SIZE(msgout(:, :))
32096 rcount = scount
32097 CALL mpi_iallgather(msgout, scount, mpi_complex, &
32098 msgin, rcount, mpi_complex, &
32099 comm%handle, request%handle, ierr)
32100 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
32101#else
32102 mark_used(comm)
32103 msgin(:, :, 1, 1) = msgout(:, :)
32104 request = mp_request_null
32105#endif
32106 CALL mp_timestop(handle)
32107 END SUBROUTINE mp_iallgather_c24
32108
32109! **************************************************************************************************
32110!> \brief Gathers rank-3 data from all processes and all processes receive the
32111!> same data
32112!> \param[in] msgout Rank-3 data to send
32113!> \param msgin ...
32114!> \param comm ...
32115!> \param request ...
32116!> \note see mp_allgather_c12
32117! **************************************************************************************************
32118 SUBROUTINE mp_iallgather_c33(msgout, msgin, comm, request)
32119 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :, :)
32120 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
32121 CLASS(mp_comm_type), INTENT(IN) :: comm
32122 TYPE(mp_request_type), INTENT(OUT) :: request
32123
32124 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c33'
32125
32126 INTEGER :: handle
32127#if defined(__parallel)
32128 INTEGER :: ierr, rcount, scount
32129#endif
32130
32131 CALL mp_timeset(routinen, handle)
32132
32133#if defined(__parallel)
32134#if !defined(__GNUC__) || __GNUC__ >= 9
32135 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
32136 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32137#endif
32138
32139 scount = SIZE(msgout(:, :, :))
32140 rcount = scount
32141 CALL mpi_iallgather(msgout, scount, mpi_complex, &
32142 msgin, rcount, mpi_complex, &
32143 comm%handle, request%handle, ierr)
32144 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
32145#else
32146 mark_used(comm)
32147 msgin(:, :, :) = msgout(:, :, :)
32148 request = mp_request_null
32149#endif
32150 CALL mp_timestop(handle)
32151 END SUBROUTINE mp_iallgather_c33
32152
32153! **************************************************************************************************
32154!> \brief Gathers vector data from all processes and all processes receive the
32155!> same data
32156!> \param[in] msgout Rank-1 data to send
32157!> \param[out] msgin Received data
32158!> \param[in] rcount Size of sent data for every process
32159!> \param[in] rdispl Offset of sent data for every process
32160!> \param[in] comm Message passing environment identifier
32161!> \par Data size
32162!> Processes can send different-sized data
32163!> \par Ranks
32164!> The last rank counts the processes
32165!> \par Offsets
32166!> Offsets are from 0
32167!> \par MPI mapping
32168!> mpi_allgather
32169! **************************************************************************************************
32170 SUBROUTINE mp_allgatherv_cv(msgout, msgin, rcount, rdispl, comm)
32171 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
32172 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
32173 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
32174 CLASS(mp_comm_type), INTENT(IN) :: comm
32175
32176 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_cv'
32177
32178 INTEGER :: handle
32179#if defined(__parallel)
32180 INTEGER :: ierr, scount
32181#endif
32182
32183 CALL mp_timeset(routinen, handle)
32184
32185#if defined(__parallel)
32186 scount = SIZE(msgout)
32187 CALL mpi_allgatherv(msgout, scount, mpi_complex, msgin, rcount, &
32188 rdispl, mpi_complex, comm%handle, ierr)
32189 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
32190#else
32191 mark_used(rcount)
32192 mark_used(rdispl)
32193 mark_used(comm)
32194 msgin = msgout
32195#endif
32196 CALL mp_timestop(handle)
32197 END SUBROUTINE mp_allgatherv_cv
32198
32199! **************************************************************************************************
32200!> \brief Gathers vector data from all processes and all processes receive the
32201!> same data
32202!> \param[in] msgout Rank-1 data to send
32203!> \param[out] msgin Received data
32204!> \param[in] rcount Size of sent data for every process
32205!> \param[in] rdispl Offset of sent data for every process
32206!> \param[in] comm Message passing environment identifier
32207!> \par Data size
32208!> Processes can send different-sized data
32209!> \par Ranks
32210!> The last rank counts the processes
32211!> \par Offsets
32212!> Offsets are from 0
32213!> \par MPI mapping
32214!> mpi_allgather
32215! **************************************************************************************************
32216 SUBROUTINE mp_allgatherv_cm2(msgout, msgin, rcount, rdispl, comm)
32217 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
32218 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
32219 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
32220 CLASS(mp_comm_type), INTENT(IN) :: comm
32221
32222 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_cv'
32223
32224 INTEGER :: handle
32225#if defined(__parallel)
32226 INTEGER :: ierr, scount
32227#endif
32228
32229 CALL mp_timeset(routinen, handle)
32230
32231#if defined(__parallel)
32232 scount = SIZE(msgout)
32233 CALL mpi_allgatherv(msgout, scount, mpi_complex, msgin, rcount, &
32234 rdispl, mpi_complex, comm%handle, ierr)
32235 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
32236#else
32237 mark_used(rcount)
32238 mark_used(rdispl)
32239 mark_used(comm)
32240 msgin = msgout
32241#endif
32242 CALL mp_timestop(handle)
32243 END SUBROUTINE mp_allgatherv_cm2
32244
32245! **************************************************************************************************
32246!> \brief Gathers vector data from all processes and all processes receive the
32247!> same data
32248!> \param[in] msgout Rank-1 data to send
32249!> \param[out] msgin Received data
32250!> \param[in] rcount Size of sent data for every process
32251!> \param[in] rdispl Offset of sent data for every process
32252!> \param[in] comm Message passing environment identifier
32253!> \par Data size
32254!> Processes can send different-sized data
32255!> \par Ranks
32256!> The last rank counts the processes
32257!> \par Offsets
32258!> Offsets are from 0
32259!> \par MPI mapping
32260!> mpi_allgather
32261! **************************************************************************************************
32262 SUBROUTINE mp_iallgatherv_cv(msgout, msgin, rcount, rdispl, comm, request)
32263 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
32264 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
32265 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
32266 CLASS(mp_comm_type), INTENT(IN) :: comm
32267 TYPE(mp_request_type), INTENT(OUT) :: request
32268
32269 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_cv'
32270
32271 INTEGER :: handle
32272#if defined(__parallel)
32273 INTEGER :: ierr, scount, rsize
32274#endif
32275
32276 CALL mp_timeset(routinen, handle)
32277
32278#if defined(__parallel)
32279#if !defined(__GNUC__) || __GNUC__ >= 9
32280 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
32281 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32282 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
32283 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
32284#endif
32285
32286 scount = SIZE(msgout)
32287 rsize = SIZE(rcount)
32288 CALL mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, &
32289 rdispl, comm, request, ierr)
32290 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
32291#else
32292 mark_used(rcount)
32293 mark_used(rdispl)
32294 mark_used(comm)
32295 msgin = msgout
32296 request = mp_request_null
32297#endif
32298 CALL mp_timestop(handle)
32299 END SUBROUTINE mp_iallgatherv_cv
32300
32301! **************************************************************************************************
32302!> \brief Gathers vector data from all processes and all processes receive the
32303!> same data
32304!> \param[in] msgout Rank-1 data to send
32305!> \param[out] msgin Received data
32306!> \param[in] rcount Size of sent data for every process
32307!> \param[in] rdispl Offset of sent data for every process
32308!> \param[in] comm Message passing environment identifier
32309!> \par Data size
32310!> Processes can send different-sized data
32311!> \par Ranks
32312!> The last rank counts the processes
32313!> \par Offsets
32314!> Offsets are from 0
32315!> \par MPI mapping
32316!> mpi_allgather
32317! **************************************************************************************************
32318 SUBROUTINE mp_iallgatherv_cv2(msgout, msgin, rcount, rdispl, comm, request)
32319 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
32320 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
32321 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
32322 CLASS(mp_comm_type), INTENT(IN) :: comm
32323 TYPE(mp_request_type), INTENT(OUT) :: request
32324
32325 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_cv2'
32326
32327 INTEGER :: handle
32328#if defined(__parallel)
32329 INTEGER :: ierr, scount, rsize
32330#endif
32331
32332 CALL mp_timeset(routinen, handle)
32333
32334#if defined(__parallel)
32335#if !defined(__GNUC__) || __GNUC__ >= 9
32336 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
32337 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32338 cpassert(is_contiguous(rcount) .OR. SIZE(rcount) == 0)
32339 cpassert(is_contiguous(rdispl) .OR. SIZE(rdispl) == 0)
32340#endif
32341
32342 scount = SIZE(msgout)
32343 rsize = SIZE(rcount)
32344 CALL mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, &
32345 rdispl, comm, request, ierr)
32346 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
32347#else
32348 mark_used(rcount)
32349 mark_used(rdispl)
32350 mark_used(comm)
32351 msgin = msgout
32352 request = mp_request_null
32353#endif
32354 CALL mp_timestop(handle)
32355 END SUBROUTINE mp_iallgatherv_cv2
32356
32357! **************************************************************************************************
32358!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
32359!> the issue is with the rank of rcount and rdispl
32360!> \param count ...
32361!> \param array_of_requests ...
32362!> \param array_of_statuses ...
32363!> \param ierr ...
32364!> \author Alfio Lazzaro
32365! **************************************************************************************************
32366#if defined(__parallel)
32367 SUBROUTINE mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
32368 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
32369 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
32370 INTEGER, INTENT(IN) :: rsize
32371 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
32372 CLASS(mp_comm_type), INTENT(IN) :: comm
32373 TYPE(mp_request_type), INTENT(OUT) :: request
32374 INTEGER, INTENT(INOUT) :: ierr
32375
32376 CALL mpi_iallgatherv(msgout, scount, mpi_complex, msgin, rcount, &
32377 rdispl, mpi_complex, comm%handle, request%handle, ierr)
32378
32379 END SUBROUTINE mp_iallgatherv_cv_internal
32380#endif
32381
32382! **************************************************************************************************
32383!> \brief Sums a vector and partitions the result among processes
32384!> \param[in] msgout Data to sum
32385!> \param[out] msgin Received portion of summed data
32386!> \param[in] rcount Partition sizes of the summed data for
32387!> every process
32388!> \param[in] comm Message passing environment identifier
32389! **************************************************************************************************
32390 SUBROUTINE mp_sum_scatter_cv(msgout, msgin, rcount, comm)
32391 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
32392 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
32393 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
32394 CLASS(mp_comm_type), INTENT(IN) :: comm
32395
32396 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_cv'
32397
32398 INTEGER :: handle
32399#if defined(__parallel)
32400 INTEGER :: ierr
32401#endif
32402
32403 CALL mp_timeset(routinen, handle)
32404
32405#if defined(__parallel)
32406 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_complex, mpi_sum, &
32407 comm%handle, ierr)
32408 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
32409
32410 CALL add_perf(perf_id=3, count=1, &
32411 msg_size=rcount(1)*2*(2*real_4_size))
32412#else
32413 mark_used(rcount)
32414 mark_used(comm)
32415 msgin = msgout(:, 1)
32416#endif
32417 CALL mp_timestop(handle)
32418 END SUBROUTINE mp_sum_scatter_cv
32419
32420! **************************************************************************************************
32421!> \brief Sends and receives vector data
32422!> \param[in] msgin Data to send
32423!> \param[in] dest Process to send data to
32424!> \param[out] msgout Received data
32425!> \param[in] source Process from which to receive
32426!> \param[in] comm Message passing environment identifier
32427!> \param[in] tag Send and recv tag (default: 0)
32428! **************************************************************************************************
32429 SUBROUTINE mp_sendrecv_c (msgin, dest, msgout, source, comm, tag)
32430 COMPLEX(kind=real_4), INTENT(IN) :: msgin
32431 INTEGER, INTENT(IN) :: dest
32432 COMPLEX(kind=real_4), INTENT(OUT) :: msgout
32433 INTEGER, INTENT(IN) :: source
32434 CLASS(mp_comm_type), INTENT(IN) :: comm
32435 INTEGER, INTENT(IN), OPTIONAL :: tag
32436
32437 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_c'
32438
32439 INTEGER :: handle
32440#if defined(__parallel)
32441 INTEGER :: ierr, msglen_in, msglen_out, &
32442 recv_tag, send_tag
32443#endif
32444
32445 CALL mp_timeset(routinen, handle)
32446
32447#if defined(__parallel)
32448 msglen_in = 1
32449 msglen_out = 1
32450 send_tag = 0 ! cannot think of something better here, this might be dangerous
32451 recv_tag = 0 ! cannot think of something better here, this might be dangerous
32452 IF (PRESENT(tag)) THEN
32453 send_tag = tag
32454 recv_tag = tag
32455 END IF
32456 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
32457 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
32458 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
32459 CALL add_perf(perf_id=7, count=1, &
32460 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
32461#else
32462 mark_used(dest)
32463 mark_used(source)
32464 mark_used(comm)
32465 mark_used(tag)
32466 msgout = msgin
32467#endif
32468 CALL mp_timestop(handle)
32469 END SUBROUTINE mp_sendrecv_c
32470
32471! **************************************************************************************************
32472!> \brief Sends and receives vector data
32473!> \param[in] msgin Data to send
32474!> \param[in] dest Process to send data to
32475!> \param[out] msgout Received data
32476!> \param[in] source Process from which to receive
32477!> \param[in] comm Message passing environment identifier
32478!> \param[in] tag Send and recv tag (default: 0)
32479! **************************************************************************************************
32480 SUBROUTINE mp_sendrecv_cv(msgin, dest, msgout, source, comm, tag)
32481 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
32482 INTEGER, INTENT(IN) :: dest
32483 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
32484 INTEGER, INTENT(IN) :: source
32485 CLASS(mp_comm_type), INTENT(IN) :: comm
32486 INTEGER, INTENT(IN), OPTIONAL :: tag
32487
32488 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cv'
32489
32490 INTEGER :: handle
32491#if defined(__parallel)
32492 INTEGER :: ierr, msglen_in, msglen_out, &
32493 recv_tag, send_tag
32494#endif
32495
32496 CALL mp_timeset(routinen, handle)
32497
32498#if defined(__parallel)
32499 msglen_in = SIZE(msgin)
32500 msglen_out = SIZE(msgout)
32501 send_tag = 0 ! cannot think of something better here, this might be dangerous
32502 recv_tag = 0 ! cannot think of something better here, this might be dangerous
32503 IF (PRESENT(tag)) THEN
32504 send_tag = tag
32505 recv_tag = tag
32506 END IF
32507 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
32508 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
32509 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
32510 CALL add_perf(perf_id=7, count=1, &
32511 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
32512#else
32513 mark_used(dest)
32514 mark_used(source)
32515 mark_used(comm)
32516 mark_used(tag)
32517 msgout = msgin
32518#endif
32519 CALL mp_timestop(handle)
32520 END SUBROUTINE mp_sendrecv_cv
32521
32522! **************************************************************************************************
32523!> \brief Sends and receives matrix data
32524!> \param msgin ...
32525!> \param dest ...
32526!> \param msgout ...
32527!> \param source ...
32528!> \param comm ...
32529!> \param tag ...
32530!> \note see mp_sendrecv_cv
32531! **************************************************************************************************
32532 SUBROUTINE mp_sendrecv_cm2(msgin, dest, msgout, source, comm, tag)
32533 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
32534 INTEGER, INTENT(IN) :: dest
32535 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
32536 INTEGER, INTENT(IN) :: source
32537 CLASS(mp_comm_type), INTENT(IN) :: comm
32538 INTEGER, INTENT(IN), OPTIONAL :: tag
32539
32540 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm2'
32541
32542 INTEGER :: handle
32543#if defined(__parallel)
32544 INTEGER :: ierr, msglen_in, msglen_out, &
32545 recv_tag, send_tag
32546#endif
32547
32548 CALL mp_timeset(routinen, handle)
32549
32550#if defined(__parallel)
32551 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
32552 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
32553 send_tag = 0 ! cannot think of something better here, this might be dangerous
32554 recv_tag = 0 ! cannot think of something better here, this might be dangerous
32555 IF (PRESENT(tag)) THEN
32556 send_tag = tag
32557 recv_tag = tag
32558 END IF
32559 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
32560 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
32561 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
32562 CALL add_perf(perf_id=7, count=1, &
32563 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
32564#else
32565 mark_used(dest)
32566 mark_used(source)
32567 mark_used(comm)
32568 mark_used(tag)
32569 msgout = msgin
32570#endif
32571 CALL mp_timestop(handle)
32572 END SUBROUTINE mp_sendrecv_cm2
32573
32574! **************************************************************************************************
32575!> \brief Sends and receives rank-3 data
32576!> \param msgin ...
32577!> \param dest ...
32578!> \param msgout ...
32579!> \param source ...
32580!> \param comm ...
32581!> \note see mp_sendrecv_cv
32582! **************************************************************************************************
32583 SUBROUTINE mp_sendrecv_cm3(msgin, dest, msgout, source, comm, tag)
32584 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
32585 INTEGER, INTENT(IN) :: dest
32586 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
32587 INTEGER, INTENT(IN) :: source
32588 CLASS(mp_comm_type), INTENT(IN) :: comm
32589 INTEGER, INTENT(IN), OPTIONAL :: tag
32590
32591 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm3'
32592
32593 INTEGER :: handle
32594#if defined(__parallel)
32595 INTEGER :: ierr, msglen_in, msglen_out, &
32596 recv_tag, send_tag
32597#endif
32598
32599 CALL mp_timeset(routinen, handle)
32600
32601#if defined(__parallel)
32602 msglen_in = SIZE(msgin)
32603 msglen_out = SIZE(msgout)
32604 send_tag = 0 ! cannot think of something better here, this might be dangerous
32605 recv_tag = 0 ! cannot think of something better here, this might be dangerous
32606 IF (PRESENT(tag)) THEN
32607 send_tag = tag
32608 recv_tag = tag
32609 END IF
32610 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
32611 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
32612 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
32613 CALL add_perf(perf_id=7, count=1, &
32614 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
32615#else
32616 mark_used(dest)
32617 mark_used(source)
32618 mark_used(comm)
32619 mark_used(tag)
32620 msgout = msgin
32621#endif
32622 CALL mp_timestop(handle)
32623 END SUBROUTINE mp_sendrecv_cm3
32624
32625! **************************************************************************************************
32626!> \brief Sends and receives rank-4 data
32627!> \param msgin ...
32628!> \param dest ...
32629!> \param msgout ...
32630!> \param source ...
32631!> \param comm ...
32632!> \note see mp_sendrecv_cv
32633! **************************************************************************************************
32634 SUBROUTINE mp_sendrecv_cm4(msgin, dest, msgout, source, comm, tag)
32635 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
32636 INTEGER, INTENT(IN) :: dest
32637 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
32638 INTEGER, INTENT(IN) :: source
32639 CLASS(mp_comm_type), INTENT(IN) :: comm
32640 INTEGER, INTENT(IN), OPTIONAL :: tag
32641
32642 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm4'
32643
32644 INTEGER :: handle
32645#if defined(__parallel)
32646 INTEGER :: ierr, msglen_in, msglen_out, &
32647 recv_tag, send_tag
32648#endif
32649
32650 CALL mp_timeset(routinen, handle)
32651
32652#if defined(__parallel)
32653 msglen_in = SIZE(msgin)
32654 msglen_out = SIZE(msgout)
32655 send_tag = 0 ! cannot think of something better here, this might be dangerous
32656 recv_tag = 0 ! cannot think of something better here, this might be dangerous
32657 IF (PRESENT(tag)) THEN
32658 send_tag = tag
32659 recv_tag = tag
32660 END IF
32661 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
32662 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
32663 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
32664 CALL add_perf(perf_id=7, count=1, &
32665 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
32666#else
32667 mark_used(dest)
32668 mark_used(source)
32669 mark_used(comm)
32670 mark_used(tag)
32671 msgout = msgin
32672#endif
32673 CALL mp_timestop(handle)
32674 END SUBROUTINE mp_sendrecv_cm4
32675
32676! **************************************************************************************************
32677!> \brief Non-blocking send and receive of a scalar
32678!> \param[in] msgin Scalar data to send
32679!> \param[in] dest Which process to send to
32680!> \param[out] msgout Receive data into this pointer
32681!> \param[in] source Process to receive from
32682!> \param[in] comm Message passing environment identifier
32683!> \param[out] send_request Request handle for the send
32684!> \param[out] recv_request Request handle for the receive
32685!> \param[in] tag (optional) tag to differentiate requests
32686!> \par Implementation
32687!> Calls mpi_isend and mpi_irecv.
32688!> \par History
32689!> 02.2005 created [Alfio Lazzaro]
32690! **************************************************************************************************
32691 SUBROUTINE mp_isendrecv_c (msgin, dest, msgout, source, comm, send_request, &
32692 recv_request, tag)
32693 COMPLEX(kind=real_4), INTENT(IN) :: msgin
32694 INTEGER, INTENT(IN) :: dest
32695 COMPLEX(kind=real_4), INTENT(INOUT) :: msgout
32696 INTEGER, INTENT(IN) :: source
32697 CLASS(mp_comm_type), INTENT(IN) :: comm
32698 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
32699 INTEGER, INTENT(in), OPTIONAL :: tag
32700
32701 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_c'
32702
32703 INTEGER :: handle
32704#if defined(__parallel)
32705 INTEGER :: ierr, my_tag
32706#endif
32707
32708 CALL mp_timeset(routinen, handle)
32709
32710#if defined(__parallel)
32711 my_tag = 0
32712 IF (PRESENT(tag)) my_tag = tag
32713
32714 CALL mpi_irecv(msgout, 1, mpi_complex, source, my_tag, &
32715 comm%handle, recv_request%handle, ierr)
32716 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32717
32718 CALL mpi_isend(msgin, 1, mpi_complex, dest, my_tag, &
32719 comm%handle, send_request%handle, ierr)
32720 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32721
32722 CALL add_perf(perf_id=8, count=1, msg_size=2*(2*real_4_size))
32723#else
32724 mark_used(dest)
32725 mark_used(source)
32726 mark_used(comm)
32727 mark_used(tag)
32728 send_request = mp_request_null
32729 recv_request = mp_request_null
32730 msgout = msgin
32731#endif
32732 CALL mp_timestop(handle)
32733 END SUBROUTINE mp_isendrecv_c
32734
32735! **************************************************************************************************
32736!> \brief Non-blocking send and receive of a vector
32737!> \param[in] msgin Vector data to send
32738!> \param[in] dest Which process to send to
32739!> \param[out] msgout Receive data into this pointer
32740!> \param[in] source Process to receive from
32741!> \param[in] comm Message passing environment identifier
32742!> \param[out] send_request Request handle for the send
32743!> \param[out] recv_request Request handle for the receive
32744!> \param[in] tag (optional) tag to differentiate requests
32745!> \par Implementation
32746!> Calls mpi_isend and mpi_irecv.
32747!> \par History
32748!> 11.2004 created [Joost VandeVondele]
32749!> \note
32750!> arrays can be pointers or assumed shape, but they must be contiguous!
32751! **************************************************************************************************
32752 SUBROUTINE mp_isendrecv_cv(msgin, dest, msgout, source, comm, send_request, &
32753 recv_request, tag)
32754 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
32755 INTEGER, INTENT(IN) :: dest
32756 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
32757 INTEGER, INTENT(IN) :: source
32758 CLASS(mp_comm_type), INTENT(IN) :: comm
32759 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
32760 INTEGER, INTENT(in), OPTIONAL :: tag
32761
32762 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_cv'
32763
32764 INTEGER :: handle
32765#if defined(__parallel)
32766 INTEGER :: ierr, msglen, my_tag
32767 COMPLEX(kind=real_4) :: foo
32768#endif
32769
32770 CALL mp_timeset(routinen, handle)
32771
32772#if defined(__parallel)
32773#if !defined(__GNUC__) || __GNUC__ >= 9
32774 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
32775 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32776#endif
32777
32778 my_tag = 0
32779 IF (PRESENT(tag)) my_tag = tag
32780
32781 msglen = SIZE(msgout, 1)
32782 IF (msglen > 0) THEN
32783 CALL mpi_irecv(msgout(1), msglen, mpi_complex, source, my_tag, &
32784 comm%handle, recv_request%handle, ierr)
32785 ELSE
32786 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32787 comm%handle, recv_request%handle, ierr)
32788 END IF
32789 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32790
32791 msglen = SIZE(msgin, 1)
32792 IF (msglen > 0) THEN
32793 CALL mpi_isend(msgin(1), msglen, mpi_complex, dest, my_tag, &
32794 comm%handle, send_request%handle, ierr)
32795 ELSE
32796 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32797 comm%handle, send_request%handle, ierr)
32798 END IF
32799 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32800
32801 msglen = (msglen + SIZE(msgout, 1) + 1)/2
32802 CALL add_perf(perf_id=8, count=1, msg_size=msglen*(2*real_4_size))
32803#else
32804 mark_used(dest)
32805 mark_used(source)
32806 mark_used(comm)
32807 mark_used(tag)
32808 send_request = mp_request_null
32809 recv_request = mp_request_null
32810 msgout = msgin
32811#endif
32812 CALL mp_timestop(handle)
32813 END SUBROUTINE mp_isendrecv_cv
32814
32815! **************************************************************************************************
32816!> \brief Non-blocking send of vector data
32817!> \param msgin ...
32818!> \param dest ...
32819!> \param comm ...
32820!> \param request ...
32821!> \param tag ...
32822!> \par History
32823!> 08.2003 created [f&j]
32824!> \note see mp_isendrecv_cv
32825!> \note
32826!> arrays can be pointers or assumed shape, but they must be contiguous!
32827! **************************************************************************************************
32828 SUBROUTINE mp_isend_cv(msgin, dest, comm, request, tag)
32829 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
32830 INTEGER, INTENT(IN) :: dest
32831 CLASS(mp_comm_type), INTENT(IN) :: comm
32832 TYPE(mp_request_type), INTENT(out) :: request
32833 INTEGER, INTENT(in), OPTIONAL :: tag
32834
32835 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cv'
32836
32837 INTEGER :: handle, ierr
32838#if defined(__parallel)
32839 INTEGER :: msglen, my_tag
32840 COMPLEX(kind=real_4) :: foo(1)
32841#endif
32842
32843 CALL mp_timeset(routinen, handle)
32844
32845#if defined(__parallel)
32846#if !defined(__GNUC__) || __GNUC__ >= 9
32847 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32848#endif
32849 my_tag = 0
32850 IF (PRESENT(tag)) my_tag = tag
32851
32852 msglen = SIZE(msgin)
32853 IF (msglen > 0) THEN
32854 CALL mpi_isend(msgin(1), msglen, mpi_complex, dest, my_tag, &
32855 comm%handle, request%handle, ierr)
32856 ELSE
32857 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32858 comm%handle, request%handle, ierr)
32859 END IF
32860 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32861
32862 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32863#else
32864 mark_used(msgin)
32865 mark_used(dest)
32866 mark_used(comm)
32867 mark_used(request)
32868 mark_used(tag)
32869 ierr = 1
32870 request = mp_request_null
32871 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32872#endif
32873 CALL mp_timestop(handle)
32874 END SUBROUTINE mp_isend_cv
32875
32876! **************************************************************************************************
32877!> \brief Non-blocking send of matrix data
32878!> \param msgin ...
32879!> \param dest ...
32880!> \param comm ...
32881!> \param request ...
32882!> \param tag ...
32883!> \par History
32884!> 2009-11-25 [UB] Made type-generic for templates
32885!> \author fawzi
32886!> \note see mp_isendrecv_cv
32887!> \note see mp_isend_cv
32888!> \note
32889!> arrays can be pointers or assumed shape, but they must be contiguous!
32890! **************************************************************************************************
32891 SUBROUTINE mp_isend_cm2(msgin, dest, comm, request, tag)
32892 COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(IN) :: msgin
32893 INTEGER, INTENT(IN) :: dest
32894 CLASS(mp_comm_type), INTENT(IN) :: comm
32895 TYPE(mp_request_type), INTENT(out) :: request
32896 INTEGER, INTENT(in), OPTIONAL :: tag
32897
32898 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm2'
32899
32900 INTEGER :: handle, ierr
32901#if defined(__parallel)
32902 INTEGER :: msglen, my_tag
32903 COMPLEX(kind=real_4) :: foo(1)
32904#endif
32905
32906 CALL mp_timeset(routinen, handle)
32907
32908#if defined(__parallel)
32909#if !defined(__GNUC__) || __GNUC__ >= 9
32910 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32911#endif
32912
32913 my_tag = 0
32914 IF (PRESENT(tag)) my_tag = tag
32915
32916 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
32917 IF (msglen > 0) THEN
32918 CALL mpi_isend(msgin(1, 1), msglen, mpi_complex, dest, my_tag, &
32919 comm%handle, request%handle, ierr)
32920 ELSE
32921 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32922 comm%handle, request%handle, ierr)
32923 END IF
32924 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32925
32926 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32927#else
32928 mark_used(msgin)
32929 mark_used(dest)
32930 mark_used(comm)
32931 mark_used(request)
32932 mark_used(tag)
32933 ierr = 1
32934 request = mp_request_null
32935 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32936#endif
32937 CALL mp_timestop(handle)
32938 END SUBROUTINE mp_isend_cm2
32939
32940! **************************************************************************************************
32941!> \brief Non-blocking send of rank-3 data
32942!> \param msgin ...
32943!> \param dest ...
32944!> \param comm ...
32945!> \param request ...
32946!> \param tag ...
32947!> \par History
32948!> 9.2008 added _rm3 subroutine [Iain Bethune]
32949!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
32950!> 2009-11-25 [UB] Made type-generic for templates
32951!> \author fawzi
32952!> \note see mp_isendrecv_cv
32953!> \note see mp_isend_cv
32954!> \note
32955!> arrays can be pointers or assumed shape, but they must be contiguous!
32956! **************************************************************************************************
32957 SUBROUTINE mp_isend_cm3(msgin, dest, comm, request, tag)
32958 COMPLEX(kind=real_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
32959 INTEGER, INTENT(IN) :: dest
32960 CLASS(mp_comm_type), INTENT(IN) :: comm
32961 TYPE(mp_request_type), INTENT(out) :: request
32962 INTEGER, INTENT(in), OPTIONAL :: tag
32963
32964 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm3'
32965
32966 INTEGER :: handle, ierr
32967#if defined(__parallel)
32968 INTEGER :: msglen, my_tag
32969 COMPLEX(kind=real_4) :: foo(1)
32970#endif
32971
32972 CALL mp_timeset(routinen, handle)
32973
32974#if defined(__parallel)
32975#if !defined(__GNUC__) || __GNUC__ >= 9
32976 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
32977#endif
32978
32979 my_tag = 0
32980 IF (PRESENT(tag)) my_tag = tag
32981
32982 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
32983 IF (msglen > 0) THEN
32984 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_complex, dest, my_tag, &
32985 comm%handle, request%handle, ierr)
32986 ELSE
32987 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32988 comm%handle, request%handle, ierr)
32989 END IF
32990 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32991
32992 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32993#else
32994 mark_used(msgin)
32995 mark_used(dest)
32996 mark_used(comm)
32997 mark_used(request)
32998 mark_used(tag)
32999 ierr = 1
33000 request = mp_request_null
33001 CALL mp_stop(ierr, "mp_isend called in non parallel case")
33002#endif
33003 CALL mp_timestop(handle)
33004 END SUBROUTINE mp_isend_cm3
33005
33006! **************************************************************************************************
33007!> \brief Non-blocking send of rank-4 data
33008!> \param msgin the input message
33009!> \param dest the destination processor
33010!> \param comm the communicator object
33011!> \param request the communication request id
33012!> \param tag the message tag
33013!> \par History
33014!> 2.2016 added _cm4 subroutine [Nico Holmberg]
33015!> \author fawzi
33016!> \note see mp_isend_cv
33017!> \note
33018!> arrays can be pointers or assumed shape, but they must be contiguous!
33019! **************************************************************************************************
33020 SUBROUTINE mp_isend_cm4(msgin, dest, comm, request, tag)
33021 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
33022 INTEGER, INTENT(IN) :: dest
33023 CLASS(mp_comm_type), INTENT(IN) :: comm
33024 TYPE(mp_request_type), INTENT(out) :: request
33025 INTEGER, INTENT(in), OPTIONAL :: tag
33026
33027 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm4'
33028
33029 INTEGER :: handle, ierr
33030#if defined(__parallel)
33031 INTEGER :: msglen, my_tag
33032 COMPLEX(kind=real_4) :: foo(1)
33033#endif
33034
33035 CALL mp_timeset(routinen, handle)
33036
33037#if defined(__parallel)
33038#if !defined(__GNUC__) || __GNUC__ >= 9
33039 cpassert(is_contiguous(msgin) .OR. SIZE(msgin) == 0)
33040#endif
33041
33042 my_tag = 0
33043 IF (PRESENT(tag)) my_tag = tag
33044
33045 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
33046 IF (msglen > 0) THEN
33047 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_complex, dest, my_tag, &
33048 comm%handle, request%handle, ierr)
33049 ELSE
33050 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
33051 comm%handle, request%handle, ierr)
33052 END IF
33053 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
33054
33055 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
33056#else
33057 mark_used(msgin)
33058 mark_used(dest)
33059 mark_used(comm)
33060 mark_used(request)
33061 mark_used(tag)
33062 ierr = 1
33063 request = mp_request_null
33064 CALL mp_stop(ierr, "mp_isend called in non parallel case")
33065#endif
33066 CALL mp_timestop(handle)
33067 END SUBROUTINE mp_isend_cm4
33068
33069! **************************************************************************************************
33070!> \brief Non-blocking receive of vector data
33071!> \param msgout ...
33072!> \param source ...
33073!> \param comm ...
33074!> \param request ...
33075!> \param tag ...
33076!> \par History
33077!> 08.2003 created [f&j]
33078!> 2009-11-25 [UB] Made type-generic for templates
33079!> \note see mp_isendrecv_cv
33080!> \note
33081!> arrays can be pointers or assumed shape, but they must be contiguous!
33082! **************************************************************************************************
33083 SUBROUTINE mp_irecv_cv(msgout, source, comm, request, tag)
33084 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
33085 INTEGER, INTENT(IN) :: source
33086 CLASS(mp_comm_type), INTENT(IN) :: comm
33087 TYPE(mp_request_type), INTENT(out) :: request
33088 INTEGER, INTENT(in), OPTIONAL :: tag
33089
33090 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cv'
33091
33092 INTEGER :: handle
33093#if defined(__parallel)
33094 INTEGER :: ierr, msglen, my_tag
33095 COMPLEX(kind=real_4) :: foo(1)
33096#endif
33097
33098 CALL mp_timeset(routinen, handle)
33099
33100#if defined(__parallel)
33101#if !defined(__GNUC__) || __GNUC__ >= 9
33102 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
33103#endif
33104
33105 my_tag = 0
33106 IF (PRESENT(tag)) my_tag = tag
33107
33108 msglen = SIZE(msgout)
33109 IF (msglen > 0) THEN
33110 CALL mpi_irecv(msgout(1), msglen, mpi_complex, source, my_tag, &
33111 comm%handle, request%handle, ierr)
33112 ELSE
33113 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
33114 comm%handle, request%handle, ierr)
33115 END IF
33116 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
33117
33118 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
33119#else
33120 cpabort("mp_irecv called in non parallel case")
33121 mark_used(msgout)
33122 mark_used(source)
33123 mark_used(comm)
33124 mark_used(tag)
33125 request = mp_request_null
33126#endif
33127 CALL mp_timestop(handle)
33128 END SUBROUTINE mp_irecv_cv
33129
33130! **************************************************************************************************
33131!> \brief Non-blocking receive of matrix data
33132!> \param msgout ...
33133!> \param source ...
33134!> \param comm ...
33135!> \param request ...
33136!> \param tag ...
33137!> \par History
33138!> 2009-11-25 [UB] Made type-generic for templates
33139!> \author fawzi
33140!> \note see mp_isendrecv_cv
33141!> \note see mp_irecv_cv
33142!> \note
33143!> arrays can be pointers or assumed shape, but they must be contiguous!
33144! **************************************************************************************************
33145 SUBROUTINE mp_irecv_cm2(msgout, source, comm, request, tag)
33146 COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
33147 INTEGER, INTENT(IN) :: source
33148 CLASS(mp_comm_type), INTENT(IN) :: comm
33149 TYPE(mp_request_type), INTENT(out) :: request
33150 INTEGER, INTENT(in), OPTIONAL :: tag
33151
33152 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm2'
33153
33154 INTEGER :: handle
33155#if defined(__parallel)
33156 INTEGER :: ierr, msglen, my_tag
33157 COMPLEX(kind=real_4) :: foo(1)
33158#endif
33159
33160 CALL mp_timeset(routinen, handle)
33161
33162#if defined(__parallel)
33163#if !defined(__GNUC__) || __GNUC__ >= 9
33164 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
33165#endif
33166
33167 my_tag = 0
33168 IF (PRESENT(tag)) my_tag = tag
33169
33170 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
33171 IF (msglen > 0) THEN
33172 CALL mpi_irecv(msgout(1, 1), msglen, mpi_complex, source, my_tag, &
33173 comm%handle, request%handle, ierr)
33174 ELSE
33175 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
33176 comm%handle, request%handle, ierr)
33177 END IF
33178 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
33179
33180 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
33181#else
33182 mark_used(msgout)
33183 mark_used(source)
33184 mark_used(comm)
33185 mark_used(tag)
33186 request = mp_request_null
33187 cpabort("mp_irecv called in non parallel case")
33188#endif
33189 CALL mp_timestop(handle)
33190 END SUBROUTINE mp_irecv_cm2
33191
33192! **************************************************************************************************
33193!> \brief Non-blocking send of rank-3 data
33194!> \param msgout ...
33195!> \param source ...
33196!> \param comm ...
33197!> \param request ...
33198!> \param tag ...
33199!> \par History
33200!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
33201!> 2009-11-25 [UB] Made type-generic for templates
33202!> \author fawzi
33203!> \note see mp_isendrecv_cv
33204!> \note see mp_irecv_cv
33205!> \note
33206!> arrays can be pointers or assumed shape, but they must be contiguous!
33207! **************************************************************************************************
33208 SUBROUTINE mp_irecv_cm3(msgout, source, comm, request, tag)
33209 COMPLEX(kind=real_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
33210 INTEGER, INTENT(IN) :: source
33211 CLASS(mp_comm_type), INTENT(IN) :: comm
33212 TYPE(mp_request_type), INTENT(out) :: request
33213 INTEGER, INTENT(in), OPTIONAL :: tag
33214
33215 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm3'
33216
33217 INTEGER :: handle
33218#if defined(__parallel)
33219 INTEGER :: ierr, msglen, my_tag
33220 COMPLEX(kind=real_4) :: foo(1)
33221#endif
33222
33223 CALL mp_timeset(routinen, handle)
33224
33225#if defined(__parallel)
33226#if !defined(__GNUC__) || __GNUC__ >= 9
33227 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
33228#endif
33229
33230 my_tag = 0
33231 IF (PRESENT(tag)) my_tag = tag
33232
33233 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
33234 IF (msglen > 0) THEN
33235 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_complex, source, my_tag, &
33236 comm%handle, request%handle, ierr)
33237 ELSE
33238 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
33239 comm%handle, request%handle, ierr)
33240 END IF
33241 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
33242
33243 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
33244#else
33245 mark_used(msgout)
33246 mark_used(source)
33247 mark_used(comm)
33248 mark_used(tag)
33249 request = mp_request_null
33250 cpabort("mp_irecv called in non parallel case")
33251#endif
33252 CALL mp_timestop(handle)
33253 END SUBROUTINE mp_irecv_cm3
33254
33255! **************************************************************************************************
33256!> \brief Non-blocking receive of rank-4 data
33257!> \param msgout the output message
33258!> \param source the source processor
33259!> \param comm the communicator object
33260!> \param request the communication request id
33261!> \param tag the message tag
33262!> \par History
33263!> 2.2016 added _cm4 subroutine [Nico Holmberg]
33264!> \author fawzi
33265!> \note see mp_irecv_cv
33266!> \note
33267!> arrays can be pointers or assumed shape, but they must be contiguous!
33268! **************************************************************************************************
33269 SUBROUTINE mp_irecv_cm4(msgout, source, comm, request, tag)
33270 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
33271 INTEGER, INTENT(IN) :: source
33272 CLASS(mp_comm_type), INTENT(IN) :: comm
33273 TYPE(mp_request_type), INTENT(out) :: request
33274 INTEGER, INTENT(in), OPTIONAL :: tag
33275
33276 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm4'
33277
33278 INTEGER :: handle
33279#if defined(__parallel)
33280 INTEGER :: ierr, msglen, my_tag
33281 COMPLEX(kind=real_4) :: foo(1)
33282#endif
33283
33284 CALL mp_timeset(routinen, handle)
33285
33286#if defined(__parallel)
33287#if !defined(__GNUC__) || __GNUC__ >= 9
33288 cpassert(is_contiguous(msgout) .OR. SIZE(msgout) == 0)
33289#endif
33290
33291 my_tag = 0
33292 IF (PRESENT(tag)) my_tag = tag
33293
33294 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
33295 IF (msglen > 0) THEN
33296 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_complex, source, my_tag, &
33297 comm%handle, request%handle, ierr)
33298 ELSE
33299 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
33300 comm%handle, request%handle, ierr)
33301 END IF
33302 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
33303
33304 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
33305#else
33306 mark_used(msgout)
33307 mark_used(source)
33308 mark_used(comm)
33309 mark_used(tag)
33310 request = mp_request_null
33311 cpabort("mp_irecv called in non parallel case")
33312#endif
33313 CALL mp_timestop(handle)
33314 END SUBROUTINE mp_irecv_cm4
33315
33316! **************************************************************************************************
33317!> \brief Window initialization function for vector data
33318!> \param base ...
33319!> \param comm ...
33320!> \param win ...
33321!> \par History
33322!> 02.2015 created [Alfio Lazzaro]
33323!> \note
33324!> arrays can be pointers or assumed shape, but they must be contiguous!
33325! **************************************************************************************************
33326 SUBROUTINE mp_win_create_cv(base, comm, win)
33327 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
33328 TYPE(mp_comm_type), INTENT(IN) :: comm
33329 CLASS(mp_win_type), INTENT(INOUT) :: win
33330
33331 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_cv'
33332
33333 INTEGER :: handle
33334#if defined(__parallel)
33335 INTEGER :: ierr
33336 INTEGER(kind=mpi_address_kind) :: len
33337 COMPLEX(kind=real_4) :: foo(1)
33338#endif
33339
33340 CALL mp_timeset(routinen, handle)
33341
33342#if defined(__parallel)
33343
33344 len = SIZE(base)*(2*real_4_size)
33345 IF (len > 0) THEN
33346 CALL mpi_win_create(base(1), len, (2*real_4_size), mpi_info_null, comm%handle, win%handle, ierr)
33347 ELSE
33348 CALL mpi_win_create(foo, len, (2*real_4_size), mpi_info_null, comm%handle, win%handle, ierr)
33349 END IF
33350 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
33351
33352 CALL add_perf(perf_id=20, count=1)
33353#else
33354 mark_used(base)
33355 mark_used(comm)
33356 win%handle = mp_win_null_handle
33357#endif
33358 CALL mp_timestop(handle)
33359 END SUBROUTINE mp_win_create_cv
33360
33361! **************************************************************************************************
33362!> \brief Single-sided get function for vector data
33363!> \param base ...
33364!> \param comm ...
33365!> \param win ...
33366!> \par History
33367!> 02.2015 created [Alfio Lazzaro]
33368!> \note
33369!> arrays can be pointers or assumed shape, but they must be contiguous!
33370! **************************************************************************************************
33371 SUBROUTINE mp_rget_cv(base, source, win, win_data, myproc, disp, request, &
33372 origin_datatype, target_datatype)
33373 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
33374 INTEGER, INTENT(IN) :: source
33375 CLASS(mp_win_type), INTENT(IN) :: win
33376 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: win_data
33377 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
33378 TYPE(mp_request_type), INTENT(OUT) :: request
33379 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
33380
33381 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_cv'
33382
33383 INTEGER :: handle
33384#if defined(__parallel)
33385 INTEGER :: ierr, len, &
33386 origin_len, target_len
33387 LOGICAL :: do_local_copy
33388 INTEGER(kind=mpi_address_kind) :: disp_aint
33389 mpi_data_type :: handle_origin_datatype, handle_target_datatype
33390#endif
33391
33392 CALL mp_timeset(routinen, handle)
33393
33394#if defined(__parallel)
33395 len = SIZE(base)
33396 disp_aint = 0
33397 IF (PRESENT(disp)) THEN
33398 disp_aint = int(disp, kind=mpi_address_kind)
33399 END IF
33400 handle_origin_datatype = mpi_complex
33401 origin_len = len
33402 IF (PRESENT(origin_datatype)) THEN
33403 handle_origin_datatype = origin_datatype%type_handle
33404 origin_len = 1
33405 END IF
33406 handle_target_datatype = mpi_complex
33407 target_len = len
33408 IF (PRESENT(target_datatype)) THEN
33409 handle_target_datatype = target_datatype%type_handle
33410 target_len = 1
33411 END IF
33412 IF (len > 0) THEN
33413 do_local_copy = .false.
33414 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
33415 IF (myproc .EQ. source) do_local_copy = .true.
33416 END IF
33417 IF (do_local_copy) THEN
33418 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
33419 base(:) = win_data(disp_aint + 1:disp_aint + len)
33420 !$OMP END PARALLEL WORKSHARE
33421 request = mp_request_null
33422 ierr = 0
33423 ELSE
33424 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
33425 target_len, handle_target_datatype, win%handle, request%handle, ierr)
33426 END IF
33427 ELSE
33428 request = mp_request_null
33429 ierr = 0
33430 END IF
33431 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
33432
33433 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*(2*real_4_size))
33434#else
33435 mark_used(source)
33436 mark_used(win)
33437 mark_used(myproc)
33438 mark_used(origin_datatype)
33439 mark_used(target_datatype)
33440
33441 request = mp_request_null
33442 !
33443 IF (PRESENT(disp)) THEN
33444 base(:) = win_data(disp + 1:disp + SIZE(base))
33445 ELSE
33446 base(:) = win_data(:SIZE(base))
33447 END IF
33448
33449#endif
33450 CALL mp_timestop(handle)
33451 END SUBROUTINE mp_rget_cv
33452
33453! **************************************************************************************************
33454!> \brief ...
33455!> \param count ...
33456!> \param lengths ...
33457!> \param displs ...
33458!> \return ...
33459! ***************************************************************************
33460 FUNCTION mp_type_indexed_make_c (count, lengths, displs) &
33461 result(type_descriptor)
33462 INTEGER, INTENT(IN) :: count
33463 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
33464 TYPE(mp_type_descriptor_type) :: type_descriptor
33465
33466 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_c'
33467
33468 INTEGER :: handle
33469#if defined(__parallel)
33470 INTEGER :: ierr
33471#endif
33472
33473 CALL mp_timeset(routinen, handle)
33474
33475#if defined(__parallel)
33476 CALL mpi_type_indexed(count, lengths, displs, mpi_complex, &
33477 type_descriptor%type_handle, ierr)
33478 IF (ierr /= 0) &
33479 cpabort("MPI_Type_Indexed @ "//routinen)
33480 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
33481 IF (ierr /= 0) &
33482 cpabort("MPI_Type_commit @ "//routinen)
33483#else
33484 type_descriptor%type_handle = 5
33485#endif
33486 type_descriptor%length = count
33487 NULLIFY (type_descriptor%subtype)
33488 type_descriptor%vector_descriptor(1:2) = 1
33489 type_descriptor%has_indexing = .true.
33490 type_descriptor%index_descriptor%index => lengths
33491 type_descriptor%index_descriptor%chunks => displs
33492
33493 CALL mp_timestop(handle)
33494
33495 END FUNCTION mp_type_indexed_make_c
33496
33497! **************************************************************************************************
33498!> \brief Allocates special parallel memory
33499!> \param[in] DATA pointer to integer array to allocate
33500!> \param[in] len number of integers to allocate
33501!> \param[out] stat (optional) allocation status result
33502!> \author UB
33503! **************************************************************************************************
33504 SUBROUTINE mp_allocate_c (DATA, len, stat)
33505 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
33506 INTEGER, INTENT(IN) :: len
33507 INTEGER, INTENT(OUT), OPTIONAL :: stat
33508
33509 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_c'
33510
33511 INTEGER :: handle, ierr
33512
33513 CALL mp_timeset(routinen, handle)
33514
33515#if defined(__parallel)
33516 NULLIFY (data)
33517 CALL mp_alloc_mem(DATA, len, stat=ierr)
33518 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
33519 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
33520 CALL add_perf(perf_id=15, count=1)
33521#else
33522 ALLOCATE (DATA(len), stat=ierr)
33523 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
33524 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
33525#endif
33526 IF (PRESENT(stat)) stat = ierr
33527 CALL mp_timestop(handle)
33528 END SUBROUTINE mp_allocate_c
33529
33530! **************************************************************************************************
33531!> \brief Deallocates special parallel memory
33532!> \param[in] DATA pointer to special memory to deallocate
33533!> \param stat ...
33534!> \author UB
33535! **************************************************************************************************
33536 SUBROUTINE mp_deallocate_c (DATA, stat)
33537 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
33538 INTEGER, INTENT(OUT), OPTIONAL :: stat
33539
33540 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_c'
33541
33542 INTEGER :: handle
33543#if defined(__parallel)
33544 INTEGER :: ierr
33545#endif
33546
33547 CALL mp_timeset(routinen, handle)
33548
33549#if defined(__parallel)
33550 CALL mp_free_mem(DATA, ierr)
33551 IF (PRESENT(stat)) THEN
33552 stat = ierr
33553 ELSE
33554 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
33555 END IF
33556 NULLIFY (data)
33557 CALL add_perf(perf_id=15, count=1)
33558#else
33559 DEALLOCATE (data)
33560 IF (PRESENT(stat)) stat = 0
33561#endif
33562 CALL mp_timestop(handle)
33563 END SUBROUTINE mp_deallocate_c
33564
33565! **************************************************************************************************
33566!> \brief (parallel) Blocking individual file write using explicit offsets
33567!> (serial) Unformatted stream write
33568!> \param[in] fh file handle (file storage unit)
33569!> \param[in] offset file offset (position)
33570!> \param[in] msg data to be written to the file
33571!> \param msglen ...
33572!> \par MPI-I/O mapping mpi_file_write_at
33573!> \par STREAM-I/O mapping WRITE
33574!> \param[in](optional) msglen number of the elements of data
33575! **************************************************************************************************
33576 SUBROUTINE mp_file_write_at_cv(fh, offset, msg, msglen)
33577 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
33578 CLASS(mp_file_type), INTENT(IN) :: fh
33579 INTEGER, INTENT(IN), OPTIONAL :: msglen
33580 INTEGER(kind=file_offset), INTENT(IN) :: offset
33581
33582 INTEGER :: msg_len
33583#if defined(__parallel)
33584 INTEGER :: ierr
33585#endif
33586
33587 msg_len = SIZE(msg)
33588 IF (PRESENT(msglen)) msg_len = msglen
33589#if defined(__parallel)
33590 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33591 IF (ierr .NE. 0) &
33592 cpabort("mpi_file_write_at_cv @ mp_file_write_at_cv")
33593#else
33594 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33595#endif
33596 END SUBROUTINE mp_file_write_at_cv
33597
33598! **************************************************************************************************
33599!> \brief ...
33600!> \param fh ...
33601!> \param offset ...
33602!> \param msg ...
33603! **************************************************************************************************
33604 SUBROUTINE mp_file_write_at_c (fh, offset, msg)
33605 COMPLEX(kind=real_4), INTENT(IN) :: msg
33606 CLASS(mp_file_type), INTENT(IN) :: fh
33607 INTEGER(kind=file_offset), INTENT(IN) :: offset
33608
33609#if defined(__parallel)
33610 INTEGER :: ierr
33611
33612 ierr = 0
33613 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33614 IF (ierr .NE. 0) &
33615 cpabort("mpi_file_write_at_c @ mp_file_write_at_c")
33616#else
33617 WRITE (unit=fh%handle, pos=offset + 1) msg
33618#endif
33619 END SUBROUTINE mp_file_write_at_c
33620
33621! **************************************************************************************************
33622!> \brief (parallel) Blocking collective file write using explicit offsets
33623!> (serial) Unformatted stream write
33624!> \param fh ...
33625!> \param offset ...
33626!> \param msg ...
33627!> \param msglen ...
33628!> \par MPI-I/O mapping mpi_file_write_at_all
33629!> \par STREAM-I/O mapping WRITE
33630! **************************************************************************************************
33631 SUBROUTINE mp_file_write_at_all_cv(fh, offset, msg, msglen)
33632 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
33633 CLASS(mp_file_type), INTENT(IN) :: fh
33634 INTEGER, INTENT(IN), OPTIONAL :: msglen
33635 INTEGER(kind=file_offset), INTENT(IN) :: offset
33636
33637 INTEGER :: msg_len
33638#if defined(__parallel)
33639 INTEGER :: ierr
33640#endif
33641
33642 msg_len = SIZE(msg)
33643 IF (PRESENT(msglen)) msg_len = msglen
33644#if defined(__parallel)
33645 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33646 IF (ierr .NE. 0) &
33647 cpabort("mpi_file_write_at_all_cv @ mp_file_write_at_all_cv")
33648#else
33649 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33650#endif
33651 END SUBROUTINE mp_file_write_at_all_cv
33652
33653! **************************************************************************************************
33654!> \brief ...
33655!> \param fh ...
33656!> \param offset ...
33657!> \param msg ...
33658! **************************************************************************************************
33659 SUBROUTINE mp_file_write_at_all_c (fh, offset, msg)
33660 COMPLEX(kind=real_4), INTENT(IN) :: msg
33661 CLASS(mp_file_type), INTENT(IN) :: fh
33662 INTEGER(kind=file_offset), INTENT(IN) :: offset
33663
33664#if defined(__parallel)
33665 INTEGER :: ierr
33666
33667 ierr = 0
33668 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33669 IF (ierr .NE. 0) &
33670 cpabort("mpi_file_write_at_all_c @ mp_file_write_at_all_c")
33671#else
33672 WRITE (unit=fh%handle, pos=offset + 1) msg
33673#endif
33674 END SUBROUTINE mp_file_write_at_all_c
33675
33676! **************************************************************************************************
33677!> \brief (parallel) Blocking individual file read using explicit offsets
33678!> (serial) Unformatted stream read
33679!> \param[in] fh file handle (file storage unit)
33680!> \param[in] offset file offset (position)
33681!> \param[out] msg data to be read from the file
33682!> \param msglen ...
33683!> \par MPI-I/O mapping mpi_file_read_at
33684!> \par STREAM-I/O mapping READ
33685!> \param[in](optional) msglen number of elements of data
33686! **************************************************************************************************
33687 SUBROUTINE mp_file_read_at_cv(fh, offset, msg, msglen)
33688 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
33689 CLASS(mp_file_type), INTENT(IN) :: fh
33690 INTEGER, INTENT(IN), OPTIONAL :: msglen
33691 INTEGER(kind=file_offset), INTENT(IN) :: offset
33692
33693 INTEGER :: msg_len
33694#if defined(__parallel)
33695 INTEGER :: ierr
33696#endif
33697
33698 msg_len = SIZE(msg)
33699 IF (PRESENT(msglen)) msg_len = msglen
33700#if defined(__parallel)
33701 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33702 IF (ierr .NE. 0) &
33703 cpabort("mpi_file_read_at_cv @ mp_file_read_at_cv")
33704#else
33705 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33706#endif
33707 END SUBROUTINE mp_file_read_at_cv
33708
33709! **************************************************************************************************
33710!> \brief ...
33711!> \param fh ...
33712!> \param offset ...
33713!> \param msg ...
33714! **************************************************************************************************
33715 SUBROUTINE mp_file_read_at_c (fh, offset, msg)
33716 COMPLEX(kind=real_4), INTENT(OUT) :: msg
33717 CLASS(mp_file_type), INTENT(IN) :: fh
33718 INTEGER(kind=file_offset), INTENT(IN) :: offset
33719
33720#if defined(__parallel)
33721 INTEGER :: ierr
33722
33723 ierr = 0
33724 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33725 IF (ierr .NE. 0) &
33726 cpabort("mpi_file_read_at_c @ mp_file_read_at_c")
33727#else
33728 READ (unit=fh%handle, pos=offset + 1) msg
33729#endif
33730 END SUBROUTINE mp_file_read_at_c
33731
33732! **************************************************************************************************
33733!> \brief (parallel) Blocking collective file read using explicit offsets
33734!> (serial) Unformatted stream read
33735!> \param fh ...
33736!> \param offset ...
33737!> \param msg ...
33738!> \param msglen ...
33739!> \par MPI-I/O mapping mpi_file_read_at_all
33740!> \par STREAM-I/O mapping READ
33741! **************************************************************************************************
33742 SUBROUTINE mp_file_read_at_all_cv(fh, offset, msg, msglen)
33743 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
33744 CLASS(mp_file_type), INTENT(IN) :: fh
33745 INTEGER, INTENT(IN), OPTIONAL :: msglen
33746 INTEGER(kind=file_offset), INTENT(IN) :: offset
33747
33748 INTEGER :: msg_len
33749#if defined(__parallel)
33750 INTEGER :: ierr
33751#endif
33752
33753 msg_len = SIZE(msg)
33754 IF (PRESENT(msglen)) msg_len = msglen
33755#if defined(__parallel)
33756 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33757 IF (ierr .NE. 0) &
33758 cpabort("mpi_file_read_at_all_cv @ mp_file_read_at_all_cv")
33759#else
33760 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33761#endif
33762 END SUBROUTINE mp_file_read_at_all_cv
33763
33764! **************************************************************************************************
33765!> \brief ...
33766!> \param fh ...
33767!> \param offset ...
33768!> \param msg ...
33769! **************************************************************************************************
33770 SUBROUTINE mp_file_read_at_all_c (fh, offset, msg)
33771 COMPLEX(kind=real_4), INTENT(OUT) :: msg
33772 CLASS(mp_file_type), INTENT(IN) :: fh
33773 INTEGER(kind=file_offset), INTENT(IN) :: offset
33774
33775#if defined(__parallel)
33776 INTEGER :: ierr
33777
33778 ierr = 0
33779 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33780 IF (ierr .NE. 0) &
33781 cpabort("mpi_file_read_at_all_c @ mp_file_read_at_all_c")
33782#else
33783 READ (unit=fh%handle, pos=offset + 1) msg
33784#endif
33785 END SUBROUTINE mp_file_read_at_all_c
33786
33787! **************************************************************************************************
33788!> \brief ...
33789!> \param ptr ...
33790!> \param vector_descriptor ...
33791!> \param index_descriptor ...
33792!> \return ...
33793! **************************************************************************************************
33794 FUNCTION mp_type_make_c (ptr, &
33795 vector_descriptor, index_descriptor) &
33796 result(type_descriptor)
33797 COMPLEX(kind=real_4), DIMENSION(:), TARGET, asynchronous :: ptr
33798 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
33799 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
33800 TYPE(mp_type_descriptor_type) :: type_descriptor
33801
33802 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_c'
33803
33804#if defined(__parallel)
33805 INTEGER :: ierr
33806#if defined(__MPI_F08)
33807 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
33808 EXTERNAL :: mpi_get_address
33809#endif
33810#endif
33811
33812 NULLIFY (type_descriptor%subtype)
33813 type_descriptor%length = SIZE(ptr)
33814#if defined(__parallel)
33815 type_descriptor%type_handle = mpi_complex
33816 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
33817 IF (ierr /= 0) &
33818 cpabort("MPI_Get_address @ "//routinen)
33819#else
33820 type_descriptor%type_handle = 5
33821#endif
33822 type_descriptor%vector_descriptor(1:2) = 1
33823 type_descriptor%has_indexing = .false.
33824 type_descriptor%data_c => ptr
33825 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
33826 cpabort(routinen//": Vectors and indices NYI")
33827 END IF
33828 END FUNCTION mp_type_make_c
33829
33830! **************************************************************************************************
33831!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
33832!> as the Fortran version returns an integer, which we take to be a C_PTR
33833!> \param DATA data array to allocate
33834!> \param[in] len length (in data elements) of data array allocation
33835!> \param[out] stat (optional) allocation status result
33836! **************************************************************************************************
33837 SUBROUTINE mp_alloc_mem_c (DATA, len, stat)
33838 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: data
33839 INTEGER, INTENT(IN) :: len
33840 INTEGER, INTENT(OUT), OPTIONAL :: stat
33841
33842#if defined(__parallel)
33843 INTEGER :: size, ierr, length, &
33844 mp_res
33845 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
33846 TYPE(c_ptr) :: mp_baseptr
33847 mpi_info_type :: mp_info
33848
33849 length = max(len, 1)
33850 CALL mpi_type_size(mpi_complex, size, ierr)
33851 mp_size = int(length, kind=mpi_address_kind)*size
33852 IF (mp_size .GT. mp_max_memory_size) THEN
33853 cpabort("MPI cannot allocate more than 2 GiByte")
33854 END IF
33855 mp_info = mpi_info_null
33856 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
33857 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
33858 IF (PRESENT(stat)) stat = mp_res
33859#else
33860 INTEGER :: length, mystat
33861 length = max(len, 1)
33862 IF (PRESENT(stat)) THEN
33863 ALLOCATE (DATA(length), stat=mystat)
33864 stat = mystat ! show to convention checker that stat is used
33865 ELSE
33866 ALLOCATE (DATA(length))
33867 END IF
33868#endif
33869 END SUBROUTINE mp_alloc_mem_c
33870
33871! **************************************************************************************************
33872!> \brief Deallocates am array, ... this is hackish
33873!> as the Fortran version takes an integer, which we hope to get by reference
33874!> \param DATA data array to allocate
33875!> \param[out] stat (optional) allocation status result
33876! **************************************************************************************************
33877 SUBROUTINE mp_free_mem_c (DATA, stat)
33878 COMPLEX(kind=real_4), DIMENSION(:), &
33879 POINTER, asynchronous :: data
33880 INTEGER, INTENT(OUT), OPTIONAL :: stat
33881
33882#if defined(__parallel)
33883 INTEGER :: mp_res
33884 CALL mpi_free_mem(DATA, mp_res)
33885 IF (PRESENT(stat)) stat = mp_res
33886#else
33887 DEALLOCATE (data)
33888 IF (PRESENT(stat)) stat = 0
33889#endif
33890 END SUBROUTINE mp_free_mem_c
33891
33892 END MODULE message_passing
isum
static int isum(const int n, const int input[n])
Private routine for computing the sum of the given integers.
Definition dbm_multiply_comm.c:40
modulo
static GRID_HOST_DEVICE int modulo(int a, int m)
Equivalent of Fortran's MODULO, which always return a positive number. https://gcc....
Definition grid_common.h:125
message_passing::mp_allocate
Definition message_passing.F:870
message_passing::mp_deallocate
Definition message_passing.F:879
message_passing::mp_testall
Definition message_passing.F:854
message_passing::mp_testany
Definition message_passing.F:858
message_passing::mp_type_make
Definition message_passing.F:888
message_passing::mp_waitall
Definition message_passing.F:850
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::int_8
integer, parameter, public int_8
Definition kinds.F:54
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
kinds::int_4_size
integer, parameter, public int_4_size
Definition kinds.F:52
kinds::default_string_length
integer, parameter, public default_string_length
Definition kinds.F:57
kinds::real_8_size
integer, parameter, public real_8_size
Definition kinds.F:43
kinds::int_8_size
integer, parameter, public int_8_size
Definition kinds.F:55
kinds::real_4_size
integer, parameter, public real_4_size
Definition kinds.F:42
kinds::real_4
integer, parameter, public real_4
Definition kinds.F:40
kinds::real_8
integer, parameter, public real_8
Definition kinds.F:41
kinds::int_4
integer, parameter, public int_4
Definition kinds.F:51
machine
Machine interface based on Fortran 2003 and POSIX.
Definition machine.F:17
machine::m_abort
subroutine, public m_abort()
Can be used to get a nice core.
Definition machine.F:408
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:23
message_passing::mp_comm_null
type(mp_comm_type), parameter, public mp_comm_null
Definition message_passing.F:791
message_passing::mp_comm_unequal
integer, parameter, public mp_comm_unequal
Definition message_passing.F:809
message_passing::mp_collect_timings
logical, save, public mp_collect_timings
Definition message_passing.F:949
message_passing::mp_dims_create
subroutine, public mp_dims_create(nodes, dims)
wrapper to MPI_Dims_create
Definition message_passing.F:2116
message_passing::mp_para_env_create
subroutine, public mp_para_env_create(para_env, group)
creates a new para environment
Definition message_passing.F:1989
message_passing::intlen
integer, parameter intlen
Definition message_passing.F:944
message_passing::mp_file_type_hindexed_make_chv
type(mp_file_descriptor_type) function, public mp_file_type_hindexed_make_chv(count, lengths, displs)
Creates an indexed MPI type for arrays of strings using bytes for spacing (hindexed type)
Definition message_passing.F:4255
message_passing::mp_world_init
subroutine, public mp_world_init(mp_comm)
initializes the system default communicator
Definition message_passing.F:1258
message_passing::file_amode_rdwr
integer, parameter, public file_amode_rdwr
Definition message_passing.F:124
message_passing::mp_para_cart_create
subroutine, public mp_para_cart_create(cart, group)
creates a cart (multidimensional parallel environment)
Definition message_passing.F:2027
message_passing::mp_file_type_free
subroutine, public mp_file_type_free(type_descriptor)
Releases the type used for MPI I/O.
Definition message_passing.F:4444
message_passing::mp_any_tag
integer, parameter, public mp_any_tag
Definition message_passing.F:105
message_passing::file_amode_wronly
integer, parameter, public file_amode_wronly
Definition message_passing.F:123
message_passing::mpi_character_size
integer, parameter, public mpi_character_size
Definition message_passing.F:131
message_passing::mp_comm_ident
integer, parameter, public mp_comm_ident
Definition message_passing.F:806
message_passing::mp_type_indexed_make_z
type(mp_type_descriptor_type) function, public mp_type_indexed_make_z(count, lengths, displs)
...
Definition message_passing.F:28617
message_passing::mp_abort
subroutine, public mp_abort()
globally stops all tasks this is intended to be low level, most of CP2K should call cp_abort()
Definition message_passing.F:1396
message_passing::mp_type_indexed_make_r
type(mp_type_descriptor_type) function, public mp_type_indexed_make_r(count, lengths, displs)
...
Definition message_passing.F:23772
message_passing::mp_comm_world
type(mp_comm_type), parameter, public mp_comm_world
Definition message_passing.F:793
message_passing::file_amode_create
integer, parameter, public file_amode_create
Definition message_passing.F:121
message_passing::mp_para_env_release
subroutine, public mp_para_env_release(para_env)
releases the para object (to be called when you don't want anymore the shared copy of this object)
Definition message_passing.F:2011
message_passing::mp_comm_self
type(mp_comm_type), parameter, public mp_comm_self
Definition message_passing.F:792
message_passing::mp_comm_congruent
integer, parameter, public mp_comm_congruent
Definition message_passing.F:807
message_passing::mp_para_cart_release
subroutine, public mp_para_cart_release(cart)
releases the given cart
Definition message_passing.F:2044
message_passing::mp_type_indexed_make_d
type(mp_type_descriptor_type) function, public mp_type_indexed_make_d(count, lengths, displs)
...
Definition message_passing.F:18927
message_passing::mp_comm_compare_default
integer, parameter, public mp_comm_compare_default
Definition message_passing.F:810
message_passing::mp_world_finalize
subroutine, public mp_world_finalize()
finalizes the system default communicator
Definition message_passing.F:1359
message_passing::mp_file_delete
subroutine, public mp_file_delete(filepath, info)
Deletes a file. Auxiliary routine to emulate 'replace' action for mp_file_open. Only the master proce...
Definition message_passing.F:3755
message_passing::mp_comm_similar
integer, parameter, public mp_comm_similar
Definition message_passing.F:808
message_passing::mp_file_null
type(mp_file_type), parameter, public mp_file_null
Definition message_passing.F:796
message_passing::mp_any_source
integer, parameter, public mp_any_source
Definition message_passing.F:106
message_passing::mp_type_indexed_make_c
type(mp_type_descriptor_type) function, public mp_type_indexed_make_c(count, lengths, displs)
...
Definition message_passing.F:33462
message_passing::mp_info_null
type(mp_info_type), parameter, public mp_info_null
Definition message_passing.F:797
message_passing::mp_win_null
type(mp_win_type), parameter, public mp_win_null
Definition message_passing.F:795
message_passing::file_amode_append
integer, parameter, public file_amode_append
Definition message_passing.F:126
message_passing::mp_get_library_version
subroutine, public mp_get_library_version(version, resultlen)
Get Version of the MPI Library (MPI 3)
Definition message_passing.F:3664
message_passing::address_kind
integer, parameter, public address_kind
Definition message_passing.F:120
message_passing::mp_file_get_amode
subroutine, public mp_file_get_amode(mpi_io, replace, amode, form, action, status, position)
(parallel) Utility routine to determine MPI file access mode based on variables
Definition message_passing.F:4490
message_passing::file_amode_rdonly
integer, parameter, public file_amode_rdonly
Definition message_passing.F:122
message_passing::mp_waitany
subroutine, public mp_waitany(requests, completed)
waits for completion of any of the given requests
Definition message_passing.F:2299
message_passing::file_amode_excl
integer, parameter, public file_amode_excl
Definition message_passing.F:125
message_passing::mp_request_null
type(mp_request_type), parameter, public mp_request_null
Definition message_passing.F:794
message_passing::mp_file_type_set_view_chv
subroutine, public mp_file_type_set_view_chv(fh, offset, type_descriptor)
Uses a previously created indexed MPI character type to tell the MPI processes how to partition (set_...
Definition message_passing.F:4298
message_passing::mp_type_size
subroutine, public mp_type_size(type_descriptor, type_size)
Returns the size of a data type in bytes.
Definition message_passing.F:4101
message_passing::mpi_integer_size
integer, parameter, public mpi_integer_size
Definition message_passing.F:132
mp_perf_env
Defines all routines to deal with the performance of MPI routines.
Definition mp_perf_env.F:11
mp_perf_env::rm_mp_perf_env
subroutine, public rm_mp_perf_env()
...
Definition mp_perf_env.F:192
mp_perf_env::add_perf
subroutine, public add_perf(perf_id, count, msg_size)
adds the performance informations of one call
Definition mp_perf_env.F:233
mp_perf_env::add_mp_perf_env
subroutine, public add_mp_perf_env(perf_env)
start and stop the performance indicators for every call to start there has to be (exactly) one call ...
Definition mp_perf_env.F:76
message_passing::mp_cart_type
Definition message_passing.F:720
message_passing::mp_comm_type
Definition message_passing.F:155
message_passing::mp_file_descriptor_type
Definition message_passing.F:936
message_passing::mp_file_type
Definition message_passing.F:649
message_passing::mp_info_type
Definition message_passing.F:708
message_passing::mp_para_cart_type
represent a multidimensional parallel environment
Definition message_passing.F:780
message_passing::mp_para_env_p_type
represent a pointer to a para env (to build arrays)
Definition message_passing.F:760
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:743
message_passing::mp_request_type
Definition message_passing.F:603
message_passing::mp_type_descriptor_type
Definition message_passing.F:912
message_passing::mp_win_type
Definition message_passing.F:619