(git:4e96ea1)
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_l, mp_max_lv, mp_max_r, mp_max_rv, &
285 mp_max_d, mp_max_dv, mp_max_c, mp_max_cv, &
286 mp_max_z, mp_max_zv, mp_max_root_i, mp_max_root_l, &
287 mp_max_root_r, mp_max_root_d, mp_max_root_c, mp_max_root_z, &
288 mp_max_root_im, mp_max_root_lm, mp_max_root_rm, mp_max_root_dm, &
289 mp_max_root_cm, mp_max_root_zm
290 generic, PUBLIC :: max => mp_max_i, mp_max_iv, &
291 mp_max_l, mp_max_lv, mp_max_r, mp_max_rv, &
292 mp_max_d, mp_max_dv, mp_max_c, mp_max_cv, &
293 mp_max_z, mp_max_zv, mp_max_root_i, mp_max_root_l, &
294 mp_max_root_r, mp_max_root_d, mp_max_root_c, mp_max_root_z, &
295 mp_max_root_im, mp_max_root_lm, mp_max_root_rm, mp_max_root_dm, &
296 mp_max_root_cm, mp_max_root_zm
297
298 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_min_i, mp_min_iv, &
299 mp_min_l, mp_min_lv, mp_min_r, mp_min_rv, &
300 mp_min_d, mp_min_dv, mp_min_c, mp_min_cv, &
301 mp_min_z, mp_min_zv
302 generic, PUBLIC :: min => mp_min_i, mp_min_iv, &
303 mp_min_l, mp_min_lv, mp_min_r, mp_min_rv, &
304 mp_min_d, mp_min_dv, mp_min_c, mp_min_cv, &
305 mp_min_z, mp_min_zv
306
307 PROCEDURE, PUBLIC, pass(comm), non_overridable :: &
308 mp_sum_scatter_iv, mp_sum_scatter_lv, mp_sum_scatter_rv, &
309 mp_sum_scatter_dv, mp_sum_scatter_cv, mp_sum_scatter_zv
310 generic, PUBLIC :: sum_scatter => &
311 mp_sum_scatter_iv, mp_sum_scatter_lv, mp_sum_scatter_rv, &
312 mp_sum_scatter_dv, mp_sum_scatter_cv, mp_sum_scatter_zv
313
314 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
315 generic, PUBLIC :: prod => mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
316
317 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_gather_i, mp_gather_iv, mp_gather_im, &
318 mp_gather_l, mp_gather_lv, mp_gather_lm, &
319 mp_gather_r, mp_gather_rv, mp_gather_rm, &
320 mp_gather_d, mp_gather_dv, mp_gather_dm, &
321 mp_gather_c, mp_gather_cv, mp_gather_cm, &
322 mp_gather_z, mp_gather_zv, mp_gather_zm, &
323 mp_gather_i_src, mp_gather_iv_src, mp_gather_im_src, &
324 mp_gather_l_src, mp_gather_lv_src, mp_gather_lm_src, &
325 mp_gather_r_src, mp_gather_rv_src, mp_gather_rm_src, &
326 mp_gather_d_src, mp_gather_dv_src, mp_gather_dm_src, &
327 mp_gather_c_src, mp_gather_cv_src, mp_gather_cm_src, &
328 mp_gather_z_src, mp_gather_zv_src, mp_gather_zm_src
329 generic, PUBLIC :: gather => mp_gather_i, mp_gather_iv, mp_gather_im, &
330 mp_gather_l, mp_gather_lv, mp_gather_lm, &
331 mp_gather_r, mp_gather_rv, mp_gather_rm, &
332 mp_gather_d, mp_gather_dv, mp_gather_dm, &
333 mp_gather_c, mp_gather_cv, mp_gather_cm, &
334 mp_gather_z, mp_gather_zv, mp_gather_zm, &
335 mp_gather_i_src, mp_gather_iv_src, mp_gather_im_src, &
336 mp_gather_l_src, mp_gather_lv_src, mp_gather_lm_src, &
337 mp_gather_r_src, mp_gather_rv_src, mp_gather_rm_src, &
338 mp_gather_d_src, mp_gather_dv_src, mp_gather_dm_src, &
339 mp_gather_c_src, mp_gather_cv_src, mp_gather_cm_src, &
340 mp_gather_z_src, mp_gather_zv_src, mp_gather_zm_src
341
342 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_gatherv_iv, &
343 mp_gatherv_lv, mp_gatherv_rv, mp_gatherv_dv, &
344 mp_gatherv_cv, mp_gatherv_zv, mp_gatherv_lm2, mp_gatherv_rm2, &
345 mp_gatherv_dm2, mp_gatherv_cm2, mp_gatherv_zm2, mp_gatherv_iv_src, &
346 mp_gatherv_lv_src, mp_gatherv_rv_src, mp_gatherv_dv_src, &
347 mp_gatherv_cv_src, mp_gatherv_zv_src, mp_gatherv_lm2_src, mp_gatherv_rm2_src, &
348 mp_gatherv_dm2_src, mp_gatherv_cm2_src, mp_gatherv_zm2_src
349 generic, PUBLIC :: gatherv => mp_gatherv_iv, &
350 mp_gatherv_lv, mp_gatherv_rv, mp_gatherv_dv, &
351 mp_gatherv_cv, mp_gatherv_zv, mp_gatherv_lm2, mp_gatherv_rm2, &
352 mp_gatherv_dm2, mp_gatherv_cm2, mp_gatherv_zm2, mp_gatherv_iv_src, &
353 mp_gatherv_lv_src, mp_gatherv_rv_src, mp_gatherv_dv_src, &
354 mp_gatherv_cv_src, mp_gatherv_zv_src, mp_gatherv_lm2_src, mp_gatherv_rm2_src, &
355 mp_gatherv_dm2_src, mp_gatherv_cm2_src, mp_gatherv_zm2_src
356
357 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_igatherv_iv, &
358 mp_igatherv_lv, mp_igatherv_rv, mp_igatherv_dv, &
359 mp_igatherv_cv, mp_igatherv_zv
360 generic, PUBLIC :: igatherv => mp_igatherv_iv, &
361 mp_igatherv_lv, mp_igatherv_rv, mp_igatherv_dv, &
362 mp_igatherv_cv, mp_igatherv_zv
363
364 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_allgather_i, mp_allgather_i2, &
365 mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
366 mp_allgather_i22, mp_allgather_l, mp_allgather_l2, &
367 mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
368 mp_allgather_l22, mp_allgather_r, mp_allgather_r2, &
369 mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
370 mp_allgather_r22, mp_allgather_d, mp_allgather_d2, &
371 mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
372 mp_allgather_d22, mp_allgather_c, mp_allgather_c2, &
373 mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
374 mp_allgather_c22, mp_allgather_z, mp_allgather_z2, &
375 mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
376 mp_allgather_z22
377 generic, PUBLIC :: allgather => mp_allgather_i, mp_allgather_i2, &
378 mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
379 mp_allgather_i22, mp_allgather_l, mp_allgather_l2, &
380 mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
381 mp_allgather_l22, mp_allgather_r, mp_allgather_r2, &
382 mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
383 mp_allgather_r22, mp_allgather_d, mp_allgather_d2, &
384 mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
385 mp_allgather_d22, mp_allgather_c, mp_allgather_c2, &
386 mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
387 mp_allgather_c22, mp_allgather_z, mp_allgather_z2, &
388 mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
389 mp_allgather_z22
390
391 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_allgatherv_iv, mp_allgatherv_lv, &
392 mp_allgatherv_rv, mp_allgatherv_dv, mp_allgatherv_cv, mp_allgatherv_zv, &
393 mp_allgatherv_im2, mp_allgatherv_lm2, mp_allgatherv_rm2, &
394 mp_allgatherv_dm2, mp_allgatherv_cm2, mp_allgatherv_zm2
395 generic, PUBLIC :: allgatherv => mp_allgatherv_iv, mp_allgatherv_lv, &
396 mp_allgatherv_rv, mp_allgatherv_dv, mp_allgatherv_cv, mp_allgatherv_zv, &
397 mp_allgatherv_im2, mp_allgatherv_lm2, mp_allgatherv_rm2, &
398 mp_allgatherv_dm2, mp_allgatherv_cm2, mp_allgatherv_zm2
399
400 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iallgather_i, mp_iallgather_l, &
401 mp_iallgather_r, mp_iallgather_d, mp_iallgather_c, mp_iallgather_z, &
402 mp_iallgather_i11, mp_iallgather_l11, mp_iallgather_r11, mp_iallgather_d11, &
403 mp_iallgather_c11, mp_iallgather_z11, mp_iallgather_i13, mp_iallgather_l13, &
404 mp_iallgather_r13, mp_iallgather_d13, mp_iallgather_c13, mp_iallgather_z13, &
405 mp_iallgather_i22, mp_iallgather_l22, mp_iallgather_r22, mp_iallgather_d22, &
406 mp_iallgather_c22, mp_iallgather_z22, mp_iallgather_i24, mp_iallgather_l24, &
407 mp_iallgather_r24, mp_iallgather_d24, mp_iallgather_c24, mp_iallgather_z24, &
408 mp_iallgather_i33, mp_iallgather_l33, mp_iallgather_r33, mp_iallgather_d33, &
409 mp_iallgather_c33, mp_iallgather_z33
410 generic, PUBLIC :: iallgather => mp_iallgather_i, mp_iallgather_l, &
411 mp_iallgather_r, mp_iallgather_d, mp_iallgather_c, mp_iallgather_z, &
412 mp_iallgather_i11, mp_iallgather_l11, mp_iallgather_r11, mp_iallgather_d11, &
413 mp_iallgather_c11, mp_iallgather_z11, mp_iallgather_i13, mp_iallgather_l13, &
414 mp_iallgather_r13, mp_iallgather_d13, mp_iallgather_c13, mp_iallgather_z13, &
415 mp_iallgather_i22, mp_iallgather_l22, mp_iallgather_r22, mp_iallgather_d22, &
416 mp_iallgather_c22, mp_iallgather_z22, mp_iallgather_i24, mp_iallgather_l24, &
417 mp_iallgather_r24, mp_iallgather_d24, mp_iallgather_c24, mp_iallgather_z24, &
418 mp_iallgather_i33, mp_iallgather_l33, mp_iallgather_r33, mp_iallgather_d33, &
419 mp_iallgather_c33, mp_iallgather_z33
420
421 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iallgatherv_iv, mp_iallgatherv_iv2, &
422 mp_iallgatherv_lv, mp_iallgatherv_lv2, mp_iallgatherv_rv, mp_iallgatherv_rv2, &
423 mp_iallgatherv_dv, mp_iallgatherv_dv2, mp_iallgatherv_cv, mp_iallgatherv_cv2, &
424 mp_iallgatherv_zv, mp_iallgatherv_zv2
425 generic, PUBLIC :: iallgatherv => mp_iallgatherv_iv, mp_iallgatherv_iv2, &
426 mp_iallgatherv_lv, mp_iallgatherv_lv2, mp_iallgatherv_rv, mp_iallgatherv_rv2, &
427 mp_iallgatherv_dv, mp_iallgatherv_dv2, mp_iallgatherv_cv, mp_iallgatherv_cv2, &
428 mp_iallgatherv_zv, mp_iallgatherv_zv2
429
430 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_scatter_iv, mp_scatter_lv, &
431 mp_scatter_rv, mp_scatter_dv, mp_scatter_cv, mp_scatter_zv
432 generic, PUBLIC :: scatter => mp_scatter_iv, mp_scatter_lv, &
433 mp_scatter_rv, mp_scatter_dv, mp_scatter_cv, mp_scatter_zv
434
435 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iscatter_i, mp_iscatter_l, &
436 mp_iscatter_r, mp_iscatter_d, mp_iscatter_c, mp_iscatter_z, &
437 mp_iscatter_iv2, mp_iscatter_lv2, mp_iscatter_rv2, mp_iscatter_dv2, &
438 mp_iscatter_cv2, mp_iscatter_zv2
439 generic, PUBLIC :: iscatter => mp_iscatter_i, mp_iscatter_l, &
440 mp_iscatter_r, mp_iscatter_d, mp_iscatter_c, mp_iscatter_z, &
441 mp_iscatter_iv2, mp_iscatter_lv2, mp_iscatter_rv2, mp_iscatter_dv2, &
442 mp_iscatter_cv2, mp_iscatter_zv2
443
444 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iscatterv_iv, mp_iscatterv_lv, &
445 mp_iscatterv_rv, mp_iscatterv_dv, mp_iscatterv_cv, mp_iscatterv_zv
446 generic, PUBLIC :: iscatterv => mp_iscatterv_iv, mp_iscatterv_lv, &
447 mp_iscatterv_rv, mp_iscatterv_dv, mp_iscatterv_cv, mp_iscatterv_zv
448
449 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
450 mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
451 mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
452 mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
453 mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
454 mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
455 mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
456 mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
457 mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
458 mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
459 mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
460 mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
461 mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
462 mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
463 mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
464 mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
465 mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
466 mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
467 generic, PUBLIC :: alltoall => mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
468 mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
469 mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
470 mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
471 mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
472 mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
473 mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
474 mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
475 mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
476 mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
477 mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
478 mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
479 mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
480 mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
481 mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
482 mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
483 mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
484 mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
485
486 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
487 mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
488 mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
489 mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
490 mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
491 mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
492 generic, PUBLIC :: send => mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
493 mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
494 mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
495 mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
496 mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
497 mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
498
499 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
500 mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
501 mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
502 mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
503 mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
504 mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
505 generic, PUBLIC :: recv => mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
506 mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
507 mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
508 mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
509 mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
510 mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
511
512 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_isendrecv_i, mp_isendrecv_iv, &
513 mp_isendrecv_l, mp_isendrecv_lv, mp_isendrecv_r, mp_isendrecv_rv, &
514 mp_isendrecv_d, mp_isendrecv_dv, mp_isendrecv_c, mp_isendrecv_cv, &
515 mp_isendrecv_z, mp_isendrecv_zv
516 generic, PUBLIC :: isendrecv => mp_isendrecv_i, mp_isendrecv_iv, &
517 mp_isendrecv_l, mp_isendrecv_lv, mp_isendrecv_r, mp_isendrecv_rv, &
518 mp_isendrecv_d, mp_isendrecv_dv, mp_isendrecv_c, mp_isendrecv_cv, &
519 mp_isendrecv_z, mp_isendrecv_zv
520
521 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
522 mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
523 mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
524 mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
525 mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
526 mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4, &
527 mp_isend_bv, mp_isend_bm3, mp_isend_custom
528 generic, PUBLIC :: isend => mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
529 mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
530 mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
531 mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
532 mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
533 mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4, &
534 mp_isend_bv, mp_isend_bm3, mp_isend_custom
535
536 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
537 mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
538 mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
539 mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
540 mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
541 mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4, &
542 mp_irecv_bv, mp_irecv_bm3, mp_irecv_custom
543 generic, PUBLIC :: irecv => mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
544 mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
545 mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
546 mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
547 mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
548 mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4, &
549 mp_irecv_bv, mp_irecv_bm3, mp_irecv_custom
550
551 PROCEDURE, PUBLIC, pass(comm), non_overridable :: probe => mp_probe
552
553 PROCEDURE, PUBLIC, pass(comm), non_overridable :: sync => mp_sync
554 PROCEDURE, PUBLIC, pass(comm), non_overridable :: isync => mp_isync
555
556 PROCEDURE, PUBLIC, pass(comm1), non_overridable :: compare => mp_comm_compare
557 PROCEDURE, PUBLIC, pass(comm1), non_overridable :: rank_compare => mp_rank_compare
558
559 PROCEDURE, PUBLIC, pass(comm2), non_overridable :: from_dup => mp_comm_dup
560 PROCEDURE, PUBLIC, pass(comm), non_overridable :: mp_comm_free
561 generic, PUBLIC :: free => mp_comm_free
562
563 PROCEDURE, PUBLIC, pass(comm), non_overridable :: mp_comm_init
564 generic, PUBLIC :: init => mp_comm_init
565
566 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_size => mp_comm_size
567 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_rank => mp_comm_rank
568 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_ndims => mp_comm_get_ndims
569 PROCEDURE, PUBLIC, pass(comm), non_overridable :: is_source => mp_comm_is_source
570
571 ! Creation routines
572 PROCEDURE, PRIVATE, pass(sub_comm), non_overridable :: mp_comm_split, mp_comm_split_direct
573 generic, PUBLIC :: from_split => mp_comm_split, mp_comm_split_direct
574 PROCEDURE, PUBLIC, pass(mp_new_comm), non_overridable :: from_reordering => mp_reordering
575 PROCEDURE, PUBLIC, pass(comm_new), non_overridable :: mp_comm_assign
576 generic, PUBLIC :: ASSIGNMENT(=) => mp_comm_assign
577
578 ! Other Getters
579 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_tag_ub
580 generic, PUBLIC :: get_tag_ub => mp_comm_get_tag_ub
581 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_host_rank
582 generic, PUBLIC :: get_host_rank => mp_comm_get_host_rank
583 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_io_rank
584 generic, PUBLIC :: get_io_rank => mp_comm_get_io_rank
585 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_wtime_is_global
586 generic, PUBLIC :: get_wtime_is_global => mp_comm_get_wtime_is_global
587 END TYPE
588
589 TYPE mp_request_type
590 PRIVATE
591 mpi_request_type :: handle = mp_request_null_handle
592 CONTAINS
593 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_request_type_set_handle
594 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_request_type_get_handle
595 PROCEDURE, PRIVATE, non_overridable :: mp_request_op_eq
596 PROCEDURE, PRIVATE, non_overridable :: mp_request_op_neq
597 generic, PUBLIC :: OPERATOR(==) => mp_request_op_eq
598 generic, PUBLIC :: OPERATOR(/=) => mp_request_op_neq
599
600 PROCEDURE, PUBLIC, pass(request), non_overridable :: test => mp_test_1
601
602 PROCEDURE, PUBLIC, pass(request), non_overridable :: wait => mp_wait
603 END TYPE
604
605 TYPE mp_win_type
606 PRIVATE
607 mpi_win_type :: handle = mp_win_null_handle
608 CONTAINS
609 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_win_type_set_handle
610 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_win_type_get_handle
611 PROCEDURE, PRIVATE, non_overridable :: mp_win_op_eq
612 PROCEDURE, PRIVATE, non_overridable :: mp_win_op_neq
613 generic, PUBLIC :: OPERATOR(==) => mp_win_op_eq
614 generic, PUBLIC :: OPERATOR(/=) => mp_win_op_neq
615
616 PROCEDURE, PRIVATE, pass(win), non_overridable :: mp_win_create_iv, mp_win_create_lv, &
617 mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv
618 generic, PUBLIC :: create => mp_win_create_iv, mp_win_create_lv, &
619 mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv
620
621 PROCEDURE, PRIVATE, pass(win), non_overridable :: mp_rget_iv, mp_rget_lv, &
622 mp_rget_rv, mp_rget_dv, mp_rget_cv, mp_rget_zv
623 generic, PUBLIC :: rget => mp_rget_iv, mp_rget_lv, &
624 mp_rget_rv, mp_rget_dv, mp_rget_cv, mp_rget_zv
625
626 PROCEDURE, PUBLIC, pass(win), non_overridable :: free => mp_win_free
627 PROCEDURE, PUBLIC, pass(win_new), non_overridable :: mp_win_assign
628 generic, PUBLIC :: ASSIGNMENT(=) => mp_win_assign
629
630 PROCEDURE, PUBLIC, pass(win), non_overridable :: lock_all => mp_win_lock_all
631 PROCEDURE, PUBLIC, pass(win), non_overridable :: unlock_all => mp_win_unlock_all
632 PROCEDURE, PUBLIC, pass(win), non_overridable :: flush_all => mp_win_flush_all
633 END TYPE
634
635 TYPE mp_file_type
636 PRIVATE
637 mpi_file_type :: handle = mp_file_null_handle
638 CONTAINS
639 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_file_type_set_handle
640 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_file_type_get_handle
641 PROCEDURE, PRIVATE, non_overridable :: mp_file_op_eq
642 PROCEDURE, PRIVATE, non_overridable :: mp_file_op_neq
643 generic, PUBLIC :: OPERATOR(==) => mp_file_op_eq
644 generic, PUBLIC :: OPERATOR(/=) => mp_file_op_neq
645
646 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_write_at_ch, mp_file_write_at_chv, &
647 mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, &
648 mp_file_write_at_d, mp_file_write_at_dv, mp_file_write_at_c, mp_file_write_at_cv, &
649 mp_file_write_at_z, mp_file_write_at_zv, mp_file_write_at_l, mp_file_write_at_lv
650 generic, PUBLIC :: write_at => mp_file_write_at_ch, mp_file_write_at_chv, &
651 mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, &
652 mp_file_write_at_d, mp_file_write_at_dv, mp_file_write_at_c, mp_file_write_at_cv, &
653 mp_file_write_at_z, mp_file_write_at_zv, mp_file_write_at_l, mp_file_write_at_lv
654
655 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
656 mp_file_write_at_all_i, mp_file_write_at_all_iv, mp_file_write_at_all_l, mp_file_write_at_all_lv, &
657 mp_file_write_at_all_r, mp_file_write_at_all_rv, mp_file_write_at_all_d, mp_file_write_at_all_dv, &
658 mp_file_write_at_all_c, mp_file_write_at_all_cv, mp_file_write_at_all_z, mp_file_write_at_all_zv
659 generic, PUBLIC :: write_at_all => mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
660 mp_file_write_at_all_i, mp_file_write_at_all_iv, mp_file_write_at_all_l, mp_file_write_at_all_lv, &
661 mp_file_write_at_all_r, mp_file_write_at_all_rv, mp_file_write_at_all_d, mp_file_write_at_all_dv, &
662 mp_file_write_at_all_c, mp_file_write_at_all_cv, mp_file_write_at_all_z, mp_file_write_at_all_zv
663
664 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_read_at_ch, mp_file_read_at_chv, &
665 mp_file_read_at_i, mp_file_read_at_iv, mp_file_read_at_r, mp_file_read_at_rv, &
666 mp_file_read_at_d, mp_file_read_at_dv, mp_file_read_at_c, mp_file_read_at_cv, &
667 mp_file_read_at_z, mp_file_read_at_zv, mp_file_read_at_l, mp_file_read_at_lv
668 generic, PUBLIC :: read_at => mp_file_read_at_ch, mp_file_read_at_chv, &
669 mp_file_read_at_i, mp_file_read_at_iv, mp_file_read_at_r, mp_file_read_at_rv, &
670 mp_file_read_at_d, mp_file_read_at_dv, mp_file_read_at_c, mp_file_read_at_cv, &
671 mp_file_read_at_z, mp_file_read_at_zv, mp_file_read_at_l, mp_file_read_at_lv
672
673 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
674 mp_file_read_at_all_i, mp_file_read_at_all_iv, mp_file_read_at_all_l, mp_file_read_at_all_lv, &
675 mp_file_read_at_all_r, mp_file_read_at_all_rv, mp_file_read_at_all_d, mp_file_read_at_all_dv, &
676 mp_file_read_at_all_c, mp_file_read_at_all_cv, mp_file_read_at_all_z, mp_file_read_at_all_zv
677 generic, PUBLIC :: read_at_all => mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
678 mp_file_read_at_all_i, mp_file_read_at_all_iv, mp_file_read_at_all_l, mp_file_read_at_all_lv, &
679 mp_file_read_at_all_r, mp_file_read_at_all_rv, mp_file_read_at_all_d, mp_file_read_at_all_dv, &
680 mp_file_read_at_all_c, mp_file_read_at_all_cv, mp_file_read_at_all_z, mp_file_read_at_all_zv
681
682 PROCEDURE, PUBLIC, pass(fh), non_overridable :: open => mp_file_open
683 PROCEDURE, PUBLIC, pass(fh), non_overridable :: close => mp_file_close
684 PROCEDURE, PRIVATE, pass(fh_new), non_overridable :: mp_file_assign
685 generic, PUBLIC :: ASSIGNMENT(=) => mp_file_assign
686
687 PROCEDURE, PUBLIC, pass(fh), non_overridable :: get_size => mp_file_get_size
688 PROCEDURE, PUBLIC, pass(fh), non_overridable :: get_position => mp_file_get_position
689
690 PROCEDURE, PUBLIC, pass(fh), non_overridable :: read_all => mp_file_read_all_chv
691 PROCEDURE, PUBLIC, pass(fh), non_overridable :: write_all => mp_file_write_all_chv
692 END TYPE
693
694 TYPE mp_info_type
695 PRIVATE
696 mpi_info_type :: handle = mp_info_null_handle
697 CONTAINS
698 PROCEDURE, NON_OVERRIDABLE :: set_handle => mp_info_type_set_handle
699 PROCEDURE, non_overridable :: get_handle => mp_info_type_get_handle
700 PROCEDURE, PRIVATE, non_overridable :: mp_info_op_eq
701 PROCEDURE, PRIVATE, non_overridable :: mp_info_op_neq
702 generic, PUBLIC :: OPERATOR(==) => mp_info_op_eq
703 generic, PUBLIC :: OPERATOR(/=) => mp_info_op_neq
704 END TYPE
705
706 TYPE, EXTENDS(mp_comm_type) :: mp_cart_type
707 INTEGER, DIMENSION(:), ALLOCATABLE, PUBLIC :: mepos_cart, num_pe_cart
708 LOGICAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: periodic
709 CONTAINS
710 PROCEDURE, PUBLIC, pass(comm_cart), non_overridable :: create => mp_cart_create
711 PROCEDURE, PUBLIC, pass(sub_comm), non_overridable :: from_sub => mp_cart_sub
712
713 PROCEDURE, PRIVATE, pass(comm), non_overridable :: get_info_cart => mp_cart_get
714
715 PROCEDURE, PUBLIC, pass(comm), non_overridable :: coords => mp_cart_coords
716 PROCEDURE, PUBLIC, pass(comm), non_overridable :: rank_cart => mp_cart_rank
717 END TYPE
718
719! **************************************************************************************************
720!> \brief stores all the informations relevant to an mpi environment
721!> \param owns_group if it owns the group (and thus should free it when
722!> this object is deallocated)
723!> \param ref_count the reference count, when it is zero this object gets
724!> deallocated
725!> \par History
726!> 08.2002 created [fawzi]
727!> \author Fawzi Mohamed
728! **************************************************************************************************
729 TYPE, EXTENDS(mp_comm_type) :: mp_para_env_type
730 PRIVATE
731 ! We set it to true to have less initialization steps in case we create a new communicator
732 LOGICAL :: owns_group = .true.
733 INTEGER :: ref_count = -1
734 CONTAINS
735 PROCEDURE, PUBLIC, pass(para_env), non_overridable :: retain => mp_para_env_retain
736 PROCEDURE, PUBLIC, pass(para_env), non_overridable :: is_valid => mp_para_env_is_valid
737 END TYPE mp_para_env_type
738
739! **************************************************************************************************
740!> \brief represent a pointer to a para env (to build arrays)
741!> \param para_env the pointer to the para_env
742!> \par History
743!> 07.2003 created [fawzi]
744!> \author Fawzi Mohamed
745! **************************************************************************************************
746 TYPE mp_para_env_p_type
747 TYPE(mp_para_env_type), POINTER :: para_env => null()
748 END TYPE mp_para_env_p_type
749
750! **************************************************************************************************
751!> \brief represent a multidimensional parallel environment
752!> \param mepos_cart the position of the actual processor
753!> \param num_pe_cart number of processors in the group in each dimension
754!> \param source_cart id of a special processor (for example the one for i-o,
755!> or the master
756!> \param owns_group if it owns the group (and thus should free it when
757!> this object is deallocated)
758!> \param ref_count the reference count, when it is zero this object gets
759!> deallocated
760!> \note
761!> not yet implemented for mpi
762!> \par History
763!> 08.2002 created [fawzi]
764!> \author Fawzi Mohamed
765! **************************************************************************************************
766 TYPE, EXTENDS(mp_cart_type) :: mp_para_cart_type
767 PRIVATE
768 ! We set it to true to have less initialization steps in case we create a new communicator
769 LOGICAL :: owns_group = .true.
770 INTEGER :: ref_count = -1
771 CONTAINS
772 PROCEDURE, PUBLIC, pass(cart), non_overridable :: retain => mp_para_cart_retain
773 PROCEDURE, PUBLIC, pass(cart), non_overridable :: is_valid => mp_para_cart_is_valid
774 END TYPE mp_para_cart_type
775
776 ! Create the constants from the corresponding handles
777 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_null = mp_comm_type(mp_comm_null_handle)
778 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_self = mp_comm_type(mp_comm_self_handle)
779 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_world = mp_comm_type(mp_comm_world_handle)
780 TYPE(mp_request_type), PARAMETER, PUBLIC :: mp_request_null = mp_request_type(mp_request_null_handle)
781 TYPE(mp_win_type), PARAMETER, PUBLIC :: mp_win_null = mp_win_type(mp_win_null_handle)
782 TYPE(mp_file_type), PARAMETER, PUBLIC :: mp_file_null = mp_file_type(mp_file_null_handle)
783 TYPE(mp_info_type), PARAMETER, PUBLIC :: mp_info_null = mp_info_type(mp_info_null_handle)
784
785#if !defined(__parallel)
786 ! This communicator is to be used in serial mode to emulate a valid communicator which is not a compiler constant
787 INTEGER, PARAMETER, PRIVATE :: mp_comm_default_handle = 1
788 TYPE(mp_comm_type), PARAMETER, PRIVATE :: mp_comm_default = mp_comm_type(mp_comm_default_handle)
789#endif
790
791 ! Constants to compare communicators
792 INTEGER, PARAMETER, PUBLIC :: mp_comm_ident = 0
793 INTEGER, PARAMETER, PUBLIC :: mp_comm_congruent = 1
794 INTEGER, PARAMETER, PUBLIC :: mp_comm_similar = 2
795 INTEGER, PARAMETER, PUBLIC :: mp_comm_unequal = 3
796 INTEGER, PARAMETER, PUBLIC :: mp_comm_compare_default = -1
797
798 ! init and error
799 PUBLIC :: mp_world_init, mp_world_finalize
800 PUBLIC :: mp_abort
801
802 ! informational / generation of sub comms
803 PUBLIC :: mp_dims_create
804 PUBLIC :: cp2k_is_parallel
805
806 ! message passing
807 PUBLIC :: mp_waitall, mp_waitany
808 PUBLIC :: mp_testall, mp_testany
809
810 ! Memory management
811 PUBLIC :: mp_allocate, mp_deallocate
812
813 ! I/O
814 PUBLIC :: mp_file_delete
815 PUBLIC :: mp_file_get_amode
816
817 ! some 'advanced types' currently only used for dbcsr
818 PUBLIC :: mp_type_descriptor_type
819 PUBLIC :: mp_type_make
820 PUBLIC :: mp_type_size
821
822 ! vector types
823 PUBLIC :: mp_type_indexed_make_r, mp_type_indexed_make_d, &
824 mp_type_indexed_make_c, mp_type_indexed_make_z
825
826 ! More I/O types and routines: variable spaced data using bytes for spacings
827 PUBLIC :: mp_file_descriptor_type
828 PUBLIC :: mp_file_type_free
829 PUBLIC :: mp_file_type_hindexed_make_chv
830 PUBLIC :: mp_file_type_set_view_chv
831
832 PUBLIC :: mp_get_library_version
833
834 ! assumed to be private
835
836 INTERFACE mp_waitall
837 MODULE PROCEDURE mp_waitall_1, mp_waitall_2
838 END INTERFACE
839
840 INTERFACE mp_testall
841 MODULE PROCEDURE mp_testall_tv
842 END INTERFACE
843
844 INTERFACE mp_testany
845 MODULE PROCEDURE mp_testany_1, mp_testany_2
846 END INTERFACE
847
848 INTERFACE mp_type_free
849 MODULE PROCEDURE mp_type_free_m, mp_type_free_v
850 END INTERFACE
851
852 !
853 ! interfaces to deal easily with scalars / vectors / matrices / ...
854 ! of the different types (integers, doubles, logicals, characters)
855 !
856 INTERFACE mp_allocate
857 MODULE PROCEDURE mp_allocate_i, &
858 mp_allocate_l, &
859 mp_allocate_r, &
860 mp_allocate_d, &
861 mp_allocate_c, &
862 mp_allocate_z
863 END INTERFACE
864
865 INTERFACE mp_deallocate
866 MODULE PROCEDURE mp_deallocate_i, &
867 mp_deallocate_l, &
868 mp_deallocate_r, &
869 mp_deallocate_d, &
870 mp_deallocate_c, &
871 mp_deallocate_z
872 END INTERFACE
873
874 INTERFACE mp_type_make
875 MODULE PROCEDURE mp_type_make_struct
876 MODULE PROCEDURE mp_type_make_i, mp_type_make_l, &
877 mp_type_make_r, mp_type_make_d, &
878 mp_type_make_c, mp_type_make_z
879 END INTERFACE
880
881 INTERFACE mp_alloc_mem
882 MODULE PROCEDURE mp_alloc_mem_i, mp_alloc_mem_l, &
883 mp_alloc_mem_d, mp_alloc_mem_z, &
884 mp_alloc_mem_r, mp_alloc_mem_c
885 END INTERFACE
886
887 INTERFACE mp_free_mem
888 MODULE PROCEDURE mp_free_mem_i, mp_free_mem_l, &
889 mp_free_mem_d, mp_free_mem_z, &
890 mp_free_mem_r, mp_free_mem_c
891 END INTERFACE
892
893! Type declarations
894 TYPE mp_indexing_meta_type
895 INTEGER, DIMENSION(:), POINTER :: index => null(), chunks => null()
896 END TYPE mp_indexing_meta_type
897
898 TYPE mp_type_descriptor_type
899 mpi_data_type :: type_handle = mp_datatype_null_handle
900 INTEGER :: length = -1
901#if defined(__parallel)
902 INTEGER(kind=mpi_address_kind) :: base = -1
903#endif
904 INTEGER(kind=int_4), DIMENSION(:), POINTER :: data_i => null()
905 INTEGER(kind=int_8), DIMENSION(:), POINTER :: data_l => null()
906 REAL(kind=real_4), DIMENSION(:), POINTER :: data_r => null()
907 REAL(kind=real_8), DIMENSION(:), POINTER :: data_d => null()
908 COMPLEX(kind=real_4), DIMENSION(:), POINTER :: data_c => null()
909 COMPLEX(kind=real_8), DIMENSION(:), POINTER :: data_z => null()
910 TYPE(mp_type_descriptor_type), DIMENSION(:), POINTER :: subtype => null()
911 INTEGER :: vector_descriptor(2) = -1
912 LOGICAL :: has_indexing = .false.
913 TYPE(mp_indexing_meta_type) :: index_descriptor = mp_indexing_meta_type()
914 END TYPE mp_type_descriptor_type
915
916 TYPE mp_file_indexing_meta_type
917 INTEGER, DIMENSION(:), POINTER :: index => null()
918 INTEGER(kind=file_offset), &
919 DIMENSION(:), POINTER :: chunks => null()
920 END TYPE mp_file_indexing_meta_type
921
922 TYPE mp_file_descriptor_type
923 mpi_data_type :: type_handle = mp_datatype_null_handle
924 INTEGER :: length = -1
925 LOGICAL :: has_indexing = .false.
926 TYPE(mp_file_indexing_meta_type) :: index_descriptor = mp_file_indexing_meta_type()
927 END TYPE
928
929 ! we make some assumptions on the length of INTEGERS, REALS and LOGICALS
930 INTEGER, PARAMETER :: intlen = bit_size(0)/8
931 INTEGER, PARAMETER :: reallen = 8
932 INTEGER, PARAMETER :: loglen = bit_size(0)/8
933 INTEGER, PARAMETER :: charlen = 1
934
935 LOGICAL, PUBLIC, SAVE :: mp_collect_timings = .false.
936
937CONTAINS
938
939 LOGICAL FUNCTION mp_comm_op_eq(comm1, comm2)
940 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
941#if defined(__parallel) && defined(__MPI_F08)
942 mp_comm_op_eq = (comm1%handle%mpi_val == comm2%handle%mpi_val)
943#else
944 mp_comm_op_eq = (comm1%handle == comm2%handle)
945#endif
946 END FUNCTION mp_comm_op_eq
947
948 LOGICAL FUNCTION mp_comm_op_neq(comm1, comm2)
949 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
950#if defined(__parallel) && defined(__MPI_F08)
951 mp_comm_op_neq = (comm1%handle%mpi_val /= comm2%handle%mpi_val)
952#else
953 mp_comm_op_neq = (comm1%handle /= comm2%handle)
954#endif
955 END FUNCTION mp_comm_op_neq
956
957 ELEMENTAL IMPURE SUBROUTINE mp_comm_type_set_handle(this, handle , ndims)
958 CLASS(mp_comm_type), INTENT(INOUT) :: this
959 INTEGER, INTENT(IN) :: handle
960 INTEGER, INTENT(IN), OPTIONAL :: ndims
961
962#if defined(__parallel) && defined(__MPI_F08)
963 this%handle%mpi_val = handle
964#else
965 this%handle = handle
966#endif
967
968 SELECT TYPE (this)
969 CLASS IS (mp_cart_type)
970 IF (.NOT. PRESENT(ndims)) &
971 CALL cp_abort(__location__, &
972 "Setup of a cartesian communicator requires information on the number of dimensions!")
973 END SELECT
974 IF (PRESENT(ndims)) this%ndims = ndims
975 CALL this%init()
976
977 END SUBROUTINE mp_comm_type_set_handle
978
979 ELEMENTAL FUNCTION mp_comm_type_get_handle(this) RESULT(handle)
980 CLASS(mp_comm_type), INTENT(IN) :: this
981 INTEGER :: handle
982
983#if defined(__parallel) && defined(__MPI_F08)
984 handle = this%handle%mpi_val
985#else
986 handle = this%handle
987#endif
988 END FUNCTION mp_comm_type_get_handle
989 LOGICAL FUNCTION mp_request_op_eq(request1, request2)
990 CLASS(mp_request_type), INTENT(IN) :: request1, request2
991#if defined(__parallel) && defined(__MPI_F08)
992 mp_request_op_eq = (request1%handle%mpi_val == request2%handle%mpi_val)
993#else
994 mp_request_op_eq = (request1%handle == request2%handle)
995#endif
996 END FUNCTION mp_request_op_eq
997
998 LOGICAL FUNCTION mp_request_op_neq(request1, request2)
999 CLASS(mp_request_type), INTENT(IN) :: request1, request2
1000#if defined(__parallel) && defined(__MPI_F08)
1001 mp_request_op_neq = (request1%handle%mpi_val /= request2%handle%mpi_val)
1002#else
1003 mp_request_op_neq = (request1%handle /= request2%handle)
1004#endif
1005 END FUNCTION mp_request_op_neq
1006
1007 ELEMENTAL SUBROUTINE mp_request_type_set_handle(this, handle )
1008 CLASS(mp_request_type), INTENT(INOUT) :: this
1009 INTEGER, INTENT(IN) :: handle
1010
1011#if defined(__parallel) && defined(__MPI_F08)
1012 this%handle%mpi_val = handle
1013#else
1014 this%handle = handle
1015#endif
1016
1017
1018 END SUBROUTINE mp_request_type_set_handle
1019
1020 ELEMENTAL FUNCTION mp_request_type_get_handle(this) RESULT(handle)
1021 CLASS(mp_request_type), INTENT(IN) :: this
1022 INTEGER :: handle
1023
1024#if defined(__parallel) && defined(__MPI_F08)
1025 handle = this%handle%mpi_val
1026#else
1027 handle = this%handle
1028#endif
1029 END FUNCTION mp_request_type_get_handle
1030 LOGICAL FUNCTION mp_win_op_eq(win1, win2)
1031 CLASS(mp_win_type), INTENT(IN) :: win1, win2
1032#if defined(__parallel) && defined(__MPI_F08)
1033 mp_win_op_eq = (win1%handle%mpi_val == win2%handle%mpi_val)
1034#else
1035 mp_win_op_eq = (win1%handle == win2%handle)
1036#endif
1037 END FUNCTION mp_win_op_eq
1038
1039 LOGICAL FUNCTION mp_win_op_neq(win1, win2)
1040 CLASS(mp_win_type), INTENT(IN) :: win1, win2
1041#if defined(__parallel) && defined(__MPI_F08)
1042 mp_win_op_neq = (win1%handle%mpi_val /= win2%handle%mpi_val)
1043#else
1044 mp_win_op_neq = (win1%handle /= win2%handle)
1045#endif
1046 END FUNCTION mp_win_op_neq
1047
1048 ELEMENTAL SUBROUTINE mp_win_type_set_handle(this, handle )
1049 CLASS(mp_win_type), INTENT(INOUT) :: this
1050 INTEGER, INTENT(IN) :: handle
1051
1052#if defined(__parallel) && defined(__MPI_F08)
1053 this%handle%mpi_val = handle
1054#else
1055 this%handle = handle
1056#endif
1057
1058
1059 END SUBROUTINE mp_win_type_set_handle
1060
1061 ELEMENTAL FUNCTION mp_win_type_get_handle(this) RESULT(handle)
1062 CLASS(mp_win_type), INTENT(IN) :: this
1063 INTEGER :: handle
1064
1065#if defined(__parallel) && defined(__MPI_F08)
1066 handle = this%handle%mpi_val
1067#else
1068 handle = this%handle
1069#endif
1070 END FUNCTION mp_win_type_get_handle
1071 LOGICAL FUNCTION mp_file_op_eq(file1, file2)
1072 CLASS(mp_file_type), INTENT(IN) :: file1, file2
1073#if defined(__parallel) && defined(__MPI_F08)
1074 mp_file_op_eq = (file1%handle%mpi_val == file2%handle%mpi_val)
1075#else
1076 mp_file_op_eq = (file1%handle == file2%handle)
1077#endif
1078 END FUNCTION mp_file_op_eq
1079
1080 LOGICAL FUNCTION mp_file_op_neq(file1, file2)
1081 CLASS(mp_file_type), INTENT(IN) :: file1, file2
1082#if defined(__parallel) && defined(__MPI_F08)
1083 mp_file_op_neq = (file1%handle%mpi_val /= file2%handle%mpi_val)
1084#else
1085 mp_file_op_neq = (file1%handle /= file2%handle)
1086#endif
1087 END FUNCTION mp_file_op_neq
1088
1089 ELEMENTAL SUBROUTINE mp_file_type_set_handle(this, handle )
1090 CLASS(mp_file_type), INTENT(INOUT) :: this
1091 INTEGER, INTENT(IN) :: handle
1092
1093#if defined(__parallel) && defined(__MPI_F08)
1094 this%handle%mpi_val = handle
1095#else
1096 this%handle = handle
1097#endif
1098
1099
1100 END SUBROUTINE mp_file_type_set_handle
1101
1102 ELEMENTAL FUNCTION mp_file_type_get_handle(this) RESULT(handle)
1103 CLASS(mp_file_type), INTENT(IN) :: this
1104 INTEGER :: handle
1105
1106#if defined(__parallel) && defined(__MPI_F08)
1107 handle = this%handle%mpi_val
1108#else
1109 handle = this%handle
1110#endif
1111 END FUNCTION mp_file_type_get_handle
1112 LOGICAL FUNCTION mp_info_op_eq(info1, info2)
1113 CLASS(mp_info_type), INTENT(IN) :: info1, info2
1114#if defined(__parallel) && defined(__MPI_F08)
1115 mp_info_op_eq = (info1%handle%mpi_val == info2%handle%mpi_val)
1116#else
1117 mp_info_op_eq = (info1%handle == info2%handle)
1118#endif
1119 END FUNCTION mp_info_op_eq
1120
1121 LOGICAL FUNCTION mp_info_op_neq(info1, info2)
1122 CLASS(mp_info_type), INTENT(IN) :: info1, info2
1123#if defined(__parallel) && defined(__MPI_F08)
1124 mp_info_op_neq = (info1%handle%mpi_val /= info2%handle%mpi_val)
1125#else
1126 mp_info_op_neq = (info1%handle /= info2%handle)
1127#endif
1128 END FUNCTION mp_info_op_neq
1129
1130 ELEMENTAL SUBROUTINE mp_info_type_set_handle(this, handle )
1131 CLASS(mp_info_type), INTENT(INOUT) :: this
1132 INTEGER, INTENT(IN) :: handle
1133
1134#if defined(__parallel) && defined(__MPI_F08)
1135 this%handle%mpi_val = handle
1136#else
1137 this%handle = handle
1138#endif
1139
1140
1141 END SUBROUTINE mp_info_type_set_handle
1142
1143 ELEMENTAL FUNCTION mp_info_type_get_handle(this) RESULT(handle)
1144 CLASS(mp_info_type), INTENT(IN) :: this
1145 INTEGER :: handle
1146
1147#if defined(__parallel) && defined(__MPI_F08)
1148 handle = this%handle%mpi_val
1149#else
1150 handle = this%handle
1151#endif
1152 END FUNCTION mp_info_type_get_handle
1153
1154 FUNCTION mp_comm_get_tag_ub(comm) RESULT(tag_ub)
1155 CLASS(mp_comm_type), INTENT(IN) :: comm
1156 INTEGER :: tag_ub
1157
1158#if defined(__parallel)
1159 INTEGER :: ierr
1160 LOGICAL :: flag
1161 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1162
1163 CALL mpi_comm_get_attr(comm%handle, mpi_tag_ub, attrval, flag, ierr)
1164 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_tag_ub")
1165 IF (.NOT. flag) THEN
1166 CALL cp_warn(__location__, "Upper bound of tags not available! "// &
1167 "Only the guaranteed minimum of 32767 is used.")
1168 tag_ub = 32767
1169 ELSE
1170 tag_ub = int(attrval, kind=kind(tag_ub))
1171 END IF
1172#else
1173 mark_used(comm)
1174 tag_ub = huge(1)
1175#endif
1176 END FUNCTION mp_comm_get_tag_ub
1177
1178 FUNCTION mp_comm_get_host_rank(comm) RESULT(host_rank)
1179 CLASS(mp_comm_type), INTENT(IN) :: comm
1180 INTEGER :: host_rank
1181
1182#if defined(__parallel)
1183 INTEGER :: ierr
1184 LOGICAL :: flag
1185 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1186
1187 CALL mpi_comm_get_attr(comm%handle, mpi_host, attrval, flag, ierr)
1188 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_host_rank")
1189 IF (.NOT. flag) cpabort("Host process rank not available!")
1190 host_rank = int(attrval, kind=kind(host_rank))
1191#else
1192 mark_used(comm)
1193 host_rank = 0
1194#endif
1195 END FUNCTION mp_comm_get_host_rank
1196
1197 FUNCTION mp_comm_get_io_rank(comm) RESULT(io_rank)
1198 CLASS(mp_comm_type), INTENT(IN) :: comm
1199 INTEGER :: io_rank
1200
1201#if defined(__parallel)
1202 INTEGER :: ierr
1203 LOGICAL :: flag
1204 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1205
1206 CALL mpi_comm_get_attr(comm%handle, mpi_io, attrval, flag, ierr)
1207 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_io_rank")
1208 IF (.NOT. flag) cpabort("IO rank not available!")
1209 io_rank = int(attrval, kind=kind(io_rank))
1210#else
1211 mark_used(comm)
1212 io_rank = 0
1213#endif
1214 END FUNCTION mp_comm_get_io_rank
1215
1216 FUNCTION mp_comm_get_wtime_is_global(comm) RESULT(wtime_is_global)
1217 CLASS(mp_comm_type), INTENT(IN) :: comm
1218 LOGICAL :: wtime_is_global
1219
1220#if defined(__parallel)
1221 INTEGER :: ierr
1222 LOGICAL :: flag
1223 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1224
1225 CALL mpi_comm_get_attr(comm%handle, mpi_tag_ub, attrval, flag, ierr)
1226 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_wtime_is_global")
1227 IF (.NOT. flag) cpabort("Synchronization state of WTIME not available!")
1228 wtime_is_global = (attrval == 1_mpi_address_kind)
1229#else
1230 mark_used(comm)
1231 wtime_is_global = .true.
1232#endif
1233 END FUNCTION mp_comm_get_wtime_is_global
1234
1235! **************************************************************************************************
1236!> \brief initializes the system default communicator
1237!> \param mp_comm [output] : handle of the default communicator
1238!> \par History
1239!> 2.2004 created [Joost VandeVondele ]
1240!> \note
1241!> should only be called once
1242! **************************************************************************************************
1243 SUBROUTINE mp_world_init(mp_comm)
1244 CLASS(mp_comm_type), INTENT(OUT) :: mp_comm
1245#if defined(__parallel)
1246 INTEGER :: ierr, provided_tsl
1247#if defined(__MIMIC)
1248 INTEGER :: mimic_handle
1249#endif
1250
1251!$OMP MASTER
1252#if defined(__DLAF) || defined(__OPENPMD)
1253 ! Both DLA-Future and (some IO backends of) the openPMD-api require
1254 ! that the MPI library supports THREAD_MULTIPLE mode
1255 CALL mpi_init_thread(mpi_thread_multiple, provided_tsl, ierr)
1256 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
1257 IF (provided_tsl < mpi_thread_multiple) THEN
1258 CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_MULTIPLE),"// &
1259 " required by DLA-Future/openPMD-api. Build CP2K without DLA-Future and openPMD-api.")
1260 END IF
1261#else
1262 CALL mpi_init_thread(mpi_thread_serialized, provided_tsl, ierr)
1263 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
1264 IF (provided_tsl < mpi_thread_serialized) THEN
1265 CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_SERIALIZED).")
1266 END IF
1267#endif
1268!$OMP END MASTER
1269 CALL mpi_comm_set_errhandler(mpi_comm_world, mpi_errors_return, ierr)
1270 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_set_errhandler @ mp_world_init")
1271#endif
1272 debug_comm_count = 1
1273 mp_comm = mp_comm_world
1274#if defined(__MIMIC)
1275 mimic_handle = mp_comm%get_handle()
1276 CALL mcl_initialize(mimic_handle)
1277 CALL mp_comm%set_handle(mimic_handle)
1278#if defined(__MPI_F08)
1279 mimic_comm_world%mpi_val = mimic_handle
1280#else
1281 mimic_comm_world = mimic_handle
1282#endif
1283#endif
1284 CALL mp_comm%init()
1285 CALL add_mp_perf_env()
1286 END SUBROUTINE mp_world_init
1287
1288! **************************************************************************************************
1289!> \brief re-create the system default communicator with a different MPI
1290!> rank order
1291!> \param mp_comm [output] : handle of the default communicator
1292!> \param mp_new_comm ...
1293!> \param ranks_order ...
1294!> \par History
1295!> 1.2012 created [ Christiane Pousa ]
1296!> \note
1297!> should only be called once, at very beginning of CP2K run
1298! **************************************************************************************************
1299 SUBROUTINE mp_reordering(mp_comm, mp_new_comm, ranks_order)
1300 CLASS(mp_comm_type), INTENT(IN) :: mp_comm
1301 CLASS(mp_comm_type), INTENT(out) :: mp_new_comm
1302 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: ranks_order
1303
1304 CHARACTER(len=*), PARAMETER :: routinen = 'mp_reordering'
1305
1306 INTEGER :: handle, ierr
1307#if defined(__parallel)
1308 mpi_group_type :: newgroup, oldgroup
1309#endif
1310
1311 CALL mp_timeset(routinen, handle)
1312 ierr = 0
1313#if defined(__parallel)
1314
1315 CALL mpi_comm_group(mp_comm%handle, oldgroup, ierr)
1316 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_reordering")
1317 CALL mpi_group_incl(oldgroup, SIZE(ranks_order), ranks_order, newgroup, ierr)
1318 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_incl @ mp_reordering")
1319
1320 CALL mpi_comm_create(mp_comm%handle, newgroup, mp_new_comm%handle, ierr)
1321 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_create @ mp_reordering")
1322
1323 CALL mpi_group_free(oldgroup, ierr)
1324 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1325 CALL mpi_group_free(newgroup, ierr)
1326 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1327
1328 CALL add_perf(perf_id=1, count=1)
1329#else
1330 mark_used(mp_comm)
1331 mark_used(ranks_order)
1332 mp_new_comm%handle = mp_comm_default_handle
1333#endif
1334 debug_comm_count = debug_comm_count + 1
1335 CALL mp_new_comm%init()
1336 CALL mp_timestop(handle)
1337 END SUBROUTINE mp_reordering
1338
1339! **************************************************************************************************
1340!> \brief finalizes the system default communicator
1341!> \par History
1342!> 2.2004 created [Joost VandeVondele]
1343! **************************************************************************************************
1344 SUBROUTINE mp_world_finalize()
1345
1346 CHARACTER(LEN=default_string_length) :: debug_comm_count_char
1347#if defined(__parallel)
1348 INTEGER :: ierr
1349#if defined(__MIMIC)
1350 CALL mpi_barrier(mimic_comm_world, ierr)
1351#else
1352 CALL mpi_barrier(mpi_comm_world, ierr) ! call mpi directly to avoid 0 stack pointer
1353#endif
1354#endif
1355 CALL rm_mp_perf_env()
1356
1357 debug_comm_count = debug_comm_count - 1
1358#if defined(__parallel)
1359 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_world_finalize")
1360#endif
1361 IF (debug_comm_count /= 0) THEN
1362 ! A bug, we're leaking or double-freeing communicators. Needs to be fixed where the leak happens.
1363 ! Memory leak checking might be helpful to locate the culprit
1364 WRITE (unit=debug_comm_count_char, fmt='(I2)') debug_comm_count
1365 CALL cp_abort(__location__, "mp_world_finalize: assert failed:"// &
1366 " leaking communicators "//adjustl(trim(debug_comm_count_char)))
1367 END IF
1368#if defined(__parallel)
1369 CALL mpi_finalize(ierr)
1370 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_finalize @ mp_world_finalize")
1371#endif
1372
1373 END SUBROUTINE mp_world_finalize
1374
1375! all the following routines should work for a given communicator, not MPI_WORLD
1376
1377! **************************************************************************************************
1378!> \brief globally stops all tasks
1379!> this is intended to be low level, most of CP2K should call cp_abort()
1380! **************************************************************************************************
1381 SUBROUTINE mp_abort()
1382 INTEGER :: ierr
1383#if defined(__MIMIC)
1384 LOGICAL :: mcl_initialized
1385#endif
1386
1387 ierr = 0
1388
1389#if !defined(__NO_ABORT)
1390#if defined(__parallel)
1391#if defined(__MIMIC)
1392 CALL mcl_is_initialized(mcl_initialized)
1393 IF (mcl_initialized) CALL mcl_abort(1, ierr)
1394#endif
1395 CALL mpi_abort(mpi_comm_world, 1, ierr)
1396#else
1397 CALL m_abort()
1398#endif
1399#endif
1400 ! this routine never returns and levels with non-zero exit code
1401 stop 1
1402 END SUBROUTINE mp_abort
1403
1404! **************************************************************************************************
1405!> \brief stops *after an mpi error* translating the error code
1406!> \param ierr an error code * returned by an mpi call *
1407!> \param prg_code ...
1408!> \note
1409!> this function is private to message_passing.F
1410! **************************************************************************************************
1411 SUBROUTINE mp_stop(ierr, prg_code)
1412 INTEGER, INTENT(IN) :: ierr
1413 CHARACTER(LEN=*), INTENT(IN) :: prg_code
1414
1415#if defined(__parallel)
1416 INTEGER :: istat, len
1417 CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: error_string
1418 CHARACTER(LEN=MPI_MAX_ERROR_STRING + 512) :: full_error
1419#else
1420 CHARACTER(LEN=512) :: full_error
1421#endif
1422
1423#if defined(__parallel)
1424 CALL mpi_error_string(ierr, error_string, len, istat)
1425 WRITE (full_error, '(A,I0,A)') ' MPI error ', ierr, ' in '//trim(prg_code)//' : '//error_string(1:len)
1426#else
1427 WRITE (full_error, '(A,I0,A)') ' MPI error (!?) ', ierr, ' in '//trim(prg_code)
1428#endif
1429
1430 cpabort(full_error)
1431
1432 END SUBROUTINE mp_stop
1433
1434! **************************************************************************************************
1435!> \brief synchronizes with a barrier a given group of mpi tasks
1436!> \param group mpi communicator
1437! **************************************************************************************************
1438 SUBROUTINE mp_sync(comm)
1439 CLASS(mp_comm_type), INTENT(IN) :: comm
1440
1441 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sync'
1442
1443 INTEGER :: handle, ierr
1444
1445 ierr = 0
1446 CALL mp_timeset(routinen, handle)
1447
1448#if defined(__parallel)
1449 CALL mpi_barrier(comm%handle, ierr)
1450 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_sync")
1451 CALL add_perf(perf_id=5, count=1)
1452#else
1453 mark_used(comm)
1454#endif
1455 CALL mp_timestop(handle)
1456
1457 END SUBROUTINE mp_sync
1458
1459! **************************************************************************************************
1460!> \brief synchronizes with a barrier a given group of mpi tasks
1461!> \param comm mpi communicator
1462!> \param request ...
1463! **************************************************************************************************
1464 SUBROUTINE mp_isync(comm, request)
1465 CLASS(mp_comm_type), INTENT(IN) :: comm
1466 TYPE(mp_request_type), INTENT(OUT) :: request
1467
1468 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isync'
1469
1470 INTEGER :: handle, ierr
1471
1472 ierr = 0
1473 CALL mp_timeset(routinen, handle)
1474
1475#if defined(__parallel)
1476 CALL mpi_ibarrier(comm%handle, request%handle, ierr)
1477 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibarrier @ mp_isync")
1478 CALL add_perf(perf_id=26, count=1)
1479#else
1480 mark_used(comm)
1481 request = mp_request_null
1482#endif
1483 CALL mp_timestop(handle)
1484
1485 END SUBROUTINE mp_isync
1486
1487! **************************************************************************************************
1488!> \brief returns task id for a given mpi communicator
1489!> \param taskid The ID of the communicator
1490!> \param comm mpi communicator
1491! **************************************************************************************************
1492 SUBROUTINE mp_comm_rank(taskid, comm)
1493
1494 INTEGER, INTENT(OUT) :: taskid
1495 CLASS(mp_comm_type), INTENT(IN) :: comm
1496
1497 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_rank'
1498
1499 INTEGER :: handle
1500#if defined(__parallel)
1501 INTEGER :: ierr
1502#endif
1503
1504 CALL mp_timeset(routinen, handle)
1505
1506#if defined(__parallel)
1507 CALL mpi_comm_rank(comm%handle, taskid, ierr)
1508 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_rank")
1509#else
1510 mark_used(comm)
1511 taskid = 0
1512#endif
1513 CALL mp_timestop(handle)
1514
1515 END SUBROUTINE mp_comm_rank
1516
1517! **************************************************************************************************
1518!> \brief returns number of tasks for a given mpi communicator
1519!> \param numtask ...
1520!> \param comm mpi communicator
1521! **************************************************************************************************
1522 SUBROUTINE mp_comm_size(numtask, comm)
1523
1524 INTEGER, INTENT(OUT) :: numtask
1525 CLASS(mp_comm_type), INTENT(IN) :: comm
1526
1527 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_size'
1528
1529 INTEGER :: handle
1530#if defined(__parallel)
1531 INTEGER :: ierr
1532#endif
1533
1534 CALL mp_timeset(routinen, handle)
1535
1536#if defined(__parallel)
1537 CALL mpi_comm_size(comm%handle, numtask, ierr)
1538 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_size")
1539#else
1540 mark_used(comm)
1541 numtask = 1
1542#endif
1543 CALL mp_timestop(handle)
1544
1545 END SUBROUTINE mp_comm_size
1546
1547! **************************************************************************************************
1548!> \brief returns info for a given Cartesian MPI communicator
1549!> \param comm ...
1550!> \param ndims ...
1551!> \param dims ...
1552!> \param task_coor ...
1553!> \param periods ...
1554! **************************************************************************************************
1555 SUBROUTINE mp_cart_get(comm, dims, task_coor, periods)
1556
1557 CLASS(mp_cart_type), INTENT(IN) :: comm
1558 INTEGER, INTENT(OUT), OPTIONAL :: dims(comm%ndims), task_coor(comm%ndims)
1559 LOGICAL, INTENT(out), OPTIONAL :: periods(comm%ndims)
1560
1561 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_get'
1562
1563 INTEGER :: handle
1564#if defined(__parallel)
1565 INTEGER :: ierr
1566 INTEGER :: my_dims(comm%ndims), my_task_coor(comm%ndims)
1567 LOGICAL :: my_periods(comm%ndims)
1568#endif
1569
1570 CALL mp_timeset(routinen, handle)
1571
1572#if defined(__parallel)
1573 CALL mpi_cart_get(comm%handle, comm%ndims, my_dims, my_periods, my_task_coor, ierr)
1574 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_cart_get")
1575 IF (PRESENT(dims)) dims = my_dims
1576 IF (PRESENT(task_coor)) task_coor = my_task_coor
1577 IF (PRESENT(periods)) periods = my_periods
1578#else
1579 mark_used(comm)
1580 IF (PRESENT(task_coor)) task_coor = 0
1581 IF (PRESENT(dims)) dims = 1
1582 IF (PRESENT(periods)) periods = .false.
1583#endif
1584 CALL mp_timestop(handle)
1585
1586 END SUBROUTINE mp_cart_get
1587
1588 INTEGER ELEMENTAL function mp_comm_get_ndims(comm)
1589 CLASS(mp_comm_type), INTENT(IN) :: comm
1590
1591 mp_comm_get_ndims = comm%ndims
1592
1593 END FUNCTION
1594
1595! **************************************************************************************************
1596!> \brief creates a cartesian communicator from any communicator
1597!> \param comm_old ...
1598!> \param ndims ...
1599!> \param dims ...
1600!> \param pos ...
1601!> \param comm_cart ...
1602! **************************************************************************************************
1603 SUBROUTINE mp_cart_create(comm_old, ndims, dims, comm_cart)
1604
1605 CLASS(mp_comm_type), INTENT(IN) :: comm_old
1606 INTEGER, INTENT(IN) :: ndims
1607 INTEGER, INTENT(INOUT) :: dims(ndims)
1608 CLASS(mp_cart_type), INTENT(OUT) :: comm_cart
1609
1610 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_create'
1611
1612 INTEGER :: handle, ierr
1613#if defined(__parallel)
1614 LOGICAL, DIMENSION(1:ndims) :: period
1615 LOGICAL :: reorder
1616#endif
1617
1618 ierr = 0
1619 CALL mp_timeset(routinen, handle)
1620
1621 comm_cart%handle = comm_old%handle
1622#if defined(__parallel)
1623
1624 IF (any(dims == 0)) CALL mpi_dims_create(comm_old%num_pe, ndims, dims, ierr)
1625 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_cart_create")
1626
1627 ! FIX ME. Quick hack to avoid problems with realspace grids for compilers
1628 ! like IBM that actually reorder the processors when creating the new
1629 ! communicator
1630 reorder = .false.
1631 period = .true.
1632 CALL mpi_cart_create(comm_old%handle, ndims, dims, period, reorder, comm_cart%handle, &
1633 ierr)
1634 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_create @ mp_cart_create")
1635 CALL add_perf(perf_id=1, count=1)
1636#else
1637 dims = 1
1638 comm_cart%handle = mp_comm_default_handle
1639#endif
1640 comm_cart%ndims = ndims
1641 debug_comm_count = debug_comm_count + 1
1642 CALL comm_cart%init()
1643 CALL mp_timestop(handle)
1644
1645 END SUBROUTINE mp_cart_create
1646
1647! **************************************************************************************************
1648!> \brief wrapper to MPI_Cart_coords
1649!> \param comm ...
1650!> \param rank ...
1651!> \param coords ...
1652! **************************************************************************************************
1653 SUBROUTINE mp_cart_coords(comm, rank, coords)
1654
1655 CLASS(mp_cart_type), INTENT(IN) :: comm
1656 INTEGER, INTENT(IN) :: rank
1657 INTEGER, DIMENSION(:), INTENT(OUT) :: coords
1658
1659 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_coords'
1660
1661 INTEGER :: handle, ierr, m
1662
1663 ierr = 0
1664 CALL mp_timeset(routinen, handle)
1665
1666 m = SIZE(coords)
1667#if defined(__parallel)
1668 CALL mpi_cart_coords(comm%handle, rank, m, coords, ierr)
1669 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_coords @ mp_cart_coords")
1670#else
1671 coords = 0
1672 mark_used(rank)
1673 mark_used(comm)
1674#endif
1675 CALL mp_timestop(handle)
1676
1677 END SUBROUTINE mp_cart_coords
1678
1679! **************************************************************************************************
1680!> \brief wrapper to MPI_Comm_compare
1681!> \param comm1 ...
1682!> \param comm2 ...
1683!> \param res ...
1684! **************************************************************************************************
1685 FUNCTION mp_comm_compare(comm1, comm2) RESULT(res)
1686
1687 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
1688 INTEGER :: res
1689
1690 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_compare'
1691
1692 INTEGER :: handle
1693#if defined(__parallel)
1694 INTEGER :: ierr, iout
1695#endif
1696
1697 CALL mp_timeset(routinen, handle)
1698
1699 res = 0
1700#if defined(__parallel)
1701 CALL mpi_comm_compare(comm1%handle, comm2%handle, iout, ierr)
1702 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_compare @ mp_comm_compare")
1703 SELECT CASE (iout)
1704 CASE (mpi_ident)
1705 res = mp_comm_ident
1706 CASE (mpi_congruent)
1707 res = mp_comm_congruent
1708 CASE (mpi_similar)
1709 res = mp_comm_similar
1710 CASE (mpi_unequal)
1711 res = mp_comm_unequal
1712 CASE default
1713 cpabort("Unknown comparison state of the communicators!")
1714 END SELECT
1715#else
1716 mark_used(comm1)
1717 mark_used(comm2)
1718#endif
1719 CALL mp_timestop(handle)
1720
1721 END FUNCTION mp_comm_compare
1722
1723! **************************************************************************************************
1724!> \brief wrapper to MPI_Cart_sub
1725!> \param comm ...
1726!> \param rdim ...
1727!> \param sub_comm ...
1728! **************************************************************************************************
1729 SUBROUTINE mp_cart_sub(comm, rdim, sub_comm)
1730
1731 CLASS(mp_cart_type), INTENT(IN) :: comm
1732 LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: rdim
1733 CLASS(mp_cart_type), INTENT(OUT) :: sub_comm
1734
1735 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_sub'
1736
1737 INTEGER :: handle
1738#if defined(__parallel)
1739 INTEGER :: ierr
1740#endif
1741
1742 CALL mp_timeset(routinen, handle)
1743
1744#if defined(__parallel)
1745 CALL mpi_cart_sub(comm%handle, rdim, sub_comm%handle, ierr)
1746 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_sub @ mp_cart_sub")
1747#else
1748 mark_used(comm)
1749 mark_used(rdim)
1750 sub_comm%handle = mp_comm_default_handle
1751#endif
1752 sub_comm%ndims = count(rdim)
1753 debug_comm_count = debug_comm_count + 1
1754 CALL sub_comm%init()
1755 CALL mp_timestop(handle)
1756
1757 END SUBROUTINE mp_cart_sub
1758
1759! **************************************************************************************************
1760!> \brief wrapper to MPI_Comm_free
1761!> \param comm ...
1762! **************************************************************************************************
1763 SUBROUTINE mp_comm_free(comm)
1764
1765 CLASS(mp_comm_type), INTENT(INOUT) :: comm
1766
1767 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_free'
1768
1769 INTEGER :: handle
1770 LOGICAL :: free_comm
1771#if defined(__parallel)
1772 INTEGER :: ierr
1773#endif
1774
1775 free_comm = .true.
1776 SELECT TYPE (comm)
1777 CLASS IS (mp_para_env_type)
1778 free_comm = .false.
1779 IF (comm%ref_count <= 0) &
1780 cpabort("para_env%ref_count <= 0")
1781 comm%ref_count = comm%ref_count - 1
1782 IF (comm%ref_count <= 0) THEN
1783 free_comm = comm%owns_group
1784 END IF
1785 CLASS IS (mp_para_cart_type)
1786 free_comm = .false.
1787 IF (comm%ref_count <= 0) &
1788 cpabort("para_cart%ref_count <= 0")
1789 comm%ref_count = comm%ref_count - 1
1790 IF (comm%ref_count <= 0) THEN
1791 free_comm = comm%owns_group
1792 END IF
1793 END SELECT
1794
1795 CALL mp_timeset(routinen, handle)
1796
1797 IF (free_comm) THEN
1798#if defined(__parallel)
1799 CALL mpi_comm_free(comm%handle, ierr)
1800 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_free @ mp_comm_free")
1801#else
1802 comm%handle = mp_comm_null_handle
1803#endif
1804 debug_comm_count = debug_comm_count - 1
1805 END IF
1806
1807 SELECT TYPE (comm)
1808 CLASS IS (mp_cart_type)
1809 DEALLOCATE (comm%periodic, comm%mepos_cart, comm%num_pe_cart)
1810 END SELECT
1811
1812 CALL mp_timestop(handle)
1813
1814 END SUBROUTINE mp_comm_free
1815
1816! **************************************************************************************************
1817!> \brief check whether the environment exists
1818!> \param para_env ...
1819!> \return ...
1820! **************************************************************************************************
1821 ELEMENTAL LOGICAL FUNCTION mp_para_env_is_valid(para_env)
1822 CLASS(mp_para_env_type), INTENT(IN) :: para_env
1823
1824 mp_para_env_is_valid = para_env%ref_count > 0
1825
1826 END FUNCTION mp_para_env_is_valid
1827
1828! **************************************************************************************************
1829!> \brief increase the reference counter but ensure that you free it later
1830!> \param para_env ...
1831! **************************************************************************************************
1832 ELEMENTAL SUBROUTINE mp_para_env_retain(para_env)
1833 CLASS(mp_para_env_type), INTENT(INOUT) :: para_env
1834
1835 para_env%ref_count = para_env%ref_count + 1
1836
1837 END SUBROUTINE mp_para_env_retain
1838
1839! **************************************************************************************************
1840!> \brief check whether the given environment is valid, i.e. existent
1841!> \param cart ...
1842!> \return ...
1843! **************************************************************************************************
1844 ELEMENTAL LOGICAL FUNCTION mp_para_cart_is_valid(cart)
1845 CLASS(mp_para_cart_type), INTENT(IN) :: cart
1846
1847 mp_para_cart_is_valid = cart%ref_count > 0
1848
1849 END FUNCTION mp_para_cart_is_valid
1850
1851! **************************************************************************************************
1852!> \brief increase the reference counter, don't forget to free it later
1853!> \param cart ...
1854! **************************************************************************************************
1855 ELEMENTAL SUBROUTINE mp_para_cart_retain(cart)
1856 CLASS(mp_para_cart_type), INTENT(INOUT) :: cart
1857
1858 cart%ref_count = cart%ref_count + 1
1859
1860 END SUBROUTINE mp_para_cart_retain
1861
1862! **************************************************************************************************
1863!> \brief wrapper to MPI_Comm_dup
1864!> \param comm1 ...
1865!> \param comm2 ...
1866! **************************************************************************************************
1867 SUBROUTINE mp_comm_dup(comm1, comm2)
1868
1869 CLASS(mp_comm_type), INTENT(IN) :: comm1
1870 CLASS(mp_comm_type), INTENT(OUT) :: comm2
1871
1872 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_dup'
1873
1874 INTEGER :: handle
1875#if defined(__parallel)
1876 INTEGER :: ierr
1877#endif
1878
1879 CALL mp_timeset(routinen, handle)
1880
1881#if defined(__parallel)
1882 CALL mpi_comm_dup(comm1%handle, comm2%handle, ierr)
1883 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_dup @ mp_comm_dup")
1884#else
1885 mark_used(comm1)
1886 comm2%handle = mp_comm_default_handle
1887#endif
1888 comm2%ndims = comm1%ndims
1889 debug_comm_count = debug_comm_count + 1
1890 CALL comm2%init()
1891 CALL mp_timestop(handle)
1892
1893 END SUBROUTINE mp_comm_dup
1894
1895! **************************************************************************************************
1896!> \brief Implements a simple assignment function to overload the assignment operator
1897!> \param comm_new communicator on the r.h.s. of the assignment operator
1898!> \param comm_old communicator on the l.h.s. of the assignment operator
1899! **************************************************************************************************
1900 ELEMENTAL IMPURE SUBROUTINE mp_comm_assign(comm_new, comm_old)
1901 CLASS(mp_comm_type), INTENT(IN) :: comm_old
1902 CLASS(mp_comm_type), INTENT(OUT) :: comm_new
1903
1904 comm_new%handle = comm_old%handle
1905 comm_new%ndims = comm_old%ndims
1906 CALL comm_new%init(.false.)
1907 END SUBROUTINE
1908
1909! **************************************************************************************************
1910!> \brief check whether the local process is the source process
1911!> \param para_env ...
1912!> \return ...
1913! **************************************************************************************************
1914 ELEMENTAL LOGICAL FUNCTION mp_comm_is_source(comm)
1915 CLASS(mp_comm_type), INTENT(IN) :: comm
1916
1917 mp_comm_is_source = comm%source == comm%mepos
1918
1919 END FUNCTION mp_comm_is_source
1920
1921! **************************************************************************************************
1922!> \brief Initializes the communicator (mostly relevant for its derived classes)
1923!> \param comm ...
1924! **************************************************************************************************
1925 ELEMENTAL IMPURE SUBROUTINE mp_comm_init(comm, owns_group)
1926 CLASS(mp_comm_type), INTENT(INOUT) :: comm
1927 LOGICAL, INTENT(IN), OPTIONAL :: owns_group
1928
1929 IF (comm%handle mpi_get_comp /= mp_comm_null_handle mpi_get_comp) THEN
1930 comm%source = 0
1931 CALL comm%get_size(comm%num_pe)
1932 CALL comm%get_rank(comm%mepos)
1933 END IF
1934
1935 SELECT TYPE (comm)
1936 CLASS IS (mp_cart_type)
1937 IF (ALLOCATED(comm%periodic)) DEALLOCATE (comm%periodic)
1938 IF (ALLOCATED(comm%mepos_cart)) DEALLOCATE (comm%mepos_cart)
1939 IF (ALLOCATED(comm%num_pe_cart)) DEALLOCATE (comm%num_pe_cart)
1940
1941 associate(ndims => comm%ndims)
1942
1943 ALLOCATE (comm%periodic(ndims), comm%mepos_cart(ndims), &
1944 comm%num_pe_cart(ndims))
1945 END associate
1946
1947 comm%mepos_cart = 0
1948 comm%periodic = .false.
1949 IF (comm%handle mpi_get_comp /= mp_comm_null_handle mpi_get_comp) THEN
1950 CALL comm%get_info_cart(comm%num_pe_cart, comm%mepos_cart, &
1951 comm%periodic)
1952 END IF
1953 END SELECT
1954
1955 SELECT TYPE (comm)
1956 CLASS IS (mp_para_env_type)
1957 IF (PRESENT(owns_group)) comm%owns_group = owns_group
1958 comm%ref_count = 1
1959 CLASS IS (mp_para_cart_type)
1960 IF (PRESENT(owns_group)) comm%owns_group = owns_group
1961 comm%ref_count = 1
1962 END SELECT
1963
1964 END SUBROUTINE
1965
1966! **************************************************************************************************
1967!> \brief creates a new para environment
1968!> \param para_env the new parallel environment
1969!> \param group the id of the actual mpi_group
1970!> \par History
1971!> 08.2002 created [fawzi]
1972!> \author Fawzi Mohamed
1973! **************************************************************************************************
1974 SUBROUTINE mp_para_env_create(para_env, group)
1975 TYPE(mp_para_env_type), POINTER :: para_env
1976 CLASS(mp_comm_type), INTENT(in) :: group
1977
1978 IF (ASSOCIATED(para_env)) &
1979 cpabort("The passed para_env must not be associated!")
1980 ALLOCATE (para_env)
1981 para_env%mp_comm_type = group
1982 CALL para_env%init()
1983 END SUBROUTINE mp_para_env_create
1984
1985! **************************************************************************************************
1986!> \brief releases the para object (to be called when you don't want anymore
1987!> the shared copy of this object)
1988!> \param para_env the new group
1989!> \par History
1990!> 08.2002 created [fawzi]
1991!> \author Fawzi Mohamed
1992!> \note
1993!> to avoid circular dependencies cp_log_handling has a private copy
1994!> of this method (see cp_log_handling:my_mp_para_env_release)!
1995! **************************************************************************************************
1996 SUBROUTINE mp_para_env_release(para_env)
1997 TYPE(mp_para_env_type), POINTER :: para_env
1998
1999 IF (ASSOCIATED(para_env)) THEN
2000 CALL para_env%free()
2001 IF (.NOT. para_env%is_valid()) DEALLOCATE (para_env)
2002 END IF
2003 NULLIFY (para_env)
2004 END SUBROUTINE mp_para_env_release
2005
2006! **************************************************************************************************
2007!> \brief creates a cart (multidimensional parallel environment)
2008!> \param cart the cart environment to create
2009!> \param group the mpi communicator
2010!> \author fawzi
2011! **************************************************************************************************
2012 SUBROUTINE mp_para_cart_create(cart, group)
2013 TYPE(mp_para_cart_type), POINTER, INTENT(OUT) :: cart
2014 CLASS(mp_comm_type), INTENT(in) :: group
2015
2016 IF (ASSOCIATED(cart)) &
2017 cpabort("The passed para_cart must not be associated!")
2018 ALLOCATE (cart)
2019 cart%mp_cart_type = group
2020 CALL cart%init()
2021
2022 END SUBROUTINE mp_para_cart_create
2023
2024! **************************************************************************************************
2025!> \brief releases the given cart
2026!> \param cart the cart to release
2027!> \author fawzi
2028! **************************************************************************************************
2029 SUBROUTINE mp_para_cart_release(cart)
2030 TYPE(mp_para_cart_type), POINTER :: cart
2031
2032 IF (ASSOCIATED(cart)) THEN
2033 CALL cart%free()
2034 IF (.NOT. cart%is_valid()) DEALLOCATE (cart)
2035 END IF
2036 NULLIFY (cart)
2037 END SUBROUTINE mp_para_cart_release
2038
2039! **************************************************************************************************
2040!> \brief wrapper to MPI_Group_translate_ranks
2041!> \param comm1 ...
2042!> \param comm2 ...
2043!> \param rank ...
2044! **************************************************************************************************
2045 SUBROUTINE mp_rank_compare(comm1, comm2, rank)
2046
2047 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
2048 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rank
2049
2050 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rank_compare'
2051
2052 INTEGER :: handle
2053#if defined(__parallel)
2054 INTEGER :: i, ierr, n, n1, n2
2055 INTEGER, ALLOCATABLE, DIMENSION(:) :: rin
2056 mpi_group_type :: g1, g2
2057#endif
2058
2059 CALL mp_timeset(routinen, handle)
2060
2061 rank = 0
2062#if defined(__parallel)
2063 CALL mpi_comm_size(comm1%handle, n1, ierr)
2064 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
2065 CALL mpi_comm_size(comm2%handle, n2, ierr)
2066 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
2067 n = max(n1, n2)
2068 CALL mpi_comm_group(comm1%handle, g1, ierr)
2069 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
2070 CALL mpi_comm_group(comm2%handle, g2, ierr)
2071 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
2072 ALLOCATE (rin(0:n - 1), stat=ierr)
2073 IF (ierr /= 0) &
2074 cpabort("allocate @ mp_rank_compare")
2075 DO i = 0, n - 1
2076 rin(i) = i
2077 END DO
2078 CALL mpi_group_translate_ranks(g1, n, rin, g2, rank, ierr)
2079 IF (ierr /= 0) CALL mp_stop(ierr, &
2080 "mpi_group_translate_rank @ mp_rank_compare")
2081 CALL mpi_group_free(g1, ierr)
2082 IF (ierr /= 0) &
2083 cpabort("group_free @ mp_rank_compare")
2084 CALL mpi_group_free(g2, ierr)
2085 IF (ierr /= 0) &
2086 cpabort("group_free @ mp_rank_compare")
2087 DEALLOCATE (rin)
2088#else
2089 mark_used(comm1)
2090 mark_used(comm2)
2091#endif
2092 CALL mp_timestop(handle)
2093
2094 END SUBROUTINE mp_rank_compare
2095
2096! **************************************************************************************************
2097!> \brief wrapper to MPI_Dims_create
2098!> \param nodes ...
2099!> \param dims ...
2100! **************************************************************************************************
2101 SUBROUTINE mp_dims_create(nodes, dims)
2102
2103 INTEGER, INTENT(IN) :: nodes
2104 INTEGER, DIMENSION(:), INTENT(INOUT) :: dims
2105
2106 CHARACTER(len=*), PARAMETER :: routinen = 'mp_dims_create'
2107
2108 INTEGER :: handle, ndim
2109#if defined(__parallel)
2110 INTEGER :: ierr
2111#endif
2112
2113 CALL mp_timeset(routinen, handle)
2114
2115 ndim = SIZE(dims)
2116#if defined(__parallel)
2117 IF (any(dims == 0)) CALL mpi_dims_create(nodes, ndim, dims, ierr)
2118 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_dims_create")
2119#else
2120 dims = 1
2121 mark_used(nodes)
2122#endif
2123 CALL mp_timestop(handle)
2124
2125 END SUBROUTINE mp_dims_create
2126
2127! **************************************************************************************************
2128!> \brief wrapper to MPI_Cart_rank
2129!> \param comm ...
2130!> \param pos ...
2131!> \param rank ...
2132! **************************************************************************************************
2133 SUBROUTINE mp_cart_rank(comm, pos, rank)
2134 CLASS(mp_cart_type), INTENT(IN) :: comm
2135 INTEGER, DIMENSION(:), INTENT(IN) :: pos
2136 INTEGER, INTENT(OUT) :: rank
2137
2138 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_rank'
2139
2140 INTEGER :: handle
2141#if defined(__parallel)
2142 INTEGER :: ierr
2143#endif
2144
2145 CALL mp_timeset(routinen, handle)
2146
2147#if defined(__parallel)
2148 CALL mpi_cart_rank(comm%handle, pos, rank, ierr)
2149 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_rank @ mp_cart_rank")
2150#else
2151 rank = 0
2152 mark_used(comm)
2153 mark_used(pos)
2154#endif
2155 CALL mp_timestop(handle)
2156
2157 END SUBROUTINE mp_cart_rank
2158
2159! **************************************************************************************************
2160!> \brief waits for completion of the given request
2161!> \param request ...
2162!> \par History
2163!> 08.2003 created [f&j]
2164!> \author joost & fawzi
2165!> \note
2166!> see isendrecv
2167! **************************************************************************************************
2168 SUBROUTINE mp_wait(request)
2169 CLASS(mp_request_type), INTENT(inout) :: request
2170
2171 CHARACTER(len=*), PARAMETER :: routinen = 'mp_wait'
2172
2173 INTEGER :: handle
2174#if defined(__parallel)
2175 INTEGER :: ierr
2176#endif
2177
2178 CALL mp_timeset(routinen, handle)
2179
2180#if defined(__parallel)
2181
2182 CALL mpi_wait(request%handle, mpi_status_ignore, ierr)
2183 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_wait @ mp_wait")
2184
2185 CALL add_perf(perf_id=9, count=1)
2186#else
2187 request%handle = mp_request_null_handle
2188#endif
2189 CALL mp_timestop(handle)
2190 END SUBROUTINE mp_wait
2191
2192! **************************************************************************************************
2193!> \brief waits for completion of the given requests
2194!> \param requests ...
2195!> \par History
2196!> 08.2003 created [f&j]
2197!> \author joost & fawzi
2198!> \note
2199!> see isendrecv
2200! **************************************************************************************************
2201 SUBROUTINE mp_waitall_1(requests)
2202 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2203
2204 CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_1'
2205
2206 INTEGER :: handle
2207#if defined(__parallel)
2208 INTEGER :: count, ierr
2209#endif
2210
2211 CALL mp_timeset(routinen, handle)
2212#if defined(__parallel)
2213 count = SIZE(requests)
2214 CALL mpi_waitall_internal(count, requests, ierr)
2215 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_1")
2216 CALL add_perf(perf_id=9, count=1)
2217#else
2218 requests = mp_request_null
2219#endif
2220 CALL mp_timestop(handle)
2221 END SUBROUTINE mp_waitall_1
2222
2223! **************************************************************************************************
2224!> \brief waits for completion of the given requests
2225!> \param requests ...
2226!> \par History
2227!> 08.2003 created [f&j]
2228!> \author joost & fawzi
2229! **************************************************************************************************
2230 SUBROUTINE mp_waitall_2(requests)
2231 TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2232
2233 CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_2'
2234
2235 INTEGER :: handle
2236#if defined(__parallel)
2237 INTEGER :: count, ierr
2238#endif
2239
2240 CALL mp_timeset(routinen, handle)
2241#if defined(__parallel)
2242 count = SIZE(requests)
2243 CALL mpi_waitall_internal(count, requests, ierr)
2244 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_2")
2245 CALL add_perf(perf_id=9, count=1)
2246#else
2247 requests = mp_request_null
2248#endif
2249 CALL mp_timestop(handle)
2250 END SUBROUTINE mp_waitall_2
2251
2252! **************************************************************************************************
2253!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2254!> the issue is with the rank or requests
2255!> \param count ...
2256!> \param array_of_requests ...
2257!> \param ierr ...
2258!> \author Joost VandeVondele
2259! **************************************************************************************************
2260#if defined(__parallel)
2261 SUBROUTINE mpi_waitall_internal(count, array_of_requests, ierr)
2262 INTEGER, INTENT(in) :: count
2263 TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2264 INTEGER, INTENT(out) :: ierr
2265
2266 mpi_request_type, ALLOCATABLE, DIMENSION(:), TARGET :: request_handles
2267
2268 ALLOCATE (request_handles(count), source=array_of_requests(1:count)%handle)
2269 CALL mpi_waitall(count, request_handles, mpi_statuses_ignore, ierr)
2270 array_of_requests(1:count)%handle = request_handles(:)
2271 DEALLOCATE (request_handles)
2272
2273 END SUBROUTINE mpi_waitall_internal
2274#endif
2275
2276! **************************************************************************************************
2277!> \brief waits for completion of any of the given requests
2278!> \param requests ...
2279!> \param completed ...
2280!> \par History
2281!> 09.2008 created
2282!> \author Iain Bethune (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
2283! **************************************************************************************************
2284 SUBROUTINE mp_waitany(requests, completed)
2285 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2286 INTEGER, INTENT(out) :: completed
2287
2288 CHARACTER(len=*), PARAMETER :: routinen = 'mp_waitany'
2289
2290 INTEGER :: handle
2291#if defined(__parallel)
2292 INTEGER :: count, ierr
2293 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2294#endif
2295
2296 CALL mp_timeset(routinen, handle)
2297
2298#if defined(__parallel)
2299 count = SIZE(requests)
2300 ! Convert CP2K's request_handles to the plain handle for the library
2301 ALLOCATE (request_handles(count), source=requests(1:count)%handle)
2302
2303 CALL mpi_waitany(count, request_handles, completed, mpi_status_ignore, ierr)
2304 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitany @ mp_waitany")
2305
2306 ! Convert the plain handles to CP2K handles
2307 requests(1:count)%handle = request_handles(:)
2308 DEALLOCATE (request_handles)
2309 CALL add_perf(perf_id=9, count=1)
2310#else
2311 requests = mp_request_null
2312 completed = 1
2313#endif
2314 CALL mp_timestop(handle)
2315 END SUBROUTINE mp_waitany
2316
2317! **************************************************************************************************
2318!> \brief Tests for completion of the given requests.
2319!> \brief We use mpi_test so that we can use a single status.
2320!> \param requests the list of requests to test
2321!> \return logical which determines if requests are complete
2322!> \par History
2323!> 3.2016 adapted to any shape [Nico Holmberg]
2324!> \author Alfio Lazzaro
2325! **************************************************************************************************
2326 FUNCTION mp_testall_tv(requests) RESULT(flag)
2327 TYPE(mp_request_type), DIMENSION(:), INTENT(INOUT) :: requests
2328 LOGICAL :: flag
2329
2330#if defined(__parallel)
2331 INTEGER :: i, ierr
2332 LOGICAL, DIMENSION(:), POINTER :: flags
2333#endif
2334
2335 flag = .true.
2336
2337#if defined(__parallel)
2338 ALLOCATE (flags(SIZE(requests)))
2339 DO i = 1, SIZE(requests)
2340 CALL mpi_test(requests(i)%handle, flags(i), mpi_status_ignore, ierr)
2341 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testall @ mp_testall_tv")
2342 flag = flag .AND. flags(i)
2343 END DO
2344 DEALLOCATE (flags)
2345#else
2346 requests = mp_request_null
2347#endif
2348 END FUNCTION mp_testall_tv
2349
2350! **************************************************************************************************
2351!> \brief Tests for completion of the given request.
2352!> \param request the request
2353!> \param flag logical which determines if the request is completed
2354!> \par History
2355!> 3.2016 created
2356!> \author Nico Holmberg
2357! **************************************************************************************************
2358 FUNCTION mp_test_1(request) RESULT(flag)
2359 CLASS(mp_request_type), INTENT(inout) :: request
2360 LOGICAL :: flag
2361
2362#if defined(__parallel)
2363 INTEGER :: ierr
2364
2365 CALL mpi_test(request%handle, flag, mpi_status_ignore, ierr)
2366 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_test @ mp_test_1")
2367#else
2368 mark_used(request)
2369 flag = .true.
2370#endif
2371 END FUNCTION mp_test_1
2372
2373! **************************************************************************************************
2374!> \brief tests for completion of the given requests
2375!> \param requests ...
2376!> \param completed ...
2377!> \param flag ...
2378!> \par History
2379!> 08.2011 created
2380!> \author Iain Bethune
2381! **************************************************************************************************
2382 SUBROUTINE mp_testany_1(requests, completed, flag)
2383 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2384 INTEGER, INTENT(out), OPTIONAL :: completed
2385 LOGICAL, INTENT(out), OPTIONAL :: flag
2386
2387#if defined(__parallel)
2388 INTEGER :: completed_l, count, ierr
2389 LOGICAL :: flag_l
2390
2391 count = SIZE(requests)
2392
2393 CALL mpi_testany_internal(count, requests, completed_l, flag_l, mpi_status_ignore, ierr)
2394 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_1 @ mp_testany")
2395
2396 IF (PRESENT(completed)) completed = completed_l
2397 IF (PRESENT(flag)) flag = flag_l
2398#else
2399 mark_used(requests)
2400 IF (PRESENT(completed)) completed = 1
2401 IF (PRESENT(flag)) flag = .true.
2402#endif
2403 END SUBROUTINE mp_testany_1
2404
2405! **************************************************************************************************
2406!> \brief tests for completion of the given requests
2407!> \param requests ...
2408!> \param completed ...
2409!> \param flag ...
2410!> \par History
2411!> 08.2011 created
2412!> \author Iain Bethune
2413! **************************************************************************************************
2414 SUBROUTINE mp_testany_2(requests, completed, flag)
2415 TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2416 INTEGER, INTENT(out), OPTIONAL :: completed
2417 LOGICAL, INTENT(out), OPTIONAL :: flag
2418
2419#if defined(__parallel)
2420 INTEGER :: completed_l, count, ierr
2421 LOGICAL :: flag_l
2422
2423 count = SIZE(requests)
2424
2425 CALL mpi_testany_internal(count, requests, completed_l, flag_l, mpi_status_ignore, ierr)
2426 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_2 @ mp_testany")
2427
2428 IF (PRESENT(completed)) completed = completed_l
2429 IF (PRESENT(flag)) flag = flag_l
2430#else
2431 mark_used(requests)
2432 IF (PRESENT(completed)) completed = 1
2433 IF (PRESENT(flag)) flag = .true.
2434#endif
2435 END SUBROUTINE mp_testany_2
2436
2437! **************************************************************************************************
2438!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2439!> the issue is with the rank or requests
2440!> \param count ...
2441!> \param array_of_requests ...
2442!> \param index ...
2443!> \param flag ...
2444!> \param status ...
2445!> \param ierr ...
2446!> \author Joost VandeVondele
2447! **************************************************************************************************
2448#if defined(__parallel)
2449 SUBROUTINE mpi_testany_internal(count, array_of_requests, index, flag, status, ierr)
2450 INTEGER, INTENT(in) :: count
2451 TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2452 INTEGER, INTENT(out) :: index
2453 LOGICAL, INTENT(out) :: flag
2454 mpi_status_type, INTENT(out) :: status
2455 INTEGER, INTENT(out) :: ierr
2456
2457 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2458
2459 ALLOCATE (request_handles(count), source=array_of_requests(1:count)%handle)
2460 CALL mpi_testany(count, request_handles, index, flag, status, ierr)
2461 array_of_requests(1:count)%handle = request_handles(:)
2462 DEALLOCATE (request_handles)
2463
2464 END SUBROUTINE mpi_testany_internal
2465#endif
2466
2467! **************************************************************************************************
2468!> \brief the direct way to split a communicator each color is a sub_comm,
2469!> the rank order is according to the order in the orig comm
2470!> \param comm ...
2471!> \param sub_comm ...
2472!> \param color ...
2473!> \param key ...
2474!> \author Joost VandeVondele
2475! **************************************************************************************************
2476 SUBROUTINE mp_comm_split_direct(comm, sub_comm, color, key)
2477 CLASS(mp_comm_type), INTENT(in) :: comm
2478 CLASS(mp_comm_type), INTENT(OUT) :: sub_comm
2479 INTEGER, INTENT(in) :: color
2480 INTEGER, INTENT(in), OPTIONAL :: key
2481
2482 CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_split_direct'
2483
2484 INTEGER :: handle
2485#if defined(__parallel)
2486 INTEGER :: ierr, my_key
2487#endif
2488
2489 CALL mp_timeset(routinen, handle)
2490
2491#if defined(__parallel)
2492 my_key = 0
2493 IF (PRESENT(key)) my_key = key
2494 CALL mpi_comm_split(comm%handle, color, my_key, sub_comm%handle, ierr)
2495 IF (ierr /= mpi_success) CALL mp_stop(ierr, routinen)
2496 CALL add_perf(perf_id=10, count=1)
2497#else
2498 sub_comm%handle = mp_comm_default_handle
2499 mark_used(comm)
2500 mark_used(color)
2501 mark_used(key)
2502#endif
2503 debug_comm_count = debug_comm_count + 1
2504 CALL sub_comm%init()
2505 CALL mp_timestop(handle)
2506
2507 END SUBROUTINE mp_comm_split_direct
2508! **************************************************************************************************
2509!> \brief splits the given communicator in group in subgroups trying to organize
2510!> them in a way that the communication within each subgroup is
2511!> efficient (but not necessarily the communication between subgroups)
2512!> \param comm the mpi communicator that you want to split
2513!> \param sub_comm the communicator for the subgroup (created, needs to be freed later)
2514!> \param ngroups actual number of groups
2515!> \param group_distribution input : allocated with array with the nprocs entries (0 .. nprocs-1)
2516!> \param subgroup_min_size the minimum size of the subgroup
2517!> \param n_subgroups the number of subgroups wanted
2518!> \param group_partition n_subgroups sized array containing the number of cpus wanted per group.
2519!> should match the total number of cpus (only used if present and associated) (0..ngroups-1)
2520!> \param stride create groups using a stride (default=1) through the ranks of the comm to be split.
2521!> \par History
2522!> 10.2003 created [fawzi]
2523!> 02.2004 modified [Joost VandeVondele]
2524!> \author Fawzi Mohamed
2525!> \note
2526!> at least one of subgroup_min_size and n_subgroups is needed,
2527!> the other default to the value needed to use most processors.
2528!> if less cpus are present than needed for subgroup min size, n_subgroups,
2529!> just one comm is created that contains all cpus
2530! **************************************************************************************************
2531 SUBROUTINE mp_comm_split(comm, sub_comm, ngroups, group_distribution, &
2532 subgroup_min_size, n_subgroups, group_partition, stride)
2533 CLASS(mp_comm_type), INTENT(in) :: comm
2534 CLASS(mp_comm_type), INTENT(out) :: sub_comm
2535 INTEGER, INTENT(out) :: ngroups
2536 INTEGER, DIMENSION(0:), INTENT(INOUT) :: group_distribution
2537 INTEGER, INTENT(in), OPTIONAL :: subgroup_min_size, &
2538 n_subgroups
2539 INTEGER, DIMENSION(0:), INTENT(IN), OPTIONAL :: group_partition
2540 INTEGER, OPTIONAL, INTENT(IN) :: stride
2541
2542 CHARACTER(LEN=*), PARAMETER :: routineN = 'mp_comm_split', &
2543 routinep = modulen//':'//routinen
2544
2545 INTEGER :: handle, mepos, nnodes
2546#if defined(__parallel)
2547 INTEGER :: color, i, ierr, j, k, &
2548 my_subgroup_min_size, &
2549 istride, local_stride, irank
2550 INTEGER, DIMENSION(:), ALLOCATABLE :: rank_permutation
2551#endif
2552
2553 CALL mp_timeset(routinen, handle)
2554
2555 ! actual number of groups
2556
2557 IF (.NOT. PRESENT(subgroup_min_size) .AND. .NOT. PRESENT(n_subgroups)) THEN
2558 cpabort(routinep//" missing arguments")
2559 END IF
2560 IF (PRESENT(subgroup_min_size) .AND. PRESENT(n_subgroups)) THEN
2561 cpabort(routinep//" too many arguments")
2562 END IF
2563
2564 CALL comm%get_size(nnodes)
2565 CALL comm%get_rank(mepos)
2566
2567 IF (ubound(group_distribution, 1) /= nnodes - 1) THEN
2568 cpabort(routinep//" group_distribution wrong bounds")
2569 END IF
2570
2571#if defined(__parallel)
2572 IF (PRESENT(subgroup_min_size)) THEN
2573 IF (subgroup_min_size < 0 .OR. subgroup_min_size > nnodes) THEN
2574 cpabort(routinep//" subgroup_min_size too small or too large")
2575 END IF
2576 ngroups = nnodes/subgroup_min_size
2577 my_subgroup_min_size = subgroup_min_size
2578 ELSE ! n_subgroups
2579 IF (n_subgroups <= 0) THEN
2580 cpabort(routinep//" n_subgroups too small")
2581 END IF
2582 IF (nnodes/n_subgroups > 0) THEN ! we have a least one cpu per group
2583 ngroups = n_subgroups
2584 ELSE ! well, only one group then
2585 ngroups = 1
2586 END IF
2587 my_subgroup_min_size = nnodes/ngroups
2588 END IF
2589
2590 ! rank_permutation: is a permutation of ranks, so that groups are not necessarily continuous in rank of the master group
2591 ! 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
2592 ! (by setting stride equal to the number of mpi ranks per node), or by sharing a node between two groups (stride 2).
2593 ALLOCATE (rank_permutation(0:nnodes - 1))
2594 local_stride = 1
2595 IF (PRESENT(stride)) local_stride = stride
2596 k = 0
2597 DO istride = 1, local_stride
2598 DO irank = istride - 1, nnodes - 1, local_stride
2599 rank_permutation(k) = irank
2600 k = k + 1
2601 END DO
2602 END DO
2603
2604 DO i = 0, nnodes - 1
2605 group_distribution(rank_permutation(i)) = min(i/my_subgroup_min_size, ngroups - 1)
2606 END DO
2607 ! even the user gave a partition, see if we can use it to overwrite this choice
2608 IF (PRESENT(group_partition)) THEN
2609 IF (all(group_partition > 0) .AND. (sum(group_partition) == nnodes) .AND. (ngroups == SIZE(group_partition))) THEN
2610 k = 0
2611 DO i = 0, SIZE(group_partition) - 1
2612 DO j = 1, group_partition(i)
2613 group_distribution(rank_permutation(k)) = i
2614 k = k + 1
2615 END DO
2616 END DO
2617 ELSE
2618 ! just ignore silently as we have reasonable defaults. Probably a warning would not be to bad
2619 END IF
2620 END IF
2621 DEALLOCATE (rank_permutation)
2622 color = group_distribution(mepos)
2623 CALL mpi_comm_split(comm%handle, color, 0, sub_comm%handle, ierr)
2624 IF (ierr /= mpi_success) CALL mp_stop(ierr, "in "//routinep//" split")
2625
2626 CALL add_perf(perf_id=10, count=1)
2627#else
2628 sub_comm%handle = mp_comm_default_handle
2629 group_distribution(0) = 0
2630 ngroups = 1
2631 mark_used(comm)
2632 mark_used(stride)
2633 mark_used(group_partition)
2634#endif
2635 debug_comm_count = debug_comm_count + 1
2636 CALL sub_comm%init()
2637 CALL mp_timestop(handle)
2638
2639 END SUBROUTINE mp_comm_split
2640
2641! **************************************************************************************************
2642!> \brief probes for an incoming message with any tag
2643!> \param[inout] source the source of the possible incoming message,
2644!> if MP_ANY_SOURCE it is a blocking one and return value is the source
2645!> of the next incoming message
2646!> if source is a different value it is a non-blocking probe returning
2647!> MP_ANY_SOURCE if there is no incoming message
2648!> \param[in] comm the communicator
2649!> \param[out] tag the tag of the incoming message
2650!> \author Mandes
2651! **************************************************************************************************
2652 SUBROUTINE mp_probe(source, comm, tag)
2653 INTEGER, INTENT(INOUT) :: source
2654 CLASS(mp_comm_type), INTENT(IN) :: comm
2655 INTEGER, INTENT(OUT) :: tag
2656
2657 CHARACTER(len=*), PARAMETER :: routineN = 'mp_probe'
2658
2659 INTEGER :: handle
2660#if defined(__parallel)
2661 INTEGER :: ierr
2662 mpi_status_type :: status_single
2663 LOGICAL :: flag
2664#endif
2665
2666! ---------------------------------------------------------------------------
2667
2668 CALL mp_timeset(routinen, handle)
2669
2670#if defined(__parallel)
2671 IF (source == mp_any_source) THEN
2672 CALL mpi_probe(mp_any_source, mp_any_tag, comm%handle, status_single, ierr)
2673 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_probe @ mp_probe")
2674 source = status_single mpi_status_extract(mpi_source)
2675 tag = status_single mpi_status_extract(mpi_tag)
2676 ELSE
2677 flag = .false.
2678 CALL mpi_iprobe(source, mp_any_tag, comm%handle, flag, status_single, ierr)
2679 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iprobe @ mp_probe")
2680 IF (flag .EQV. .false.) THEN
2681 source = mp_any_source
2682 tag = -1 !status_single(MPI_TAG) ! in case of flag==false status is undefined
2683 ELSE
2684 tag = status_single mpi_status_extract(mpi_tag)
2685 END IF
2686 END IF
2687#else
2688 tag = -1
2689 mark_used(comm)
2690 mark_used(source)
2691#endif
2692 CALL mp_timestop(handle)
2693 END SUBROUTINE mp_probe
2694
2695! **************************************************************************************************
2696! Here come the data routines with none of the standard data types.
2697! **************************************************************************************************
2698
2699! **************************************************************************************************
2700!> \brief ...
2701!> \param msg ...
2702!> \param source ...
2703!> \param comm ...
2704! **************************************************************************************************
2705 SUBROUTINE mp_bcast_b(msg, source, comm)
2706 LOGICAL, INTENT(INOUT) :: msg
2707 INTEGER, INTENT(IN) :: source
2708 CLASS(mp_comm_type), INTENT(IN) :: comm
2709
2710 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b'
2711
2712 INTEGER :: handle
2713#if defined(__parallel)
2714 INTEGER :: ierr, msglen
2715#endif
2716
2717 CALL mp_timeset(routinen, handle)
2718
2719#if defined(__parallel)
2720 msglen = 1
2721 CALL mpi_bcast(msg, msglen, mpi_logical, source, comm%handle, ierr)
2722 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2723 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2724#else
2725 mark_used(msg)
2726 mark_used(source)
2727 mark_used(comm)
2728#endif
2729 CALL mp_timestop(handle)
2730 END SUBROUTINE mp_bcast_b
2731
2732! **************************************************************************************************
2733!> \brief ...
2734!> \param msg ...
2735!> \param source ...
2736!> \param comm ...
2737! **************************************************************************************************
2738 SUBROUTINE mp_bcast_b_src(msg, comm)
2739 LOGICAL, INTENT(INOUT) :: msg
2740 CLASS(mp_comm_type), INTENT(IN) :: comm
2741
2742 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b_src'
2743
2744 INTEGER :: handle
2745#if defined(__parallel)
2746 INTEGER :: ierr, msglen
2747#endif
2748
2749 CALL mp_timeset(routinen, handle)
2750
2751#if defined(__parallel)
2752 msglen = 1
2753 CALL mpi_bcast(msg, msglen, mpi_logical, comm%source, comm%handle, ierr)
2754 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2755 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2756#else
2757 mark_used(msg)
2758 mark_used(comm)
2759#endif
2760 CALL mp_timestop(handle)
2761 END SUBROUTINE mp_bcast_b_src
2762
2763! **************************************************************************************************
2764!> \brief ...
2765!> \param msg ...
2766!> \param source ...
2767!> \param comm ...
2768! **************************************************************************************************
2769 SUBROUTINE mp_bcast_bv(msg, source, comm)
2770 LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2771 INTEGER, INTENT(IN) :: source
2772 CLASS(mp_comm_type), INTENT(IN) :: comm
2773
2774 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv'
2775
2776 INTEGER :: handle
2777#if defined(__parallel)
2778 INTEGER :: ierr, msglen
2779#endif
2780
2781 CALL mp_timeset(routinen, handle)
2782
2783#if defined(__parallel)
2784 msglen = SIZE(msg)
2785 CALL mpi_bcast(msg, msglen, mpi_logical, source, comm%handle, ierr)
2786 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2787 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2788#else
2789 mark_used(msg)
2790 mark_used(source)
2791 mark_used(comm)
2792#endif
2793 CALL mp_timestop(handle)
2794 END SUBROUTINE mp_bcast_bv
2795
2796! **************************************************************************************************
2797!> \brief ...
2798!> \param msg ...
2799!> \param comm ...
2800! **************************************************************************************************
2801 SUBROUTINE mp_bcast_bv_src(msg, comm)
2802 LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2803 CLASS(mp_comm_type), INTENT(IN) :: comm
2804
2805 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv_src'
2806
2807 INTEGER :: handle
2808#if defined(__parallel)
2809 INTEGER :: ierr, msglen
2810#endif
2811
2812 CALL mp_timeset(routinen, handle)
2813
2814#if defined(__parallel)
2815 msglen = SIZE(msg)
2816 CALL mpi_bcast(msg, msglen, mpi_logical, comm%source, comm%handle, ierr)
2817 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2818 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2819#else
2820 mark_used(msg)
2821 mark_used(comm)
2822#endif
2823 CALL mp_timestop(handle)
2824 END SUBROUTINE mp_bcast_bv_src
2825
2826! **************************************************************************************************
2827!> \brief Non-blocking send of logical vector data
2828!> \param msgin the input message
2829!> \param dest the destination processor
2830!> \param comm the communicator object
2831!> \param request communication request index
2832!> \param tag message tag
2833!> \par History
2834!> 3.2016 added _bv subroutine [Nico Holmberg]
2835!> \author fawzi
2836!> \note see mp_irecv_iv
2837!> \note
2838!> arrays can be pointers or assumed shape, but they must be contiguous!
2839! **************************************************************************************************
2840 SUBROUTINE mp_isend_bv(msgin, dest, comm, request, tag)
2841 LOGICAL, DIMENSION(:), INTENT(IN) :: msgin
2842 INTEGER, INTENT(IN) :: dest
2843 CLASS(mp_comm_type), INTENT(IN) :: comm
2844 TYPE(mp_request_type), INTENT(out) :: request
2845 INTEGER, INTENT(in), OPTIONAL :: tag
2846
2847 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bv'
2848
2849 INTEGER :: handle
2850#if defined(__parallel)
2851 INTEGER :: ierr, msglen, my_tag
2852 LOGICAL :: foo(1)
2853#endif
2854
2855 CALL mp_timeset(routinen, handle)
2856
2857#if defined(__parallel)
2858#if !defined(__GNUC__) || __GNUC__ >= 9
2859 cpassert(is_contiguous(msgin))
2860#endif
2861
2862 my_tag = 0
2863 IF (PRESENT(tag)) my_tag = tag
2864
2865 msglen = SIZE(msgin, 1)
2866 IF (msglen > 0) THEN
2867 CALL mpi_isend(msgin(1), msglen, mpi_logical, dest, my_tag, &
2868 comm%handle, request%handle, ierr)
2869 ELSE
2870 CALL mpi_isend(foo, msglen, mpi_logical, dest, my_tag, &
2871 comm%handle, request%handle, ierr)
2872 END IF
2873 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
2874
2875 CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2876#else
2877 cpabort("mp_isend called in non parallel case")
2878 mark_used(msgin)
2879 mark_used(dest)
2880 mark_used(comm)
2881 mark_used(tag)
2882 request = mp_request_null
2883#endif
2884 CALL mp_timestop(handle)
2885 END SUBROUTINE mp_isend_bv
2886
2887! **************************************************************************************************
2888!> \brief Non-blocking receive of logical vector data
2889!> \param msgout the received message
2890!> \param source the source processor
2891!> \param comm the communicator object
2892!> \param request communication request index
2893!> \param tag message tag
2894!> \par History
2895!> 3.2016 added _bv subroutine [Nico Holmberg]
2896!> \author fawzi
2897!> \note see mp_irecv_iv
2898!> \note
2899!> arrays can be pointers or assumed shape, but they must be contiguous!
2900! **************************************************************************************************
2901 SUBROUTINE mp_irecv_bv(msgout, source, comm, request, tag)
2902 LOGICAL, DIMENSION(:), INTENT(INOUT) :: msgout
2903 INTEGER, INTENT(IN) :: source
2904 CLASS(mp_comm_type), INTENT(IN) :: comm
2905 TYPE(mp_request_type), INTENT(out) :: request
2906 INTEGER, INTENT(in), OPTIONAL :: tag
2907
2908 CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bv'
2909
2910 INTEGER :: handle
2911#if defined(__parallel)
2912 INTEGER :: ierr, msglen, my_tag
2913 LOGICAL :: foo(1)
2914#endif
2915
2916 CALL mp_timeset(routinen, handle)
2917
2918#if defined(__parallel)
2919#if !defined(__GNUC__) || __GNUC__ >= 9
2920 cpassert(is_contiguous(msgout))
2921#endif
2922
2923 my_tag = 0
2924 IF (PRESENT(tag)) my_tag = tag
2925
2926 msglen = SIZE(msgout, 1)
2927 IF (msglen > 0) THEN
2928 CALL mpi_irecv(msgout(1), msglen, mpi_logical, source, my_tag, &
2929 comm%handle, request%handle, ierr)
2930 ELSE
2931 CALL mpi_irecv(foo, msglen, mpi_logical, source, my_tag, &
2932 comm%handle, request%handle, ierr)
2933 END IF
2934 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
2935
2936 CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
2937#else
2938 cpabort("mp_irecv called in non parallel case")
2939 mark_used(msgout)
2940 mark_used(source)
2941 mark_used(comm)
2942 mark_used(tag)
2943 request = mp_request_null
2944#endif
2945 CALL mp_timestop(handle)
2946 END SUBROUTINE mp_irecv_bv
2947
2948! **************************************************************************************************
2949!> \brief Non-blocking send of rank-3 logical data
2950!> \param msgin the input message
2951!> \param dest the destination processor
2952!> \param comm the communicator object
2953!> \param request communication request index
2954!> \param tag message tag
2955!> \par History
2956!> 2.2016 added _bm3 subroutine [Nico Holmberg]
2957!> \author fawzi
2958!> \note see mp_irecv_iv
2959!> \note
2960!> arrays can be pointers or assumed shape, but they must be contiguous!
2961! **************************************************************************************************
2962 SUBROUTINE mp_isend_bm3(msgin, dest, comm, request, tag)
2963 LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgin
2964 INTEGER, INTENT(IN) :: dest
2965 CLASS(mp_comm_type), INTENT(IN) :: comm
2966 TYPE(mp_request_type), INTENT(out) :: request
2967 INTEGER, INTENT(in), OPTIONAL :: tag
2968
2969 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bm3'
2970
2971 INTEGER :: handle
2972#if defined(__parallel)
2973 INTEGER :: ierr, msglen, my_tag
2974 LOGICAL :: foo(1)
2975#endif
2976
2977 CALL mp_timeset(routinen, handle)
2978
2979#if defined(__parallel)
2980#if !defined(__GNUC__) || __GNUC__ >= 9
2981 cpassert(is_contiguous(msgin))
2982#endif
2983
2984 my_tag = 0
2985 IF (PRESENT(tag)) my_tag = tag
2986
2987 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
2988 IF (msglen > 0) THEN
2989 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_logical, dest, my_tag, &
2990 comm%handle, request%handle, ierr)
2991 ELSE
2992 CALL mpi_isend(foo, msglen, mpi_logical, dest, my_tag, &
2993 comm%handle, request%handle, ierr)
2994 END IF
2995 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
2996
2997 CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2998#else
2999 cpabort("mp_isend called in non parallel case")
3000 mark_used(msgin)
3001 mark_used(dest)
3002 mark_used(comm)
3003 mark_used(tag)
3004 request = mp_request_null
3005#endif
3006 CALL mp_timestop(handle)
3007 END SUBROUTINE mp_isend_bm3
3008
3009! **************************************************************************************************
3010!> \brief Non-blocking receive of rank-3 logical data
3011!> \param msgout the received message
3012!> \param source the source processor
3013!> \param comm the communicator object
3014!> \param request communication request index
3015!> \param tag message tag
3016!> \par History
3017!> 2.2016 added _bm3 subroutine [Nico Holmberg]
3018!> \author fawzi
3019!> \note see mp_irecv_iv
3020!> \note
3021!> arrays can be pointers or assumed shape, but they must be contiguous!
3022! **************************************************************************************************
3023 SUBROUTINE mp_irecv_bm3(msgout, source, comm, request, tag)
3024 LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgout
3025 INTEGER, INTENT(IN) :: source
3026 CLASS(mp_comm_type), INTENT(IN) :: comm
3027 TYPE(mp_request_type), INTENT(out) :: request
3028 INTEGER, INTENT(in), OPTIONAL :: tag
3029
3030 CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bm3'
3031
3032 INTEGER :: handle
3033#if defined(__parallel)
3034 INTEGER :: ierr, msglen, my_tag
3035 LOGICAL :: foo(1)
3036#endif
3037
3038 CALL mp_timeset(routinen, handle)
3039
3040#if defined(__parallel)
3041#if !defined(__GNUC__) || __GNUC__ >= 9
3042 cpassert(is_contiguous(msgout))
3043#endif
3044
3045 my_tag = 0
3046 IF (PRESENT(tag)) my_tag = tag
3047
3048 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
3049 IF (msglen > 0) THEN
3050 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_logical, source, my_tag, &
3051 comm%handle, request%handle, ierr)
3052 ELSE
3053 CALL mpi_irecv(foo, msglen, mpi_logical, source, my_tag, &
3054 comm%handle, request%handle, ierr)
3055 END IF
3056 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
3057
3058 CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
3059#else
3060 cpabort("mp_irecv called in non parallel case")
3061 mark_used(msgout)
3062 mark_used(source)
3063 mark_used(comm)
3064 mark_used(request)
3065 mark_used(tag)
3066 request = mp_request_null
3067#endif
3068 CALL mp_timestop(handle)
3069 END SUBROUTINE mp_irecv_bm3
3070
3071! **************************************************************************************************
3072!> \brief Broadcasts a string.
3073!> \param msg ...
3074!> \param source ...
3075!> \param comm ...
3076! **************************************************************************************************
3077 SUBROUTINE mp_bcast_av(msg, source, comm)
3078 CHARACTER(LEN=*), INTENT(INOUT) :: msg
3079 INTEGER, INTENT(IN) :: source
3080 CLASS(mp_comm_type), INTENT(IN) :: comm
3081
3082 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av'
3083
3084 INTEGER :: handle
3085#if defined(__parallel)
3086 INTEGER :: ierr, msglen
3087#endif
3088
3089 CALL mp_timeset(routinen, handle)
3090
3091#if defined(__parallel)
3092 msglen = len(msg)*charlen
3093 IF (comm%mepos /= source) msg = "" ! need to clear msg
3094 CALL mpi_bcast(msg, msglen, mpi_character, source, comm%handle, ierr)
3095 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3096 CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3097#else
3098 mark_used(msg)
3099 mark_used(source)
3100 mark_used(comm)
3101#endif
3102 CALL mp_timestop(handle)
3103 END SUBROUTINE mp_bcast_av
3104
3105! **************************************************************************************************
3106!> \brief Broadcasts a string.
3107!> \param msg ...
3108!> \param comm ...
3109! **************************************************************************************************
3110 SUBROUTINE mp_bcast_av_src(msg, comm)
3111 CHARACTER(LEN=*), INTENT(INOUT) :: msg
3112 CLASS(mp_comm_type), INTENT(IN) :: comm
3113
3114 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av_src'
3115
3116 INTEGER :: handle
3117#if defined(__parallel)
3118 INTEGER :: ierr, msglen
3119#endif
3120
3121 CALL mp_timeset(routinen, handle)
3122
3123#if defined(__parallel)
3124 msglen = len(msg)*charlen
3125 IF (.NOT. comm%is_source()) msg = "" ! need to clear msg
3126 CALL mpi_bcast(msg, msglen, mpi_character, comm%source, comm%handle, ierr)
3127 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3128 CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3129#else
3130 mark_used(msg)
3131 mark_used(comm)
3132#endif
3133 CALL mp_timestop(handle)
3134 END SUBROUTINE mp_bcast_av_src
3135
3136! **************************************************************************************************
3137!> \brief ...
3138!> \param msg ...
3139!> \param source ...
3140!> \param comm ...
3141! **************************************************************************************************
3142 SUBROUTINE mp_bcast_am(msg, source, comm)
3143 CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3144 INTEGER, INTENT(IN) :: source
3145 CLASS(mp_comm_type), INTENT(IN) :: comm
3146
3147 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am'
3148
3149 INTEGER :: handle
3150#if defined(__parallel)
3151 INTEGER :: ierr, msglen
3152#endif
3153
3154 CALL mp_timeset(routinen, handle)
3155
3156#if defined(__parallel)
3157 msglen = SIZE(msg)*len(msg(1))*charlen
3158 IF (comm%mepos /= source) msg = "" ! need to clear msg
3159 CALL mpi_bcast(msg, msglen, mpi_character, source, comm%handle, ierr)
3160 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3161 CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3162#else
3163 mark_used(msg)
3164 mark_used(source)
3165 mark_used(comm)
3166#endif
3167 CALL mp_timestop(handle)
3168 END SUBROUTINE mp_bcast_am
3169
3170 SUBROUTINE mp_bcast_am_src(msg, comm)
3171 CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3172 CLASS(mp_comm_type), INTENT(IN) :: comm
3173
3174 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am_src'
3175
3176 INTEGER :: handle
3177#if defined(__parallel)
3178 INTEGER :: ierr, msglen
3179#endif
3180
3181 CALL mp_timeset(routinen, handle)
3182
3183#if defined(__parallel)
3184 msglen = SIZE(msg)*len(msg(1))*charlen
3185 IF (.NOT. comm%is_source()) msg = "" ! need to clear msg
3186 CALL mpi_bcast(msg, msglen, mpi_character, comm%source, comm%handle, ierr)
3187 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3188 CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3189#else
3190 mark_used(msg)
3191 mark_used(comm)
3192#endif
3193 CALL mp_timestop(handle)
3194 END SUBROUTINE mp_bcast_am_src
3195
3196! **************************************************************************************************
3197!> \brief Finds the location of the minimal element in a vector.
3198!> \param[in,out] msg Find location of minimum element among these
3199!> data (input).
3200!> \param[in] comm Message passing environment identifier
3201!> \par MPI mapping
3202!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3203!> \par Invalid data types
3204!> This routine is invalid for (int_8) data!
3205! **************************************************************************************************
3206 SUBROUTINE mp_minloc_dv(msg, comm)
3207 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3208 CLASS(mp_comm_type), INTENT(IN) :: comm
3209
3210 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_dv'
3211
3212 INTEGER :: handle
3213#if defined(__parallel)
3214 INTEGER :: ierr, msglen
3215 REAL(kind=real_8), ALLOCATABLE :: res(:)
3216#endif
3217
3218 IF ("d" == "l" .AND. real_8 == int_8) THEN
3219 cpabort("Minimal location not available with long integers @ "//routinen)
3220 END IF
3221 CALL mp_timeset(routinen, handle)
3222
3223#if defined(__parallel)
3224 msglen = SIZE(msg)
3225 ALLOCATE (res(1:msglen), stat=ierr)
3226 IF (ierr /= 0) &
3227 cpabort("allocate @ "//routinen)
3228 CALL mpi_allreduce(msg, res, msglen/2, mpi_2double_precision, mpi_minloc, comm%handle, ierr)
3229 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3230 msg = res
3231 DEALLOCATE (res)
3232 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3233#else
3234 mark_used(msg)
3235 mark_used(comm)
3236#endif
3237 CALL mp_timestop(handle)
3238 END SUBROUTINE mp_minloc_dv
3239
3240! **************************************************************************************************
3241!> \brief Finds the location of the minimal element in a vector.
3242!> \param[in,out] msg Find location of minimum element among these
3243!> data (input).
3244!> \param[in] comm Message passing environment identifier
3245!> \par MPI mapping
3246!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3247!> \par Invalid data types
3248!> This routine is invalid for (int_8) data!
3249! **************************************************************************************************
3250 SUBROUTINE mp_minloc_iv(msg, comm)
3251 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3252 CLASS(mp_comm_type), INTENT(IN) :: comm
3253
3254 CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_iv'
3255
3256 INTEGER :: handle
3257#if defined(__parallel)
3258 INTEGER :: ierr, msglen
3259 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3260#endif
3261
3262 IF ("i" == "l" .AND. int_4 == int_8) THEN
3263 cpabort("Minimal location not available with long integers @ "//routinen)
3264 END IF
3265 CALL mp_timeset(routinen, handle)
3266
3267#if defined(__parallel)
3268 msglen = SIZE(msg)
3269 ALLOCATE (res(1:msglen))
3270 CALL mpi_allreduce(msg, res, msglen/2, mpi_2integer, mpi_minloc, comm%handle, ierr)
3271 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3272 msg = res
3273 DEALLOCATE (res)
3274 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3275#else
3276 mark_used(msg)
3277 mark_used(comm)
3278#endif
3279 CALL mp_timestop(handle)
3280 END SUBROUTINE mp_minloc_iv
3281
3282! **************************************************************************************************
3283!> \brief Finds the location of the minimal element in a vector.
3284!> \param[in,out] msg Find location of minimum element among these
3285!> data (input).
3286!> \param[in] comm Message passing environment identifier
3287!> \par MPI mapping
3288!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3289!> \par Invalid data types
3290!> This routine is invalid for (int_8) data!
3291! **************************************************************************************************
3292 SUBROUTINE mp_minloc_lv(msg, comm)
3293 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3294 CLASS(mp_comm_type), INTENT(IN) :: comm
3295
3296 CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_lv'
3297
3298 INTEGER :: handle
3299#if defined(__parallel)
3300 INTEGER :: ierr, msglen
3301 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3302#endif
3303
3304 IF ("l" == "l" .AND. int_8 == int_8) THEN
3305 cpabort("Minimal location not available with long integers @ "//routinen)
3306 END IF
3307 CALL mp_timeset(routinen, handle)
3308
3309#if defined(__parallel)
3310 msglen = SIZE(msg)
3311 ALLOCATE (res(1:msglen))
3312 CALL mpi_allreduce(msg, res, msglen/2, mpi_integer8, mpi_minloc, comm%handle, ierr)
3313 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3314 msg = res
3315 DEALLOCATE (res)
3316 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3317#else
3318 mark_used(msg)
3319 mark_used(comm)
3320#endif
3321 CALL mp_timestop(handle)
3322 END SUBROUTINE mp_minloc_lv
3323
3324! **************************************************************************************************
3325!> \brief Finds the location of the minimal element in a vector.
3326!> \param[in,out] msg Find location of minimum element among these
3327!> data (input).
3328!> \param[in] comm Message passing environment identifier
3329!> \par MPI mapping
3330!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3331!> \par Invalid data types
3332!> This routine is invalid for (int_8) data!
3333! **************************************************************************************************
3334 SUBROUTINE mp_minloc_rv(msg, comm)
3335 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3336 CLASS(mp_comm_type), INTENT(IN) :: comm
3337
3338 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_rv'
3339
3340 INTEGER :: handle
3341#if defined(__parallel)
3342 INTEGER :: ierr, msglen
3343 REAL(kind=real_4), ALLOCATABLE :: res(:)
3344#endif
3345
3346 IF ("r" == "l" .AND. real_4 == int_8) THEN
3347 cpabort("Minimal location not available with long integers @ "//routinen)
3348 END IF
3349 CALL mp_timeset(routinen, handle)
3350
3351#if defined(__parallel)
3352 msglen = SIZE(msg)
3353 ALLOCATE (res(1:msglen))
3354 CALL mpi_allreduce(msg, res, msglen/2, mpi_2real, mpi_minloc, comm%handle, ierr)
3355 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3356 msg = res
3357 DEALLOCATE (res)
3358 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3359#else
3360 mark_used(msg)
3361 mark_used(comm)
3362#endif
3363 CALL mp_timestop(handle)
3364 END SUBROUTINE mp_minloc_rv
3365
3366! **************************************************************************************************
3367!> \brief Finds the location of the maximal element in a vector.
3368!> \param[in,out] msg Find location of maximum element among these
3369!> data (input).
3370!> \param[in] comm Message passing environment identifier
3371!> \par MPI mapping
3372!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3373!> \par Invalid data types
3374!> This routine is invalid for (int_8) data!
3375! **************************************************************************************************
3376 SUBROUTINE mp_maxloc_dv(msg, comm)
3377 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3378 CLASS(mp_comm_type), INTENT(IN) :: comm
3379
3380 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_dv'
3381
3382 INTEGER :: handle
3383#if defined(__parallel)
3384 INTEGER :: ierr, msglen
3385 REAL(kind=real_8), ALLOCATABLE :: res(:)
3386#endif
3387
3388 IF ("d" == "l" .AND. real_8 == int_8) THEN
3389 cpabort("Maximal location not available with long integers @ "//routinen)
3390 END IF
3391 CALL mp_timeset(routinen, handle)
3392
3393#if defined(__parallel)
3394 msglen = SIZE(msg)
3395 ALLOCATE (res(1:msglen))
3396 CALL mpi_allreduce(msg, res, msglen/2, mpi_2double_precision, mpi_maxloc, comm%handle, ierr)
3397 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3398 msg = res
3399 DEALLOCATE (res)
3400 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3401#else
3402 mark_used(msg)
3403 mark_used(comm)
3404#endif
3405 CALL mp_timestop(handle)
3406 END SUBROUTINE mp_maxloc_dv
3407
3408! **************************************************************************************************
3409!> \brief Finds the location of the maximal element in a vector.
3410!> \param[in,out] msg Find location of maximum element among these
3411!> data (input).
3412!> \param[in] comm Message passing environment identifier
3413!> \par MPI mapping
3414!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3415!> \par Invalid data types
3416!> This routine is invalid for (int_8) data!
3417! **************************************************************************************************
3418 SUBROUTINE mp_maxloc_iv(msg, comm)
3419 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3420 CLASS(mp_comm_type), INTENT(IN) :: comm
3421
3422 CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_iv'
3423
3424 INTEGER :: handle
3425#if defined(__parallel)
3426 INTEGER :: ierr, msglen
3427 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3428#endif
3429
3430 IF ("i" == "l" .AND. int_4 == int_8) THEN
3431 cpabort("Maximal location not available with long integers @ "//routinen)
3432 END IF
3433 CALL mp_timeset(routinen, handle)
3434
3435#if defined(__parallel)
3436 msglen = SIZE(msg)
3437 ALLOCATE (res(1:msglen))
3438 CALL mpi_allreduce(msg, res, msglen/2, mpi_2integer, mpi_maxloc, comm%handle, ierr)
3439 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3440 msg = res
3441 DEALLOCATE (res)
3442 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3443#else
3444 mark_used(msg)
3445 mark_used(comm)
3446#endif
3447 CALL mp_timestop(handle)
3448 END SUBROUTINE mp_maxloc_iv
3449
3450! **************************************************************************************************
3451!> \brief Finds the location of the maximal element in a vector.
3452!> \param[in,out] msg Find location of maximum element among these
3453!> data (input).
3454!> \param[in] comm Message passing environment identifier
3455!> \par MPI mapping
3456!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3457!> \par Invalid data types
3458!> This routine is invalid for (int_8) data!
3459! **************************************************************************************************
3460 SUBROUTINE mp_maxloc_lv(msg, comm)
3461 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3462 CLASS(mp_comm_type), INTENT(IN) :: comm
3463
3464 CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_lv'
3465
3466 INTEGER :: handle
3467#if defined(__parallel)
3468 INTEGER :: ierr, msglen
3469 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3470#endif
3471
3472 IF ("l" == "l" .AND. int_8 == int_8) THEN
3473 cpabort("Maximal location not available with long integers @ "//routinen)
3474 END IF
3475 CALL mp_timeset(routinen, handle)
3476
3477#if defined(__parallel)
3478 msglen = SIZE(msg)
3479 ALLOCATE (res(1:msglen))
3480 CALL mpi_allreduce(msg, res, msglen/2, mpi_integer8, mpi_maxloc, comm%handle, ierr)
3481 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3482 msg = res
3483 DEALLOCATE (res)
3484 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3485#else
3486 mark_used(msg)
3487 mark_used(comm)
3488#endif
3489 CALL mp_timestop(handle)
3490 END SUBROUTINE mp_maxloc_lv
3491
3492! **************************************************************************************************
3493!> \brief Finds the location of the maximal element in a vector.
3494!> \param[in,out] msg Find location of maximum element among these
3495!> data (input).
3496!> \param[in] comm Message passing environment identifier
3497!> \par MPI mapping
3498!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3499!> \par Invalid data types
3500!> This routine is invalid for (int_8) data!
3501! **************************************************************************************************
3502 SUBROUTINE mp_maxloc_rv(msg, comm)
3503 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3504 CLASS(mp_comm_type), INTENT(IN) :: comm
3505
3506 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_rv'
3507
3508 INTEGER :: handle
3509#if defined(__parallel)
3510 INTEGER :: ierr, msglen
3511 REAL(kind=real_4), ALLOCATABLE :: res(:)
3512#endif
3513
3514 IF ("r" == "l" .AND. real_4 == int_8) THEN
3515 cpabort("Maximal location not available with long integers @ "//routinen)
3516 END IF
3517 CALL mp_timeset(routinen, handle)
3518
3519#if defined(__parallel)
3520 msglen = SIZE(msg)
3521 ALLOCATE (res(1:msglen))
3522 CALL mpi_allreduce(msg, res, msglen/2, mpi_2real, mpi_maxloc, comm%handle, ierr)
3523 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3524 msg = res
3525 DEALLOCATE (res)
3526 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3527#else
3528 mark_used(msg)
3529 mark_used(comm)
3530#endif
3531 CALL mp_timestop(handle)
3532 END SUBROUTINE mp_maxloc_rv
3533
3534! **************************************************************************************************
3535!> \brief Logical OR reduction
3536!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3537!> and resultant inclusive disjunction (output)
3538!> \param[in] comm Message passing environment identifier
3539!> \par MPI mapping
3540!> mpi_allreduce
3541! **************************************************************************************************
3542 SUBROUTINE mp_sum_b(msg, comm)
3543 LOGICAL, INTENT(INOUT) :: msg
3544 CLASS(mp_comm_type), INTENT(IN) :: comm
3545
3546 CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_b'
3547
3548 INTEGER :: handle
3549#if defined(__parallel)
3550 INTEGER :: ierr, msglen
3551#endif
3552
3553 CALL mp_timeset(routinen, handle)
3554#if defined(__parallel)
3555 msglen = 1
3556 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, ierr)
3557 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3558#else
3559 mark_used(msg)
3560 mark_used(comm)
3561#endif
3562 CALL mp_timestop(handle)
3563 END SUBROUTINE mp_sum_b
3564
3565! **************************************************************************************************
3566!> \brief Logical OR reduction
3567!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3568!> and resultant inclusive disjunction (output)
3569!> \param[in] comm Message passing environment identifier
3570!> \par MPI mapping
3571!> mpi_allreduce
3572! **************************************************************************************************
3573 SUBROUTINE mp_sum_bv(msg, comm)
3574 LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: msg
3575 CLASS(mp_comm_type), INTENT(IN) :: comm
3576
3577 CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_bv'
3578
3579 INTEGER :: handle
3580#if defined(__parallel)
3581 INTEGER :: ierr, msglen
3582#endif
3583
3584 CALL mp_timeset(routinen, handle)
3585#if defined(__parallel)
3586 msglen = SIZE(msg)
3587 IF (msglen > 0) THEN
3588 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, ierr)
3589 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3590 END IF
3591#else
3592 mark_used(msg)
3593 mark_used(comm)
3594#endif
3595 CALL mp_timestop(handle)
3596 END SUBROUTINE mp_sum_bv
3597
3598! **************************************************************************************************
3599!> \brief Logical OR reduction
3600!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3601!> and resultant inclusive disjunction (output)
3602!> \param[in] comm Message passing environment identifier
3603!> \param request ...
3604!> \par MPI mapping
3605!> mpi_allreduce
3606! **************************************************************************************************
3607 SUBROUTINE mp_isum_bv(msg, comm, request)
3608 LOGICAL, DIMENSION(:), INTENT(INOUT) :: msg
3609 CLASS(mp_comm_type), INTENT(IN) :: comm
3610 TYPE(mp_request_type), INTENT(INOUT) :: request
3611
3612 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isum_bv'
3613
3614 INTEGER :: handle
3615#if defined(__parallel)
3616 INTEGER :: ierr, msglen
3617#endif
3618
3619 CALL mp_timeset(routinen, handle)
3620#if defined(__parallel)
3621 msglen = SIZE(msg)
3622#if !defined(__GNUC__) || __GNUC__ >= 9
3623 cpassert(is_contiguous(msg))
3624#endif
3625
3626 IF (msglen > 0) THEN
3627 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, request%handle, ierr)
3628 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3629 ELSE
3630 request = mp_request_null
3631 END IF
3632#else
3633 mark_used(msg)
3634 mark_used(comm)
3635 request = mp_request_null
3636#endif
3637 CALL mp_timestop(handle)
3638 END SUBROUTINE mp_isum_bv
3639
3640! **************************************************************************************************
3641!> \brief Get Version of the MPI Library (MPI 3)
3642!> \param[out] version Version of the library,
3643!> declared as CHARACTER(LEN=mp_max_library_version_string)
3644!> \param[out] resultlen Length (in printable characters) of
3645!> the result returned in version (integer)
3646! **************************************************************************************************
3647 SUBROUTINE mp_get_library_version(version, resultlen)
3648 CHARACTER(len=*), INTENT(OUT) :: version
3649 INTEGER, INTENT(OUT) :: resultlen
3650
3651#if defined(__parallel)
3652 INTEGER :: ierr
3653#endif
3654
3655 version = ''
3656
3657#if defined(__parallel)
3658 ierr = 0
3659 CALL mpi_get_library_version(version, resultlen, ierr)
3660 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_get_library_version @ mp_get_library_version")
3661#else
3662 resultlen = 0
3663#endif
3664 END SUBROUTINE mp_get_library_version
3665
3666! **************************************************************************************************
3667!> \brief Opens a file
3668!> \param[in] groupid message passing environment identifier
3669!> \param[out] fh file handle (file storage unit)
3670!> \param[in] filepath path to the file
3671!> \param amode_status access mode
3672!> \param info ...
3673!> \par MPI-I/O mapping mpi_file_open
3674!> \par STREAM-I/O mapping OPEN
3675!>
3676!> \param[in](optional) info info object
3677!> \par History
3678!> 11.2012 created [Hossein Bani-Hashemian]
3679! **************************************************************************************************
3680 SUBROUTINE mp_file_open(groupid, fh, filepath, amode_status, info)
3681 CLASS(mp_comm_type), INTENT(IN) :: groupid
3682 CLASS(mp_file_type), INTENT(OUT) :: fh
3683 CHARACTER(len=*), INTENT(IN) :: filepath
3684 INTEGER, INTENT(IN) :: amode_status
3685 TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3686
3687#if defined(__parallel)
3688 INTEGER :: ierr
3689 mpi_info_type :: my_info
3690#else
3691 CHARACTER(LEN=10) :: fstatus, fposition
3692 INTEGER :: amode, handle, istat
3693 LOGICAL :: exists, is_open
3694#endif
3695
3696#if defined(__parallel)
3697 ierr = 0
3698 my_info = mpi_info_null
3699 IF (PRESENT(info)) my_info = info%handle
3700 CALL mpi_file_open(groupid%handle, filepath, amode_status, my_info, fh%handle, ierr)
3701 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3702 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open")
3703#else
3704 mark_used(groupid)
3705 mark_used(info)
3706 amode = amode_status
3707 IF (amode > file_amode_append) THEN
3708 fposition = "APPEND"
3709 amode = amode - file_amode_append
3710 ELSE
3711 fposition = "REWIND"
3712 END IF
3713 IF ((amode == file_amode_create) .OR. &
3714 (amode == file_amode_create + file_amode_wronly) .OR. &
3715 (amode == file_amode_create + file_amode_wronly + file_amode_excl)) THEN
3716 fstatus = "UNKNOWN"
3717 ELSE
3718 fstatus = "OLD"
3719 END IF
3720 ! Get a new unit number
3721 DO handle = 1, 999
3722 INQUIRE (unit=handle, exist=exists, opened=is_open, iostat=istat)
3723 IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) EXIT
3724 END DO
3725 OPEN (unit=handle, file=filepath, status=fstatus, access="STREAM", position=fposition)
3726 fh%handle = handle
3727#endif
3728 END SUBROUTINE mp_file_open
3729
3730! **************************************************************************************************
3731!> \brief Deletes a file. Auxiliary routine to emulate 'replace' action for mp_file_open.
3732!> Only the master processor should call this routine.
3733!> \param[in] filepath path to the file
3734!> \param[in](optional) info info object
3735!> \par History
3736!> 11.2017 created [Nico Holmberg]
3737! **************************************************************************************************
3738 SUBROUTINE mp_file_delete(filepath, info)
3739 CHARACTER(len=*), INTENT(IN) :: filepath
3740 TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3741
3742#if defined(__parallel)
3743 INTEGER :: ierr
3744 mpi_info_type :: my_info
3745 LOGICAL :: exists
3746
3747 ierr = 0
3748 my_info = mpi_info_null
3749 IF (PRESENT(info)) my_info = info%handle
3750 INQUIRE (file=filepath, exist=exists)
3751 IF (exists) CALL mpi_file_delete(filepath, my_info, ierr)
3752 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete")
3753#else
3754 mark_used(filepath)
3755 mark_used(info)
3756 ! Explicit file delete not necessary, handled by subsequent call to open_file with action 'replace'
3757#endif
3758
3759 END SUBROUTINE mp_file_delete
3760
3761! **************************************************************************************************
3762!> \brief Closes a file
3763!> \param[in] fh file handle (file storage unit)
3764!> \par MPI-I/O mapping mpi_file_close
3765!> \par STREAM-I/O mapping CLOSE
3766!>
3767!> \par History
3768!> 11.2012 created [Hossein Bani-Hashemian]
3769! **************************************************************************************************
3770 SUBROUTINE mp_file_close(fh)
3771 CLASS(mp_file_type), INTENT(INOUT) :: fh
3772
3773#if defined(__parallel)
3774 INTEGER :: ierr
3775
3776 ierr = 0
3777 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3778 CALL mpi_file_close(fh%handle, ierr)
3779 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close")
3780#else
3781 CLOSE (fh%handle)
3782 fh%handle = mp_file_null_handle
3783#endif
3784 END SUBROUTINE mp_file_close
3785
3786 SUBROUTINE mp_file_assign(fh_new, fh_old)
3787 CLASS(mp_file_type), INTENT(OUT) :: fh_new
3788 CLASS(mp_file_type), INTENT(IN) :: fh_old
3789
3790 fh_new%handle = fh_old%handle
3791
3792 END SUBROUTINE
3793
3794! **************************************************************************************************
3795!> \brief Returns the file size
3796!> \param[in] fh file handle (file storage unit)
3797!> \param[out] file_size the file size
3798!> \par MPI-I/O mapping mpi_file_get_size
3799!> \par STREAM-I/O mapping INQUIRE
3800!>
3801!> \par History
3802!> 12.2012 created [Hossein Bani-Hashemian]
3803! **************************************************************************************************
3804 SUBROUTINE mp_file_get_size(fh, file_size)
3805 CLASS(mp_file_type), INTENT(IN) :: fh
3806 INTEGER(kind=file_offset), INTENT(OUT) :: file_size
3807
3808#if defined(__parallel)
3809 INTEGER :: ierr
3810#endif
3811
3812#if defined(__parallel)
3813 ierr = 0
3814 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3815 CALL mpi_file_get_size(fh%handle, file_size, ierr)
3816 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size")
3817#else
3818 INQUIRE (unit=fh%handle, size=file_size)
3819#endif
3820 END SUBROUTINE mp_file_get_size
3821
3822! **************************************************************************************************
3823!> \brief Returns the file position
3824!> \param[in] fh file handle (file storage unit)
3825!> \param[out] file_size the file position
3826!> \par MPI-I/O mapping mpi_file_get_position
3827!> \par STREAM-I/O mapping INQUIRE
3828!>
3829!> \par History
3830!> 11.2017 created [Nico Holmberg]
3831! **************************************************************************************************
3832 SUBROUTINE mp_file_get_position(fh, pos)
3833 CLASS(mp_file_type), INTENT(IN) :: fh
3834 INTEGER(kind=file_offset), INTENT(OUT) :: pos
3835
3836#if defined(__parallel)
3837 INTEGER :: ierr
3838#endif
3839
3840#if defined(__parallel)
3841 ierr = 0
3842 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3843 CALL mpi_file_get_position(fh%handle, pos, ierr)
3844 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position")
3845#else
3846 INQUIRE (unit=fh%handle, pos=pos)
3847#endif
3848 END SUBROUTINE mp_file_get_position
3849
3850! **************************************************************************************************
3851!> \brief (parallel) Blocking individual file write using explicit offsets
3852!> (serial) Unformatted stream write
3853!> \param[in] fh file handle (file storage unit)
3854!> \param[in] offset file offset (position)
3855!> \param[in] msg data to be written to the file
3856!> \param msglen ...
3857!> \par MPI-I/O mapping mpi_file_write_at
3858!> \par STREAM-I/O mapping WRITE
3859!> \param[in](optional) msglen number of the elements of data
3860! **************************************************************************************************
3861 SUBROUTINE mp_file_write_at_chv(fh, offset, msg, msglen)
3862 CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
3863 CLASS(mp_file_type), INTENT(IN) :: fh
3864 INTEGER, INTENT(IN), OPTIONAL :: msglen
3865 INTEGER(kind=file_offset), INTENT(IN) :: offset
3866
3867#if defined(__parallel)
3868 INTEGER :: ierr, msg_len
3869#endif
3870
3871#if defined(__parallel)
3872 msg_len = SIZE(msg)
3873 IF (PRESENT(msglen)) msg_len = msglen
3874 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
3875 IF (ierr /= 0) &
3876 cpabort("mpi_file_write_at_chv @ mp_file_write_at_chv")
3877#else
3878 mark_used(msglen)
3879 WRITE (unit=fh%handle, pos=offset + 1) msg
3880#endif
3881 END SUBROUTINE mp_file_write_at_chv
3882
3883! **************************************************************************************************
3884!> \brief ...
3885!> \param fh ...
3886!> \param offset ...
3887!> \param msg ...
3888! **************************************************************************************************
3889 SUBROUTINE mp_file_write_at_ch(fh, offset, msg)
3890 CHARACTER(LEN=*), INTENT(IN) :: msg
3891 CLASS(mp_file_type), INTENT(IN) :: fh
3892 INTEGER(kind=file_offset), INTENT(IN) :: offset
3893
3894#if defined(__parallel)
3895 INTEGER :: ierr
3896#endif
3897
3898#if defined(__parallel)
3899 CALL mpi_file_write_at(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
3900 IF (ierr /= 0) &
3901 cpabort("mpi_file_write_at_ch @ mp_file_write_at_ch")
3902#else
3903 WRITE (unit=fh%handle, pos=offset + 1) msg
3904#endif
3905 END SUBROUTINE mp_file_write_at_ch
3906
3907! **************************************************************************************************
3908!> \brief (parallel) Blocking collective file write using explicit offsets
3909!> (serial) Unformatted stream write
3910!> \param fh ...
3911!> \param offset ...
3912!> \param msg ...
3913!> \param msglen ...
3914!> \par MPI-I/O mapping mpi_file_write_at_all
3915!> \par STREAM-I/O mapping WRITE
3916! **************************************************************************************************
3917 SUBROUTINE mp_file_write_at_all_chv(fh, offset, msg, msglen)
3918 CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
3919 CLASS(mp_file_type), INTENT(IN) :: fh
3920 INTEGER, INTENT(IN), OPTIONAL :: msglen
3921 INTEGER(kind=file_offset), INTENT(IN) :: offset
3922
3923#if defined(__parallel)
3924 INTEGER :: ierr, msg_len
3925#endif
3926
3927#if defined(__parallel)
3928 msg_len = SIZE(msg)
3929 IF (PRESENT(msglen)) msg_len = msglen
3930 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
3931 IF (ierr /= 0) &
3932 cpabort("mpi_file_write_at_all_chv @ mp_file_write_at_all_chv")
3933#else
3934 mark_used(msglen)
3935 WRITE (unit=fh%handle, pos=offset + 1) msg
3936#endif
3937 END SUBROUTINE mp_file_write_at_all_chv
3938
3939! **************************************************************************************************
3940!> \brief wrapper to MPI_File_write_at_all
3941!> \param fh ...
3942!> \param offset ...
3943!> \param msg ...
3944! **************************************************************************************************
3945 SUBROUTINE mp_file_write_at_all_ch(fh, offset, msg)
3946 CHARACTER(LEN=*), INTENT(IN) :: msg
3947 CLASS(mp_file_type), INTENT(IN) :: fh
3948 INTEGER(kind=file_offset), INTENT(IN) :: offset
3949
3950#if defined(__parallel)
3951 INTEGER :: ierr
3952#endif
3953
3954#if defined(__parallel)
3955 CALL mpi_file_write_at_all(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
3956 IF (ierr /= 0) &
3957 cpabort("mpi_file_write_at_all_ch @ mp_file_write_at_all_ch")
3958#else
3959 WRITE (unit=fh%handle, pos=offset + 1) msg
3960#endif
3961 END SUBROUTINE mp_file_write_at_all_ch
3962
3963! **************************************************************************************************
3964!> \brief (parallel) Blocking individual file read using explicit offsets
3965!> (serial) Unformatted stream read
3966!> \param[in] fh file handle (file storage unit)
3967!> \param[in] offset file offset (position)
3968!> \param[out] msg data to be read from the file
3969!> \param msglen ...
3970!> \par MPI-I/O mapping mpi_file_read_at
3971!> \par STREAM-I/O mapping READ
3972!> \param[in](optional) msglen number of elements of data
3973! **************************************************************************************************
3974 SUBROUTINE mp_file_read_at_chv(fh, offset, msg, msglen)
3975 CHARACTER, CONTIGUOUS, INTENT(OUT) :: msg(:)
3976 CLASS(mp_file_type), INTENT(IN) :: fh
3977 INTEGER, INTENT(IN), OPTIONAL :: msglen
3978 INTEGER(kind=file_offset), INTENT(IN) :: offset
3979
3980#if defined(__parallel)
3981 INTEGER :: ierr, msg_len
3982#endif
3983
3984#if defined(__parallel)
3985 msg_len = SIZE(msg)
3986 IF (PRESENT(msglen)) msg_len = msglen
3987 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
3988 IF (ierr /= 0) &
3989 cpabort("mpi_file_read_at_chv @ mp_file_read_at_chv")
3990#else
3991 mark_used(msglen)
3992 READ (unit=fh%handle, pos=offset + 1) msg
3993#endif
3994 END SUBROUTINE mp_file_read_at_chv
3995
3996! **************************************************************************************************
3997!> \brief wrapper to MPI_File_read_at
3998!> \param fh ...
3999!> \param offset ...
4000!> \param msg ...
4001! **************************************************************************************************
4002 SUBROUTINE mp_file_read_at_ch(fh, offset, msg)
4003 CHARACTER(LEN=*), INTENT(OUT) :: msg
4004 CLASS(mp_file_type), INTENT(IN) :: fh
4005 INTEGER(kind=file_offset), INTENT(IN) :: offset
4006
4007#if defined(__parallel)
4008 INTEGER :: ierr
4009#endif
4010
4011#if defined(__parallel)
4012 CALL mpi_file_read_at(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4013 IF (ierr /= 0) &
4014 cpabort("mpi_file_read_at_ch @ mp_file_read_at_ch")
4015#else
4016 READ (unit=fh%handle, pos=offset + 1) msg
4017#endif
4018 END SUBROUTINE mp_file_read_at_ch
4019
4020! **************************************************************************************************
4021!> \brief (parallel) Blocking collective file read using explicit offsets
4022!> (serial) Unformatted stream read
4023!> \param fh ...
4024!> \param offset ...
4025!> \param msg ...
4026!> \param msglen ...
4027!> \par MPI-I/O mapping mpi_file_read_at_all
4028!> \par STREAM-I/O mapping READ
4029! **************************************************************************************************
4030 SUBROUTINE mp_file_read_at_all_chv(fh, offset, msg, msglen)
4031 CHARACTER, INTENT(OUT) :: msg(:)
4032 CLASS(mp_file_type), INTENT(IN) :: fh
4033 INTEGER, INTENT(IN), OPTIONAL :: msglen
4034 INTEGER(kind=file_offset), INTENT(IN) :: offset
4035
4036#if defined(__parallel)
4037 INTEGER :: ierr, msg_len
4038#endif
4039
4040#if defined(__parallel)
4041 msg_len = SIZE(msg)
4042 IF (PRESENT(msglen)) msg_len = msglen
4043 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4044 IF (ierr /= 0) &
4045 cpabort("mpi_file_read_at_all_chv @ mp_file_read_at_all_chv")
4046#else
4047 mark_used(msglen)
4048 READ (unit=fh%handle, pos=offset + 1) msg
4049#endif
4050 END SUBROUTINE mp_file_read_at_all_chv
4051
4052! **************************************************************************************************
4053!> \brief wrapper to MPI_File_read_at_all
4054!> \param fh ...
4055!> \param offset ...
4056!> \param msg ...
4057! **************************************************************************************************
4058 SUBROUTINE mp_file_read_at_all_ch(fh, offset, msg)
4059 CHARACTER(LEN=*), INTENT(OUT) :: msg
4060 CLASS(mp_file_type), INTENT(IN) :: fh
4061 INTEGER(kind=file_offset), INTENT(IN) :: offset
4062
4063#if defined(__parallel)
4064 INTEGER :: ierr
4065#endif
4066
4067#if defined(__parallel)
4068 CALL mpi_file_read_at_all(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4069 IF (ierr /= 0) &
4070 cpabort("mpi_file_read_at_all_ch @ mp_file_read_at_all_ch")
4071#else
4072 READ (unit=fh%handle, pos=offset + 1) msg
4073#endif
4074 END SUBROUTINE mp_file_read_at_all_ch
4075
4076! **************************************************************************************************
4077!> \brief Returns the size of a data type in bytes
4078!> \param[in] type_descriptor data type
4079!> \param[out] type_size size of the data type
4080!> \par MPI mapping
4081!> mpi_type_size
4082!>
4083! **************************************************************************************************
4084 SUBROUTINE mp_type_size(type_descriptor, type_size)
4085 TYPE(mp_type_descriptor_type), INTENT(IN) :: type_descriptor
4086 INTEGER, INTENT(OUT) :: type_size
4087
4088#if defined(__parallel)
4089 INTEGER :: ierr
4090
4091 ierr = 0
4092 CALL mpi_type_size(type_descriptor%type_handle, type_size, ierr)
4093 IF (ierr /= 0) &
4094 cpabort("mpi_type_size failed @ mp_type_size")
4095#else
4096 SELECT CASE (type_descriptor%type_handle)
4097 CASE (1)
4098 type_size = real_4_size
4099 CASE (3)
4100 type_size = real_8_size
4101 CASE (5)
4102 type_size = 2*real_4_size
4103 CASE (7)
4104 type_size = 2*real_8_size
4105 END SELECT
4106#endif
4107 END SUBROUTINE mp_type_size
4108
4109! **************************************************************************************************
4110!> \brief wrapper to MPI_Type_create_struct
4111!> \param subtypes ...
4112!> \param vector_descriptor ...
4113!> \param index_descriptor ...
4114!> \return ...
4115! **************************************************************************************************
4116 FUNCTION mp_type_make_struct(subtypes, &
4117 vector_descriptor, index_descriptor) &
4118 result(type_descriptor)
4119 TYPE(mp_type_descriptor_type), &
4120 DIMENSION(:), INTENT(IN) :: subtypes
4121 INTEGER, DIMENSION(2), INTENT(IN), &
4122 OPTIONAL :: vector_descriptor
4123 TYPE(mp_indexing_meta_type), &
4124 INTENT(IN), OPTIONAL :: index_descriptor
4125 TYPE(mp_type_descriptor_type) :: type_descriptor
4126
4127 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_struct'
4128
4129 INTEGER :: i, n
4130 INTEGER, ALLOCATABLE, DIMENSION(:) :: lengths
4131#if defined(__parallel)
4132 INTEGER :: ierr
4133 INTEGER(kind=mpi_address_kind), &
4134 ALLOCATABLE, DIMENSION(:) :: displacements
4135#if defined(__MPI_F08)
4136 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
4137 EXTERNAL :: mpi_get_address
4138#endif
4139#endif
4140 mpi_data_type, ALLOCATABLE, DIMENSION(:) :: old_types
4141
4142 n = SIZE(subtypes)
4143 type_descriptor%length = 1
4144#if defined(__parallel)
4145 ierr = 0
4146 CALL mpi_get_address(mpi_bottom, type_descriptor%base, ierr)
4147 IF (ierr /= 0) &
4148 cpabort("MPI_get_address @ "//routinen)
4149 ALLOCATE (displacements(n))
4150#endif
4151 type_descriptor%vector_descriptor(1:2) = 1
4152 type_descriptor%has_indexing = .false.
4153 ALLOCATE (type_descriptor%subtype(n))
4154 type_descriptor%subtype(:) = subtypes(:)
4155 ALLOCATE (lengths(n), old_types(n))
4156 DO i = 1, SIZE(subtypes)
4157#if defined(__parallel)
4158 displacements(i) = subtypes(i)%base
4159#endif
4160 old_types(i) = subtypes(i)%type_handle
4161 lengths(i) = subtypes(i)%length
4162 END DO
4163#if defined(__parallel)
4164 CALL mpi_type_create_struct(n, &
4165 lengths, displacements, old_types, &
4166 type_descriptor%type_handle, ierr)
4167 IF (ierr /= 0) &
4168 cpabort("MPI_Type_create_struct @ "//routinen)
4169 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4170 IF (ierr /= 0) &
4171 cpabort("MPI_Type_commit @ "//routinen)
4172#endif
4173 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
4174 cpabort(routinen//" Vectors and indices NYI")
4175 END IF
4176 END FUNCTION mp_type_make_struct
4177
4178! **************************************************************************************************
4179!> \brief wrapper to MPI_Type_free
4180!> \param type_descriptor ...
4181! **************************************************************************************************
4182 RECURSIVE SUBROUTINE mp_type_free_m(type_descriptor)
4183 TYPE(mp_type_descriptor_type), INTENT(inout) :: type_descriptor
4184
4185 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_free_m'
4186
4187 INTEGER :: handle, i
4188#if defined(__parallel)
4189 INTEGER :: ierr
4190#endif
4191
4192 CALL mp_timeset(routinen, handle)
4193
4194 ! If the subtype is associated, then it's a user-defined data type.
4195
4196 IF (ASSOCIATED(type_descriptor%subtype)) THEN
4197 DO i = 1, SIZE(type_descriptor%subtype)
4198 CALL mp_type_free_m(type_descriptor%subtype(i))
4199 END DO
4200 DEALLOCATE (type_descriptor%subtype)
4201 END IF
4202#if defined(__parallel)
4203 ierr = 0
4204 CALL mpi_type_free(type_descriptor%type_handle, ierr)
4205 IF (ierr /= 0) &
4206 cpabort("MPI_Type_free @ "//routinen)
4207#endif
4208
4209 CALL mp_timestop(handle)
4210
4211 END SUBROUTINE mp_type_free_m
4212
4213! **************************************************************************************************
4214!> \brief ...
4215!> \param type_descriptors ...
4216! **************************************************************************************************
4217 SUBROUTINE mp_type_free_v(type_descriptors)
4218 TYPE(mp_type_descriptor_type), DIMENSION(:), &
4219 INTENT(inout) :: type_descriptors
4220
4221 INTEGER :: i
4222
4223 DO i = 1, SIZE(type_descriptors)
4224 CALL mp_type_free(type_descriptors(i))
4225 END DO
4226
4227 END SUBROUTINE mp_type_free_v
4228
4229! **************************************************************************************************
4230!> \brief Creates an indexed MPI type for arrays of strings using bytes for spacing (hindexed type)
4231!> \param count number of array blocks to read
4232!> \param lengths lengths of each array block
4233!> \param displs byte offsets for array blocks
4234!> \return container holding the created type
4235!> \author Nico Holmberg [05.2017]
4236! **************************************************************************************************
4237 FUNCTION mp_file_type_hindexed_make_chv(count, lengths, displs) &
4238 result(type_descriptor)
4239 INTEGER, INTENT(IN) :: count
4240 INTEGER, DIMENSION(1:count), &
4241 INTENT(IN), TARGET :: lengths
4242 INTEGER(kind=file_offset), &
4243 DIMENSION(1:count), INTENT(in), TARGET :: displs
4244 TYPE(mp_file_descriptor_type) :: type_descriptor
4245
4246 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_hindexed_make_chv'
4247
4248 INTEGER :: ierr, handle
4249
4250 ierr = 0
4251 CALL mp_timeset(routinen, handle)
4252
4253#if defined(__parallel)
4254 CALL mpi_type_create_hindexed(count, lengths, int(displs, kind=address_kind), mpi_character, &
4255 type_descriptor%type_handle, ierr)
4256 IF (ierr /= 0) &
4257 cpabort("MPI_Type_create_hindexed @ "//routinen)
4258 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4259 IF (ierr /= 0) &
4260 cpabort("MPI_Type_commit @ "//routinen)
4261#else
4262 type_descriptor%type_handle = 68
4263#endif
4264 type_descriptor%length = count
4265 type_descriptor%has_indexing = .true.
4266 type_descriptor%index_descriptor%index => lengths
4267 type_descriptor%index_descriptor%chunks => displs
4268
4269 CALL mp_timestop(handle)
4270
4271 END FUNCTION mp_file_type_hindexed_make_chv
4272
4273! **************************************************************************************************
4274!> \brief Uses a previously created indexed MPI character type to tell the MPI processes
4275!> how to partition (set_view) an opened file
4276!> \param fh the file handle associated with the input file
4277!> \param offset global offset determining where the relevant data begins
4278!> \param type_descriptor container for the MPI type
4279!> \author Nico Holmberg [05.2017]
4280! **************************************************************************************************
4281 SUBROUTINE mp_file_type_set_view_chv(fh, offset, type_descriptor)
4282 TYPE(mp_file_type), INTENT(IN) :: fh
4283 INTEGER(kind=file_offset), INTENT(IN) :: offset
4284 TYPE(mp_file_descriptor_type) :: type_descriptor
4285
4286 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_set_view_chv'
4287
4288 INTEGER :: handle
4289#if defined(__parallel)
4290 INTEGER :: ierr
4291#endif
4292
4293 CALL mp_timeset(routinen, handle)
4294
4295#if defined(__parallel)
4296 ierr = 0
4297 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4298 CALL mpi_file_set_view(fh%handle, offset, mpi_character, &
4299 type_descriptor%type_handle, "native", mpi_info_null, ierr)
4300 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view")
4301#else
4302 ! Uses absolute offsets stored in mp_file_descriptor_type
4303 mark_used(fh)
4304 mark_used(offset)
4305 mark_used(type_descriptor)
4306#endif
4307
4308 CALL mp_timestop(handle)
4309
4310 END SUBROUTINE mp_file_type_set_view_chv
4311
4312! **************************************************************************************************
4313!> \brief (parallel) Collective, blocking read of a character array from a file. File access pattern
4314! determined by a previously set file view.
4315!> (serial) Unformatted stream read using explicit offsets
4316!> \param fh the file handle associated with the input file
4317!> \param msglen the message length of an individual vector component
4318!> \param ndims the number of vector components
4319!> \param buffer the buffer where the data is placed
4320!> \param type_descriptor container for the MPI type
4321!> \author Nico Holmberg [05.2017]
4322! **************************************************************************************************
4323 SUBROUTINE mp_file_read_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4324 CLASS(mp_file_type), INTENT(IN) :: fh
4325 INTEGER, INTENT(IN) :: msglen
4326 INTEGER, INTENT(IN) :: ndims
4327 CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(INOUT) :: buffer
4328 TYPE(mp_file_descriptor_type), &
4329 INTENT(IN), OPTIONAL :: type_descriptor
4330
4331 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_read_all_chv'
4332
4333 INTEGER :: handle
4334#if defined(__parallel)
4335 INTEGER:: ierr
4336#else
4337 INTEGER :: i
4338#endif
4339
4340 CALL mp_timeset(routinen, handle)
4341
4342#if defined(__parallel)
4343 ierr = 0
4344 mark_used(type_descriptor)
4345 CALL mpi_file_read_all(fh%handle, buffer, ndims*msglen, mpi_character, mpi_status_ignore, ierr)
4346 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all")
4347 CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4348#else
4349 mark_used(msglen)
4350 mark_used(ndims)
4351 IF (.NOT. PRESENT(type_descriptor)) &
4352 CALL cp_abort(__location__, &
4353 "Container for mp_file_descriptor_type must be present in serial call.")
4354 IF (.NOT. type_descriptor%has_indexing) &
4355 CALL cp_abort(__location__, &
4356 "File view has not been set in mp_file_descriptor_type.")
4357 ! Use explicit offsets
4358 DO i = 1, ndims
4359 READ (fh%handle, pos=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4360 END DO
4361#endif
4362
4363 CALL mp_timestop(handle)
4364
4365 END SUBROUTINE mp_file_read_all_chv
4366
4367! **************************************************************************************************
4368!> \brief (parallel) Collective, blocking write of a character array to a file. File access pattern
4369! determined by a previously set file view.
4370!> (serial) Unformatted stream write using explicit offsets
4371!> \param fh the file handle associated with the output file
4372!> \param msglen the message length of an individual vector component
4373!> \param ndims the number of vector components
4374!> \param buffer the buffer where the data is placed
4375!> \param type_descriptor container for the MPI type
4376!> \author Nico Holmberg [05.2017]
4377! **************************************************************************************************
4378 SUBROUTINE mp_file_write_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4379 CLASS(mp_file_type), INTENT(IN) :: fh
4380 INTEGER, INTENT(IN) :: msglen
4381 INTEGER, INTENT(IN) :: ndims
4382 CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(IN) :: buffer
4383 TYPE(mp_file_descriptor_type), &
4384 INTENT(IN), OPTIONAL :: type_descriptor
4385
4386 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_write_all_chv'
4387
4388 INTEGER :: handle
4389#if defined(__parallel)
4390 INTEGER :: ierr
4391#else
4392 INTEGER :: i
4393#endif
4394
4395 CALL mp_timeset(routinen, handle)
4396
4397#if defined(__parallel)
4398 mark_used(type_descriptor)
4399 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4400 CALL mpi_file_write_all(fh%handle, buffer, ndims*msglen, mpi_character, mpi_status_ignore, ierr)
4401 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all")
4402 CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4403#else
4404 mark_used(msglen)
4405 mark_used(ndims)
4406 IF (.NOT. PRESENT(type_descriptor)) &
4407 CALL cp_abort(__location__, &
4408 "Container for mp_file_descriptor_type must be present in serial call.")
4409 IF (.NOT. type_descriptor%has_indexing) &
4410 CALL cp_abort(__location__, &
4411 "File view has not been set in mp_file_descriptor_type.")
4412 ! Use explicit offsets
4413 DO i = 1, ndims
4414 WRITE (fh%handle, pos=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4415 END DO
4416#endif
4417
4418 CALL mp_timestop(handle)
4419
4420 END SUBROUTINE mp_file_write_all_chv
4421
4422! **************************************************************************************************
4423!> \brief Releases the type used for MPI I/O
4424!> \param type_descriptor the container for the MPI type
4425!> \author Nico Holmberg [05.2017]
4426! **************************************************************************************************
4427 SUBROUTINE mp_file_type_free(type_descriptor)
4428 TYPE(mp_file_descriptor_type) :: type_descriptor
4429
4430 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_type_free'
4431
4432 INTEGER :: handle
4433#if defined(__parallel)
4434 INTEGER :: ierr
4435#endif
4436
4437 CALL mp_timeset(routinen, handle)
4438
4439#if defined(__parallel)
4440 CALL mpi_type_free(type_descriptor%type_handle, ierr)
4441 IF (ierr /= 0) &
4442 cpabort("MPI_Type_free @ "//routinen)
4443#endif
4444#if defined(__parallel) && defined(__MPI_F08)
4445 type_descriptor%type_handle%mpi_val = -1
4446#else
4447 type_descriptor%type_handle = -1
4448#endif
4449 type_descriptor%length = -1
4450 IF (type_descriptor%has_indexing) THEN
4451 NULLIFY (type_descriptor%index_descriptor%index)
4452 NULLIFY (type_descriptor%index_descriptor%chunks)
4453 type_descriptor%has_indexing = .false.
4454 END IF
4455
4456 CALL mp_timestop(handle)
4457
4458 END SUBROUTINE mp_file_type_free
4459
4460! **************************************************************************************************
4461!> \brief (parallel) Utility routine to determine MPI file access mode based on variables
4462! that in the serial case would get passed to the intrinsic OPEN
4463!> (serial) No action
4464!> \param mpi_io flag that determines if MPI I/O will actually be used
4465!> \param replace flag that indicates whether file needs to be deleted prior to opening it
4466!> \param amode the MPI I/O access mode
4467!> \param form formatted or unformatted data?
4468!> \param action the variable that determines what to do with file
4469!> \param status the status flag:
4470!> \param position should the file be appended or rewound
4471!> \author Nico Holmberg [11.2017]
4472! **************************************************************************************************
4473 SUBROUTINE mp_file_get_amode(mpi_io, replace, amode, form, action, status, position)
4474 LOGICAL, INTENT(INOUT) :: mpi_io, replace
4475 INTEGER, INTENT(OUT) :: amode
4476 CHARACTER(len=*), INTENT(IN) :: form, action, status, position
4477
4478 amode = -1
4479#if defined(__parallel)
4480 ! Disable mpi io for unformatted access
4481 SELECT CASE (form)
4482 CASE ("FORMATTED")
4483 ! Do nothing
4484 CASE ("UNFORMATTED")
4485 mpi_io = .false.
4486 CASE DEFAULT
4487 cpabort("Unknown MPI file form requested.")
4488 END SELECT
4489 ! Determine file access mode (limited set of allowed choices)
4490 SELECT CASE (action)
4491 CASE ("WRITE")
4492 amode = file_amode_wronly
4493 SELECT CASE (status)
4494 CASE ("NEW")
4495 ! Try to open new file for writing, crash if file already exists
4496 amode = amode + file_amode_create + file_amode_excl
4497 CASE ("UNKNOWN")
4498 ! Open file for writing and create it if file does not exist
4499 amode = amode + file_amode_create
4500 SELECT CASE (position)
4501 CASE ("APPEND")
4502 ! Append existing file
4503 amode = amode + file_amode_append
4504 CASE ("REWIND", "ASIS")
4505 ! Do nothing
4506 CASE DEFAULT
4507 cpabort("Unknown MPI file position requested.")
4508 END SELECT
4509 CASE ("OLD")
4510 SELECT CASE (position)
4511 CASE ("APPEND")
4512 ! Append existing file
4513 amode = amode + file_amode_append
4514 CASE ("REWIND", "ASIS")
4515 ! Do nothing
4516 CASE DEFAULT
4517 cpabort("Unknown MPI file position requested.")
4518 END SELECT
4519 CASE ("REPLACE")
4520 ! Overwrite existing file. Must delete existing file first
4521 amode = amode + file_amode_create
4522 replace = .true.
4523 CASE ("SCRATCH")
4524 ! Disable
4525 mpi_io = .false.
4526 CASE DEFAULT
4527 cpabort("Unknown MPI file status requested.")
4528 END SELECT
4529 CASE ("READ")
4530 amode = file_amode_rdonly
4531 SELECT CASE (status)
4532 CASE ("NEW")
4533 cpabort("Cannot read from 'NEW' file.")
4534 CASE ("REPLACE")
4535 cpabort("Illegal status 'REPLACE' for read.")
4536 CASE ("UNKNOWN", "OLD")
4537 ! Do nothing
4538 CASE ("SCRATCH")
4539 ! Disable
4540 mpi_io = .false.
4541 CASE DEFAULT
4542 cpabort("Unknown MPI file status requested.")
4543 END SELECT
4544 CASE ("READWRITE")
4545 amode = file_amode_rdwr
4546 SELECT CASE (status)
4547 CASE ("NEW")
4548 ! Try to open new file, crash if file already exists
4549 amode = amode + file_amode_create + file_amode_excl
4550 CASE ("UNKNOWN")
4551 ! Open file and create it if file does not exist
4552 amode = amode + file_amode_create
4553 SELECT CASE (position)
4554 CASE ("APPEND")
4555 ! Append existing file
4556 amode = amode + file_amode_append
4557 CASE ("REWIND", "ASIS")
4558 ! Do nothing
4559 CASE DEFAULT
4560 cpabort("Unknown MPI file position requested.")
4561 END SELECT
4562 CASE ("OLD")
4563 SELECT CASE (position)
4564 CASE ("APPEND")
4565 ! Append existing file
4566 amode = amode + file_amode_append
4567 CASE ("REWIND", "ASIS")
4568 ! Do nothing
4569 CASE DEFAULT
4570 cpabort("Unknown MPI file position requested.")
4571 END SELECT
4572 CASE ("REPLACE")
4573 ! Overwrite existing file. Must delete existing file first
4574 amode = amode + file_amode_create
4575 replace = .true.
4576 CASE ("SCRATCH")
4577 ! Disable
4578 mpi_io = .false.
4579 CASE DEFAULT
4580 cpabort("Unknown MPI file status requested.")
4581 END SELECT
4582 CASE DEFAULT
4583 cpabort("Unknown MPI file action requested.")
4584 END SELECT
4585#else
4586 mark_used(replace)
4587 mark_used(form)
4588 mark_used(position)
4589 mark_used(status)
4590 mark_used(action)
4591 mpi_io = .false.
4592#endif
4593
4594 END SUBROUTINE mp_file_get_amode
4595
4596! **************************************************************************************************
4597!> \brief Non-blocking send of custom type
4598!> \param msgin ...
4599!> \param dest ...
4600!> \param comm ...
4601!> \param request ...
4602!> \param tag ...
4603! **************************************************************************************************
4604 SUBROUTINE mp_isend_custom(msgin, dest, comm, request, tag)
4605 TYPE(mp_type_descriptor_type), INTENT(IN) :: msgin
4606 INTEGER, INTENT(IN) :: dest
4607 CLASS(mp_comm_type), INTENT(IN) :: comm
4608 TYPE(mp_request_type), INTENT(out) :: request
4609 INTEGER, INTENT(in), OPTIONAL :: tag
4610
4611 INTEGER :: ierr, my_tag
4612
4613 ierr = 0
4614 my_tag = 0
4615
4616#if defined(__parallel)
4617 IF (PRESENT(tag)) my_tag = tag
4618
4619 CALL mpi_isend(mpi_bottom, 1, msgin%type_handle, dest, my_tag, &
4620 comm%handle, request%handle, ierr)
4621 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ mp_isend_custom")
4622#else
4623 mark_used(msgin)
4624 mark_used(dest)
4625 mark_used(comm)
4626 mark_used(tag)
4627 ierr = 1
4628 request = mp_request_null
4629 CALL mp_stop(ierr, "mp_isend called in non parallel case")
4630#endif
4631 END SUBROUTINE mp_isend_custom
4632
4633! **************************************************************************************************
4634!> \brief Non-blocking receive of vector data
4635!> \param msgout ...
4636!> \param source ...
4637!> \param comm ...
4638!> \param request ...
4639!> \param tag ...
4640! **************************************************************************************************
4641 SUBROUTINE mp_irecv_custom(msgout, source, comm, request, tag)
4642 TYPE(mp_type_descriptor_type), INTENT(INOUT) :: msgout
4643 INTEGER, INTENT(IN) :: source
4644 CLASS(mp_comm_type), INTENT(IN) :: comm
4645 TYPE(mp_request_type), INTENT(out) :: request
4646 INTEGER, INTENT(in), OPTIONAL :: tag
4647
4648 INTEGER :: ierr, my_tag
4649
4650 ierr = 0
4651 my_tag = 0
4652
4653#if defined(__parallel)
4654 IF (PRESENT(tag)) my_tag = tag
4655
4656 CALL mpi_irecv(mpi_bottom, 1, msgout%type_handle, source, my_tag, &
4657 comm%handle, request%handle, ierr)
4658 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ mp_irecv_custom")
4659#else
4660 mark_used(msgout)
4661 mark_used(source)
4662 mark_used(comm)
4663 mark_used(tag)
4664 ierr = 1
4665 request = mp_request_null
4666 cpabort("mp_irecv called in non parallel case")
4667#endif
4668 END SUBROUTINE mp_irecv_custom
4669
4670! **************************************************************************************************
4671!> \brief Window free
4672!> \param win ...
4673! **************************************************************************************************
4674 SUBROUTINE mp_win_free(win)
4675 CLASS(mp_win_type), INTENT(INOUT) :: win
4676
4677 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_free'
4678
4679 INTEGER :: handle
4680#if defined(__parallel)
4681 INTEGER :: ierr
4682#endif
4683
4684 CALL mp_timeset(routinen, handle)
4685
4686#if defined(__parallel)
4687 ierr = 0
4688 CALL mpi_win_free(win%handle, ierr)
4689 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_free @ "//routinen)
4690
4691 CALL add_perf(perf_id=21, count=1)
4692#else
4693 win%handle = mp_win_null_handle
4694#endif
4695 CALL mp_timestop(handle)
4696 END SUBROUTINE mp_win_free
4697
4698 SUBROUTINE mp_win_assign(win_new, win_old)
4699 CLASS(mp_win_type), INTENT(OUT) :: win_new
4700 CLASS(mp_win_type), INTENT(IN) :: win_old
4701
4702 win_new%handle = win_old%handle
4703
4704 END SUBROUTINE mp_win_assign
4705
4706! **************************************************************************************************
4707!> \brief Window flush
4708!> \param win ...
4709! **************************************************************************************************
4710 SUBROUTINE mp_win_flush_all(win)
4711 CLASS(mp_win_type), INTENT(IN) :: win
4712
4713 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_flush_all'
4714
4715 INTEGER :: handle, ierr
4716
4717 ierr = 0
4718 CALL mp_timeset(routinen, handle)
4719
4720#if defined(__parallel)
4721 CALL mpi_win_flush_all(win%handle, ierr)
4722 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_flush_all @ "//routinen)
4723#else
4724 mark_used(win)
4725#endif
4726 CALL mp_timestop(handle)
4727 END SUBROUTINE mp_win_flush_all
4728
4729! **************************************************************************************************
4730!> \brief Window lock
4731!> \param win ...
4732! **************************************************************************************************
4733 SUBROUTINE mp_win_lock_all(win)
4734 CLASS(mp_win_type), INTENT(IN) :: win
4735
4736 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_lock_all'
4737
4738 INTEGER :: handle, ierr
4739
4740 ierr = 0
4741 CALL mp_timeset(routinen, handle)
4742
4743#if defined(__parallel)
4744
4745 CALL mpi_win_lock_all(mpi_mode_nocheck, win%handle, ierr)
4746 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_lock_all @ "//routinen)
4747
4748 CALL add_perf(perf_id=19, count=1)
4749#else
4750 mark_used(win)
4751#endif
4752 CALL mp_timestop(handle)
4753 END SUBROUTINE mp_win_lock_all
4754
4755! **************************************************************************************************
4756!> \brief Window lock
4757!> \param win ...
4758! **************************************************************************************************
4759 SUBROUTINE mp_win_unlock_all(win)
4760 CLASS(mp_win_type), INTENT(IN) :: win
4761
4762 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_unlock_all'
4763
4764 INTEGER :: handle, ierr
4765
4766 ierr = 0
4767 CALL mp_timeset(routinen, handle)
4768
4769#if defined(__parallel)
4770
4771 CALL mpi_win_unlock_all(win%handle, ierr)
4772 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_unlock_all @ "//routinen)
4773
4774 CALL add_perf(perf_id=19, count=1)
4775#else
4776 mark_used(win)
4777#endif
4778 CALL mp_timestop(handle)
4779 END SUBROUTINE mp_win_unlock_all
4780
4781! **************************************************************************************************
4782!> \brief Starts a timer region
4783!> \param routineN ...
4784!> \param handle ...
4785! **************************************************************************************************
4786 SUBROUTINE mp_timeset(routineN, handle)
4787 CHARACTER(len=*), INTENT(IN) :: routinen
4788 INTEGER, INTENT(OUT) :: handle
4789
4790 IF (mp_collect_timings) &
4791 CALL timeset(routinen, handle)
4792 END SUBROUTINE mp_timeset
4793
4794! **************************************************************************************************
4795!> \brief Ends a timer region
4796!> \param handle ...
4797! **************************************************************************************************
4798 SUBROUTINE mp_timestop(handle)
4799 INTEGER, INTENT(IN) :: handle
4800
4801 IF (mp_collect_timings) &
4802 CALL timestop(handle)
4803 END SUBROUTINE mp_timestop
4804
4805! **************************************************************************************************
4806!> \brief Shift around the data in msg
4807!> \param[in,out] msg Rank-2 data to shift
4808!> \param[in] comm message passing environment identifier
4809!> \param[in] displ_in displacements (?)
4810!> \par Example
4811!> msg will be moved from rank to rank+displ_in (in a circular way)
4812!> \par Limitations
4813!> * displ_in will be 1 by default (others not tested)
4814!> * the message array needs to be the same size on all processes
4815! **************************************************************************************************
4816 SUBROUTINE mp_shift_im(msg, comm, displ_in)
4817
4818 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
4819 CLASS(mp_comm_type), INTENT(IN) :: comm
4820 INTEGER, INTENT(IN), OPTIONAL :: displ_in
4821
4822 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_im'
4823
4824 INTEGER :: handle, ierror
4825#if defined(__parallel)
4826 INTEGER :: displ, left, &
4827 msglen, myrank, nprocs, &
4828 right, tag
4829#endif
4830
4831 ierror = 0
4832 CALL mp_timeset(routinen, handle)
4833
4834#if defined(__parallel)
4835 CALL mpi_comm_rank(comm%handle, myrank, ierror)
4836 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
4837 CALL mpi_comm_size(comm%handle, nprocs, ierror)
4838 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
4839 IF (PRESENT(displ_in)) THEN
4840 displ = displ_in
4841 ELSE
4842 displ = 1
4843 END IF
4844 right = modulo(myrank + displ, nprocs)
4845 left = modulo(myrank - displ, nprocs)
4846 tag = 17
4847 msglen = SIZE(msg)
4848 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer, right, tag, left, tag, &
4849 comm%handle, mpi_status_ignore, ierror)
4850 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
4851 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_4_size)
4852#else
4853 mark_used(msg)
4854 mark_used(comm)
4855 mark_used(displ_in)
4856#endif
4857 CALL mp_timestop(handle)
4858
4859 END SUBROUTINE mp_shift_im
4860
4861! **************************************************************************************************
4862!> \brief Shift around the data in msg
4863!> \param[in,out] msg Data to shift
4864!> \param[in] comm message passing environment identifier
4865!> \param[in] displ_in displacements (?)
4866!> \par Example
4867!> msg will be moved from rank to rank+displ_in (in a circular way)
4868!> \par Limitations
4869!> * displ_in will be 1 by default (others not tested)
4870!> * the message array needs to be the same size on all processes
4871! **************************************************************************************************
4872 SUBROUTINE mp_shift_i (msg, comm, displ_in)
4873
4874 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
4875 CLASS(mp_comm_type), INTENT(IN) :: comm
4876 INTEGER, INTENT(IN), OPTIONAL :: displ_in
4877
4878 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_i'
4879
4880 INTEGER :: handle, ierror
4881#if defined(__parallel)
4882 INTEGER :: displ, left, &
4883 msglen, myrank, nprocs, &
4884 right, tag
4885#endif
4886
4887 ierror = 0
4888 CALL mp_timeset(routinen, handle)
4889
4890#if defined(__parallel)
4891 CALL mpi_comm_rank(comm%handle, myrank, ierror)
4892 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
4893 CALL mpi_comm_size(comm%handle, nprocs, ierror)
4894 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
4895 IF (PRESENT(displ_in)) THEN
4896 displ = displ_in
4897 ELSE
4898 displ = 1
4899 END IF
4900 right = modulo(myrank + displ, nprocs)
4901 left = modulo(myrank - displ, nprocs)
4902 tag = 19
4903 msglen = SIZE(msg)
4904 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer, right, tag, left, &
4905 tag, comm%handle, mpi_status_ignore, ierror)
4906 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
4907 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_4_size)
4908#else
4909 mark_used(msg)
4910 mark_used(comm)
4911 mark_used(displ_in)
4912#endif
4913 CALL mp_timestop(handle)
4914
4915 END SUBROUTINE mp_shift_i
4916
4917! **************************************************************************************************
4918!> \brief All-to-all data exchange, rank-1 data of different sizes
4919!> \param[in] sb Data to send
4920!> \param[in] scount Data counts for data sent to other processes
4921!> \param[in] sdispl Respective data offsets for data sent to process
4922!> \param[in,out] rb Buffer into which to receive data
4923!> \param[in] rcount Data counts for data received from other
4924!> processes
4925!> \param[in] rdispl Respective data offsets for data received from
4926!> other processes
4927!> \param[in] comm Message passing environment identifier
4928!> \par MPI mapping
4929!> mpi_alltoallv
4930!> \par Array sizes
4931!> The scount, rcount, and the sdispl and rdispl arrays have a
4932!> size equal to the number of processes.
4933!> \par Offsets
4934!> Values in sdispl and rdispl start with 0.
4935! **************************************************************************************************
4936 SUBROUTINE mp_alltoall_i11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
4937
4938 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
4939 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
4940 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
4941 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
4942 CLASS(mp_comm_type), INTENT(IN) :: comm
4943
4944 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i11v'
4945
4946 INTEGER :: handle
4947#if defined(__parallel)
4948 INTEGER :: ierr, msglen
4949#else
4950 INTEGER :: i
4951#endif
4952
4953 CALL mp_timeset(routinen, handle)
4954
4955#if defined(__parallel)
4956 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer, &
4957 rb, rcount, rdispl, mpi_integer, comm%handle, ierr)
4958 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
4959 msglen = sum(scount) + sum(rcount)
4960 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
4961#else
4962 mark_used(comm)
4963 mark_used(scount)
4964 mark_used(sdispl)
4965 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
4966 DO i = 1, rcount(1)
4967 rb(rdispl(1) + i) = sb(sdispl(1) + i)
4968 END DO
4969#endif
4970 CALL mp_timestop(handle)
4971
4972 END SUBROUTINE mp_alltoall_i11v
4973
4974! **************************************************************************************************
4975!> \brief All-to-all data exchange, rank-2 data of different sizes
4976!> \param sb ...
4977!> \param scount ...
4978!> \param sdispl ...
4979!> \param rb ...
4980!> \param rcount ...
4981!> \param rdispl ...
4982!> \param comm ...
4983!> \par MPI mapping
4984!> mpi_alltoallv
4985!> \note see mp_alltoall_i11v
4986! **************************************************************************************************
4987 SUBROUTINE mp_alltoall_i22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
4988
4989 INTEGER(KIND=int_4), DIMENSION(:, :), &
4990 INTENT(IN), CONTIGUOUS :: sb
4991 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
4992 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, &
4993 INTENT(INOUT) :: rb
4994 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
4995 CLASS(mp_comm_type), INTENT(IN) :: comm
4996
4997 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i22v'
4998
4999 INTEGER :: handle
5000#if defined(__parallel)
5001 INTEGER :: ierr, msglen
5002#endif
5003
5004 CALL mp_timeset(routinen, handle)
5005
5006#if defined(__parallel)
5007 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer, &
5008 rb, rcount, rdispl, mpi_integer, comm%handle, ierr)
5009 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
5010 msglen = sum(scount) + sum(rcount)
5011 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*int_4_size)
5012#else
5013 mark_used(comm)
5014 mark_used(scount)
5015 mark_used(sdispl)
5016 mark_used(rcount)
5017 mark_used(rdispl)
5018 rb = sb
5019#endif
5020 CALL mp_timestop(handle)
5021
5022 END SUBROUTINE mp_alltoall_i22v
5023
5024! **************************************************************************************************
5025!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
5026!> \param[in] sb array with data to send
5027!> \param[out] rb array into which data is received
5028!> \param[in] count number of elements to send/receive (product of the
5029!> extents of the first two dimensions)
5030!> \param[in] comm Message passing environment identifier
5031!> \par Index meaning
5032!> \par The first two indices specify the data while the last index counts
5033!> the processes
5034!> \par Sizes of ranks
5035!> All processes have the same data size.
5036!> \par MPI mapping
5037!> mpi_alltoall
5038! **************************************************************************************************
5039 SUBROUTINE mp_alltoall_i (sb, rb, count, comm)
5040
5041 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
5042 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
5043 INTEGER, INTENT(IN) :: count
5044 CLASS(mp_comm_type), INTENT(IN) :: comm
5045
5046 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i'
5047
5048 INTEGER :: handle
5049#if defined(__parallel)
5050 INTEGER :: ierr, msglen, np
5051#endif
5052
5053 CALL mp_timeset(routinen, handle)
5054
5055#if defined(__parallel)
5056 CALL mpi_alltoall(sb, count, mpi_integer, &
5057 rb, count, mpi_integer, comm%handle, ierr)
5058 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5059 CALL mpi_comm_size(comm%handle, np, ierr)
5060 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5061 msglen = 2*count*np
5062 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5063#else
5064 mark_used(count)
5065 mark_used(comm)
5066 rb = sb
5067#endif
5068 CALL mp_timestop(handle)
5069
5070 END SUBROUTINE mp_alltoall_i
5071
5072! **************************************************************************************************
5073!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
5074!> \param sb ...
5075!> \param rb ...
5076!> \param count ...
5077!> \param commp ...
5078!> \note see mp_alltoall_i
5079! **************************************************************************************************
5080 SUBROUTINE mp_alltoall_i22(sb, rb, count, comm)
5081
5082 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
5083 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
5084 INTEGER, INTENT(IN) :: count
5085 CLASS(mp_comm_type), INTENT(IN) :: comm
5086
5087 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i22'
5088
5089 INTEGER :: handle
5090#if defined(__parallel)
5091 INTEGER :: ierr, msglen, np
5092#endif
5093
5094 CALL mp_timeset(routinen, handle)
5095
5096#if defined(__parallel)
5097 CALL mpi_alltoall(sb, count, mpi_integer, &
5098 rb, count, mpi_integer, comm%handle, ierr)
5099 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5100 CALL mpi_comm_size(comm%handle, np, ierr)
5101 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5102 msglen = 2*SIZE(sb)*np
5103 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5104#else
5105 mark_used(count)
5106 mark_used(comm)
5107 rb = sb
5108#endif
5109 CALL mp_timestop(handle)
5110
5111 END SUBROUTINE mp_alltoall_i22
5112
5113! **************************************************************************************************
5114!> \brief All-to-all data exchange, rank-3 data with equal sizes
5115!> \param sb ...
5116!> \param rb ...
5117!> \param count ...
5118!> \param comm ...
5119!> \note see mp_alltoall_i
5120! **************************************************************************************************
5121 SUBROUTINE mp_alltoall_i33(sb, rb, count, comm)
5122
5123 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
5124 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
5125 INTEGER, INTENT(IN) :: count
5126 CLASS(mp_comm_type), INTENT(IN) :: comm
5127
5128 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i33'
5129
5130 INTEGER :: handle
5131#if defined(__parallel)
5132 INTEGER :: ierr, msglen, np
5133#endif
5134
5135 CALL mp_timeset(routinen, handle)
5136
5137#if defined(__parallel)
5138 CALL mpi_alltoall(sb, count, mpi_integer, &
5139 rb, count, mpi_integer, comm%handle, ierr)
5140 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5141 CALL mpi_comm_size(comm%handle, np, ierr)
5142 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5143 msglen = 2*count*np
5144 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5145#else
5146 mark_used(count)
5147 mark_used(comm)
5148 rb = sb
5149#endif
5150 CALL mp_timestop(handle)
5151
5152 END SUBROUTINE mp_alltoall_i33
5153
5154! **************************************************************************************************
5155!> \brief All-to-all data exchange, rank 4 data, equal sizes
5156!> \param sb ...
5157!> \param rb ...
5158!> \param count ...
5159!> \param comm ...
5160!> \note see mp_alltoall_i
5161! **************************************************************************************************
5162 SUBROUTINE mp_alltoall_i44(sb, rb, count, comm)
5163
5164 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5165 INTENT(IN) :: sb
5166 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5167 INTENT(OUT) :: rb
5168 INTEGER, INTENT(IN) :: count
5169 CLASS(mp_comm_type), INTENT(IN) :: comm
5170
5171 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i44'
5172
5173 INTEGER :: handle
5174#if defined(__parallel)
5175 INTEGER :: ierr, msglen, np
5176#endif
5177
5178 CALL mp_timeset(routinen, handle)
5179
5180#if defined(__parallel)
5181 CALL mpi_alltoall(sb, count, mpi_integer, &
5182 rb, count, mpi_integer, comm%handle, ierr)
5183 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5184 CALL mpi_comm_size(comm%handle, np, ierr)
5185 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5186 msglen = 2*count*np
5187 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5188#else
5189 mark_used(count)
5190 mark_used(comm)
5191 rb = sb
5192#endif
5193 CALL mp_timestop(handle)
5194
5195 END SUBROUTINE mp_alltoall_i44
5196
5197! **************************************************************************************************
5198!> \brief All-to-all data exchange, rank 5 data, equal sizes
5199!> \param sb ...
5200!> \param rb ...
5201!> \param count ...
5202!> \param comm ...
5203!> \note see mp_alltoall_i
5204! **************************************************************************************************
5205 SUBROUTINE mp_alltoall_i55(sb, rb, count, comm)
5206
5207 INTEGER(KIND=int_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
5208 INTENT(IN) :: sb
5209 INTEGER(KIND=int_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
5210 INTENT(OUT) :: rb
5211 INTEGER, INTENT(IN) :: count
5212 CLASS(mp_comm_type), INTENT(IN) :: comm
5213
5214 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i55'
5215
5216 INTEGER :: handle
5217#if defined(__parallel)
5218 INTEGER :: ierr, msglen, np
5219#endif
5220
5221 CALL mp_timeset(routinen, handle)
5222
5223#if defined(__parallel)
5224 CALL mpi_alltoall(sb, count, mpi_integer, &
5225 rb, count, mpi_integer, comm%handle, ierr)
5226 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5227 CALL mpi_comm_size(comm%handle, np, ierr)
5228 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5229 msglen = 2*count*np
5230 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5231#else
5232 mark_used(count)
5233 mark_used(comm)
5234 rb = sb
5235#endif
5236 CALL mp_timestop(handle)
5237
5238 END SUBROUTINE mp_alltoall_i55
5239
5240! **************************************************************************************************
5241!> \brief All-to-all data exchange, rank-4 data to rank-5 data
5242!> \param sb ...
5243!> \param rb ...
5244!> \param count ...
5245!> \param comm ...
5246!> \note see mp_alltoall_i
5247!> \note User must ensure size consistency.
5248! **************************************************************************************************
5249 SUBROUTINE mp_alltoall_i45(sb, rb, count, comm)
5250
5251 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5252 INTENT(IN) :: sb
5253 INTEGER(KIND=int_4), &
5254 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
5255 INTEGER, INTENT(IN) :: count
5256 CLASS(mp_comm_type), INTENT(IN) :: comm
5257
5258 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i45'
5259
5260 INTEGER :: handle
5261#if defined(__parallel)
5262 INTEGER :: ierr, msglen, np
5263#endif
5264
5265 CALL mp_timeset(routinen, handle)
5266
5267#if defined(__parallel)
5268 CALL mpi_alltoall(sb, count, mpi_integer, &
5269 rb, count, mpi_integer, comm%handle, ierr)
5270 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5271 CALL mpi_comm_size(comm%handle, np, ierr)
5272 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5273 msglen = 2*count*np
5274 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5275#else
5276 mark_used(count)
5277 mark_used(comm)
5278 rb = reshape(sb, shape(rb))
5279#endif
5280 CALL mp_timestop(handle)
5281
5282 END SUBROUTINE mp_alltoall_i45
5283
5284! **************************************************************************************************
5285!> \brief All-to-all data exchange, rank-3 data to rank-4 data
5286!> \param sb ...
5287!> \param rb ...
5288!> \param count ...
5289!> \param comm ...
5290!> \note see mp_alltoall_i
5291!> \note User must ensure size consistency.
5292! **************************************************************************************************
5293 SUBROUTINE mp_alltoall_i34(sb, rb, count, comm)
5294
5295 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, &
5296 INTENT(IN) :: sb
5297 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5298 INTENT(OUT) :: rb
5299 INTEGER, INTENT(IN) :: count
5300 CLASS(mp_comm_type), INTENT(IN) :: comm
5301
5302 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i34'
5303
5304 INTEGER :: handle
5305#if defined(__parallel)
5306 INTEGER :: ierr, msglen, np
5307#endif
5308
5309 CALL mp_timeset(routinen, handle)
5310
5311#if defined(__parallel)
5312 CALL mpi_alltoall(sb, count, mpi_integer, &
5313 rb, count, mpi_integer, comm%handle, ierr)
5314 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5315 CALL mpi_comm_size(comm%handle, np, ierr)
5316 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5317 msglen = 2*count*np
5318 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5319#else
5320 mark_used(count)
5321 mark_used(comm)
5322 rb = reshape(sb, shape(rb))
5323#endif
5324 CALL mp_timestop(handle)
5325
5326 END SUBROUTINE mp_alltoall_i34
5327
5328! **************************************************************************************************
5329!> \brief All-to-all data exchange, rank-5 data to rank-4 data
5330!> \param sb ...
5331!> \param rb ...
5332!> \param count ...
5333!> \param comm ...
5334!> \note see mp_alltoall_i
5335!> \note User must ensure size consistency.
5336! **************************************************************************************************
5337 SUBROUTINE mp_alltoall_i54(sb, rb, count, comm)
5338
5339 INTEGER(KIND=int_4), &
5340 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
5341 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5342 INTENT(OUT) :: rb
5343 INTEGER, INTENT(IN) :: count
5344 CLASS(mp_comm_type), INTENT(IN) :: comm
5345
5346 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i54'
5347
5348 INTEGER :: handle
5349#if defined(__parallel)
5350 INTEGER :: ierr, msglen, np
5351#endif
5352
5353 CALL mp_timeset(routinen, handle)
5354
5355#if defined(__parallel)
5356 CALL mpi_alltoall(sb, count, mpi_integer, &
5357 rb, count, mpi_integer, comm%handle, ierr)
5358 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5359 CALL mpi_comm_size(comm%handle, np, ierr)
5360 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5361 msglen = 2*count*np
5362 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5363#else
5364 mark_used(count)
5365 mark_used(comm)
5366 rb = reshape(sb, shape(rb))
5367#endif
5368 CALL mp_timestop(handle)
5369
5370 END SUBROUTINE mp_alltoall_i54
5371
5372! **************************************************************************************************
5373!> \brief Send one datum to another process
5374!> \param[in] msg Scalar to send
5375!> \param[in] dest Destination process
5376!> \param[in] tag Transfer identifier
5377!> \param[in] comm Message passing environment identifier
5378!> \par MPI mapping
5379!> mpi_send
5380! **************************************************************************************************
5381 SUBROUTINE mp_send_i (msg, dest, tag, comm)
5382 INTEGER(KIND=int_4), INTENT(IN) :: msg
5383 INTEGER, INTENT(IN) :: dest, tag
5384 CLASS(mp_comm_type), INTENT(IN) :: comm
5385
5386 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_i'
5387
5388 INTEGER :: handle
5389#if defined(__parallel)
5390 INTEGER :: ierr, msglen
5391#endif
5392
5393 CALL mp_timeset(routinen, handle)
5394
5395#if defined(__parallel)
5396 msglen = 1
5397 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5398 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5399 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5400#else
5401 mark_used(msg)
5402 mark_used(dest)
5403 mark_used(tag)
5404 mark_used(comm)
5405 ! only defined in parallel
5406 cpabort("not in parallel mode")
5407#endif
5408 CALL mp_timestop(handle)
5409 END SUBROUTINE mp_send_i
5410
5411! **************************************************************************************************
5412!> \brief Send rank-1 data to another process
5413!> \param[in] msg Rank-1 data to send
5414!> \param dest ...
5415!> \param tag ...
5416!> \param comm ...
5417!> \note see mp_send_i
5418! **************************************************************************************************
5419 SUBROUTINE mp_send_iv(msg, dest, tag, comm)
5420 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
5421 INTEGER, INTENT(IN) :: dest, tag
5422 CLASS(mp_comm_type), INTENT(IN) :: comm
5423
5424 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_iv'
5425
5426 INTEGER :: handle
5427#if defined(__parallel)
5428 INTEGER :: ierr, msglen
5429#endif
5430
5431 CALL mp_timeset(routinen, handle)
5432
5433#if defined(__parallel)
5434 msglen = SIZE(msg)
5435 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5436 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5437 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5438#else
5439 mark_used(msg)
5440 mark_used(dest)
5441 mark_used(tag)
5442 mark_used(comm)
5443 ! only defined in parallel
5444 cpabort("not in parallel mode")
5445#endif
5446 CALL mp_timestop(handle)
5447 END SUBROUTINE mp_send_iv
5448
5449! **************************************************************************************************
5450!> \brief Send rank-2 data to another process
5451!> \param[in] msg Rank-2 data to send
5452!> \param dest ...
5453!> \param tag ...
5454!> \param comm ...
5455!> \note see mp_send_i
5456! **************************************************************************************************
5457 SUBROUTINE mp_send_im2(msg, dest, tag, comm)
5458 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
5459 INTEGER, INTENT(IN) :: dest, tag
5460 CLASS(mp_comm_type), INTENT(IN) :: comm
5461
5462 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_im2'
5463
5464 INTEGER :: handle
5465#if defined(__parallel)
5466 INTEGER :: ierr, msglen
5467#endif
5468
5469 CALL mp_timeset(routinen, handle)
5470
5471#if defined(__parallel)
5472 msglen = SIZE(msg)
5473 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5474 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5475 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5476#else
5477 mark_used(msg)
5478 mark_used(dest)
5479 mark_used(tag)
5480 mark_used(comm)
5481 ! only defined in parallel
5482 cpabort("not in parallel mode")
5483#endif
5484 CALL mp_timestop(handle)
5485 END SUBROUTINE mp_send_im2
5486
5487! **************************************************************************************************
5488!> \brief Send rank-3 data to another process
5489!> \param[in] msg Rank-3 data to send
5490!> \param dest ...
5491!> \param tag ...
5492!> \param comm ...
5493!> \note see mp_send_i
5494! **************************************************************************************************
5495 SUBROUTINE mp_send_im3(msg, dest, tag, comm)
5496 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
5497 INTEGER, INTENT(IN) :: dest, tag
5498 CLASS(mp_comm_type), INTENT(IN) :: comm
5499
5500 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
5501
5502 INTEGER :: handle
5503#if defined(__parallel)
5504 INTEGER :: ierr, msglen
5505#endif
5506
5507 CALL mp_timeset(routinen, handle)
5508
5509#if defined(__parallel)
5510 msglen = SIZE(msg)
5511 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5512 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5513 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5514#else
5515 mark_used(msg)
5516 mark_used(dest)
5517 mark_used(tag)
5518 mark_used(comm)
5519 ! only defined in parallel
5520 cpabort("not in parallel mode")
5521#endif
5522 CALL mp_timestop(handle)
5523 END SUBROUTINE mp_send_im3
5524
5525! **************************************************************************************************
5526!> \brief Receive one datum from another process
5527!> \param[in,out] msg Place received data into this variable
5528!> \param[in,out] source Process to receive from
5529!> \param[in,out] tag Transfer identifier
5530!> \param[in] comm Message passing environment identifier
5531!> \par MPI mapping
5532!> mpi_send
5533! **************************************************************************************************
5534 SUBROUTINE mp_recv_i (msg, source, tag, comm)
5535 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5536 INTEGER, INTENT(INOUT) :: source, tag
5537 CLASS(mp_comm_type), INTENT(IN) :: comm
5538
5539 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_i'
5540
5541 INTEGER :: handle
5542#if defined(__parallel)
5543 INTEGER :: ierr, msglen
5544 mpi_status_type :: status
5545#endif
5546
5547 CALL mp_timeset(routinen, handle)
5548
5549#if defined(__parallel)
5550 msglen = 1
5551 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5552 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5553 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5554 ELSE
5555 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5556 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5557 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5558 source = status mpi_status_extract(mpi_source)
5559 tag = status mpi_status_extract(mpi_tag)
5560 END IF
5561#else
5562 mark_used(msg)
5563 mark_used(source)
5564 mark_used(tag)
5565 mark_used(comm)
5566 ! only defined in parallel
5567 cpabort("not in parallel mode")
5568#endif
5569 CALL mp_timestop(handle)
5570 END SUBROUTINE mp_recv_i
5571
5572! **************************************************************************************************
5573!> \brief Receive rank-1 data from another process
5574!> \param[in,out] msg Place received data into this rank-1 array
5575!> \param source ...
5576!> \param tag ...
5577!> \param comm ...
5578!> \note see mp_recv_i
5579! **************************************************************************************************
5580 SUBROUTINE mp_recv_iv(msg, source, tag, comm)
5581 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5582 INTEGER, INTENT(INOUT) :: source, tag
5583 CLASS(mp_comm_type), INTENT(IN) :: comm
5584
5585 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_iv'
5586
5587 INTEGER :: handle
5588#if defined(__parallel)
5589 INTEGER :: ierr, msglen
5590 mpi_status_type :: status
5591#endif
5592
5593 CALL mp_timeset(routinen, handle)
5594
5595#if defined(__parallel)
5596 msglen = SIZE(msg)
5597 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5598 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5599 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5600 ELSE
5601 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5602 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5603 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5604 source = status mpi_status_extract(mpi_source)
5605 tag = status mpi_status_extract(mpi_tag)
5606 END IF
5607#else
5608 mark_used(msg)
5609 mark_used(source)
5610 mark_used(tag)
5611 mark_used(comm)
5612 ! only defined in parallel
5613 cpabort("not in parallel mode")
5614#endif
5615 CALL mp_timestop(handle)
5616 END SUBROUTINE mp_recv_iv
5617
5618! **************************************************************************************************
5619!> \brief Receive rank-2 data from another process
5620!> \param[in,out] msg Place received data into this rank-2 array
5621!> \param source ...
5622!> \param tag ...
5623!> \param comm ...
5624!> \note see mp_recv_i
5625! **************************************************************************************************
5626 SUBROUTINE mp_recv_im2(msg, source, tag, comm)
5627 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5628 INTEGER, INTENT(INOUT) :: source, tag
5629 CLASS(mp_comm_type), INTENT(IN) :: comm
5630
5631 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_im2'
5632
5633 INTEGER :: handle
5634#if defined(__parallel)
5635 INTEGER :: ierr, msglen
5636 mpi_status_type :: status
5637#endif
5638
5639 CALL mp_timeset(routinen, handle)
5640
5641#if defined(__parallel)
5642 msglen = SIZE(msg)
5643 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5644 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5645 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5646 ELSE
5647 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5648 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5649 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5650 source = status mpi_status_extract(mpi_source)
5651 tag = status mpi_status_extract(mpi_tag)
5652 END IF
5653#else
5654 mark_used(msg)
5655 mark_used(source)
5656 mark_used(tag)
5657 mark_used(comm)
5658 ! only defined in parallel
5659 cpabort("not in parallel mode")
5660#endif
5661 CALL mp_timestop(handle)
5662 END SUBROUTINE mp_recv_im2
5663
5664! **************************************************************************************************
5665!> \brief Receive rank-3 data from another process
5666!> \param[in,out] msg Place received data into this rank-3 array
5667!> \param source ...
5668!> \param tag ...
5669!> \param comm ...
5670!> \note see mp_recv_i
5671! **************************************************************************************************
5672 SUBROUTINE mp_recv_im3(msg, source, tag, comm)
5673 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
5674 INTEGER, INTENT(INOUT) :: source, tag
5675 CLASS(mp_comm_type), INTENT(IN) :: comm
5676
5677 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_im3'
5678
5679 INTEGER :: handle
5680#if defined(__parallel)
5681 INTEGER :: ierr, msglen
5682 mpi_status_type :: status
5683#endif
5684
5685 CALL mp_timeset(routinen, handle)
5686
5687#if defined(__parallel)
5688 msglen = SIZE(msg)
5689 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5690 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5691 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5692 ELSE
5693 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5694 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5695 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5696 source = status mpi_status_extract(mpi_source)
5697 tag = status mpi_status_extract(mpi_tag)
5698 END IF
5699#else
5700 mark_used(msg)
5701 mark_used(source)
5702 mark_used(tag)
5703 mark_used(comm)
5704 ! only defined in parallel
5705 cpabort("not in parallel mode")
5706#endif
5707 CALL mp_timestop(handle)
5708 END SUBROUTINE mp_recv_im3
5709
5710! **************************************************************************************************
5711!> \brief Broadcasts a datum to all processes.
5712!> \param[in] msg Datum to broadcast
5713!> \param[in] source Processes which broadcasts
5714!> \param[in] comm Message passing environment identifier
5715!> \par MPI mapping
5716!> mpi_bcast
5717! **************************************************************************************************
5718 SUBROUTINE mp_bcast_i (msg, source, comm)
5719 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5720 INTEGER, INTENT(IN) :: source
5721 CLASS(mp_comm_type), INTENT(IN) :: comm
5722
5723 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i'
5724
5725 INTEGER :: handle
5726#if defined(__parallel)
5727 INTEGER :: ierr, msglen
5728#endif
5729
5730 CALL mp_timeset(routinen, handle)
5731
5732#if defined(__parallel)
5733 msglen = 1
5734 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
5735 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5736 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5737#else
5738 mark_used(msg)
5739 mark_used(source)
5740 mark_used(comm)
5741#endif
5742 CALL mp_timestop(handle)
5743 END SUBROUTINE mp_bcast_i
5744
5745! **************************************************************************************************
5746!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
5747!> \param[in] msg Datum to broadcast
5748!> \param[in] comm Message passing environment identifier
5749!> \par MPI mapping
5750!> mpi_bcast
5751! **************************************************************************************************
5752 SUBROUTINE mp_bcast_i_src(msg, comm)
5753 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5754 CLASS(mp_comm_type), INTENT(IN) :: comm
5755
5756 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i_src'
5757
5758 INTEGER :: handle
5759#if defined(__parallel)
5760 INTEGER :: ierr, msglen
5761#endif
5762
5763 CALL mp_timeset(routinen, handle)
5764
5765#if defined(__parallel)
5766 msglen = 1
5767 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
5768 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5769 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5770#else
5771 mark_used(msg)
5772 mark_used(comm)
5773#endif
5774 CALL mp_timestop(handle)
5775 END SUBROUTINE mp_bcast_i_src
5776
5777! **************************************************************************************************
5778!> \brief Broadcasts a datum to all processes.
5779!> \param[in] msg Datum to broadcast
5780!> \param[in] source Processes which broadcasts
5781!> \param[in] comm Message passing environment identifier
5782!> \par MPI mapping
5783!> mpi_bcast
5784! **************************************************************************************************
5785 SUBROUTINE mp_ibcast_i (msg, source, comm, request)
5786 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5787 INTEGER, INTENT(IN) :: source
5788 CLASS(mp_comm_type), INTENT(IN) :: comm
5789 TYPE(mp_request_type), INTENT(OUT) :: request
5790
5791 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_i'
5792
5793 INTEGER :: handle
5794#if defined(__parallel)
5795 INTEGER :: ierr, msglen
5796#endif
5797
5798 CALL mp_timeset(routinen, handle)
5799
5800#if defined(__parallel)
5801 msglen = 1
5802 CALL mpi_ibcast(msg, msglen, mpi_integer, source, comm%handle, request%handle, ierr)
5803 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
5804 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_4_size)
5805#else
5806 mark_used(msg)
5807 mark_used(source)
5808 mark_used(comm)
5809 request = mp_request_null
5810#endif
5811 CALL mp_timestop(handle)
5812 END SUBROUTINE mp_ibcast_i
5813
5814! **************************************************************************************************
5815!> \brief Broadcasts rank-1 data to all processes
5816!> \param[in] msg Data to broadcast
5817!> \param source ...
5818!> \param comm ...
5819!> \note see mp_bcast_i1
5820! **************************************************************************************************
5821 SUBROUTINE mp_bcast_iv(msg, source, comm)
5822 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5823 INTEGER, INTENT(IN) :: source
5824 CLASS(mp_comm_type), INTENT(IN) :: comm
5825
5826 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_iv'
5827
5828 INTEGER :: handle
5829#if defined(__parallel)
5830 INTEGER :: ierr, msglen
5831#endif
5832
5833 CALL mp_timeset(routinen, handle)
5834
5835#if defined(__parallel)
5836 msglen = SIZE(msg)
5837 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
5838 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5839 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5840#else
5841 mark_used(msg)
5842 mark_used(source)
5843 mark_used(comm)
5844#endif
5845 CALL mp_timestop(handle)
5846 END SUBROUTINE mp_bcast_iv
5847
5848! **************************************************************************************************
5849!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
5850!> \param[in] msg Data to broadcast
5851!> \param comm ...
5852!> \note see mp_bcast_i1
5853! **************************************************************************************************
5854 SUBROUTINE mp_bcast_iv_src(msg, comm)
5855 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5856 CLASS(mp_comm_type), INTENT(IN) :: comm
5857
5858 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_iv_src'
5859
5860 INTEGER :: handle
5861#if defined(__parallel)
5862 INTEGER :: ierr, msglen
5863#endif
5864
5865 CALL mp_timeset(routinen, handle)
5866
5867#if defined(__parallel)
5868 msglen = SIZE(msg)
5869 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
5870 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5871 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5872#else
5873 mark_used(msg)
5874 mark_used(comm)
5875#endif
5876 CALL mp_timestop(handle)
5877 END SUBROUTINE mp_bcast_iv_src
5878
5879! **************************************************************************************************
5880!> \brief Broadcasts rank-1 data to all processes
5881!> \param[in] msg Data to broadcast
5882!> \param source ...
5883!> \param comm ...
5884!> \note see mp_bcast_i1
5885! **************************************************************************************************
5886 SUBROUTINE mp_ibcast_iv(msg, source, comm, request)
5887 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
5888 INTEGER, INTENT(IN) :: source
5889 CLASS(mp_comm_type), INTENT(IN) :: comm
5890 TYPE(mp_request_type) :: request
5891
5892 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_iv'
5893
5894 INTEGER :: handle
5895#if defined(__parallel)
5896 INTEGER :: ierr, msglen
5897#endif
5898
5899 CALL mp_timeset(routinen, handle)
5900
5901#if defined(__parallel)
5902#if !defined(__GNUC__) || __GNUC__ >= 9
5903 cpassert(is_contiguous(msg))
5904#endif
5905 msglen = SIZE(msg)
5906 CALL mpi_ibcast(msg, msglen, mpi_integer, source, comm%handle, request%handle, ierr)
5907 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
5908 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_4_size)
5909#else
5910 mark_used(msg)
5911 mark_used(source)
5912 mark_used(comm)
5913 request = mp_request_null
5914#endif
5915 CALL mp_timestop(handle)
5916 END SUBROUTINE mp_ibcast_iv
5917
5918! **************************************************************************************************
5919!> \brief Broadcasts rank-2 data to all processes
5920!> \param[in] msg Data to broadcast
5921!> \param source ...
5922!> \param comm ...
5923!> \note see mp_bcast_i1
5924! **************************************************************************************************
5925 SUBROUTINE mp_bcast_im(msg, source, comm)
5926 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5927 INTEGER, INTENT(IN) :: source
5928 CLASS(mp_comm_type), INTENT(IN) :: comm
5929
5930 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_im'
5931
5932 INTEGER :: handle
5933#if defined(__parallel)
5934 INTEGER :: ierr, msglen
5935#endif
5936
5937 CALL mp_timeset(routinen, handle)
5938
5939#if defined(__parallel)
5940 msglen = SIZE(msg)
5941 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
5942 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5943 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5944#else
5945 mark_used(msg)
5946 mark_used(source)
5947 mark_used(comm)
5948#endif
5949 CALL mp_timestop(handle)
5950 END SUBROUTINE mp_bcast_im
5951
5952! **************************************************************************************************
5953!> \brief Broadcasts rank-2 data to all processes
5954!> \param[in] msg Data to broadcast
5955!> \param source ...
5956!> \param comm ...
5957!> \note see mp_bcast_i1
5958! **************************************************************************************************
5959 SUBROUTINE mp_bcast_im_src(msg, comm)
5960 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5961 CLASS(mp_comm_type), INTENT(IN) :: comm
5962
5963 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_im_src'
5964
5965 INTEGER :: handle
5966#if defined(__parallel)
5967 INTEGER :: ierr, msglen
5968#endif
5969
5970 CALL mp_timeset(routinen, handle)
5971
5972#if defined(__parallel)
5973 msglen = SIZE(msg)
5974 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
5975 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5976 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5977#else
5978 mark_used(msg)
5979 mark_used(comm)
5980#endif
5981 CALL mp_timestop(handle)
5982 END SUBROUTINE mp_bcast_im_src
5983
5984! **************************************************************************************************
5985!> \brief Broadcasts rank-3 data to all processes
5986!> \param[in] msg Data to broadcast
5987!> \param source ...
5988!> \param comm ...
5989!> \note see mp_bcast_i1
5990! **************************************************************************************************
5991 SUBROUTINE mp_bcast_i3(msg, source, comm)
5992 INTEGER(KIND=int_4), CONTIGUOUS :: msg(:, :, :)
5993 INTEGER, INTENT(IN) :: source
5994 CLASS(mp_comm_type), INTENT(IN) :: comm
5995
5996 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i3'
5997
5998 INTEGER :: handle
5999#if defined(__parallel)
6000 INTEGER :: ierr, msglen
6001#endif
6002
6003 CALL mp_timeset(routinen, handle)
6004
6005#if defined(__parallel)
6006 msglen = SIZE(msg)
6007 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
6008 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6009 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6010#else
6011 mark_used(msg)
6012 mark_used(source)
6013 mark_used(comm)
6014#endif
6015 CALL mp_timestop(handle)
6016 END SUBROUTINE mp_bcast_i3
6017
6018! **************************************************************************************************
6019!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
6020!> \param[in] msg Data to broadcast
6021!> \param source ...
6022!> \param comm ...
6023!> \note see mp_bcast_i1
6024! **************************************************************************************************
6025 SUBROUTINE mp_bcast_i3_src(msg, comm)
6026 INTEGER(KIND=int_4), CONTIGUOUS :: msg(:, :, :)
6027 CLASS(mp_comm_type), INTENT(IN) :: comm
6028
6029 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i3_src'
6030
6031 INTEGER :: handle
6032#if defined(__parallel)
6033 INTEGER :: ierr, msglen
6034#endif
6035
6036 CALL mp_timeset(routinen, handle)
6037
6038#if defined(__parallel)
6039 msglen = SIZE(msg)
6040 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
6041 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6042 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6043#else
6044 mark_used(msg)
6045 mark_used(comm)
6046#endif
6047 CALL mp_timestop(handle)
6048 END SUBROUTINE mp_bcast_i3_src
6049
6050! **************************************************************************************************
6051!> \brief Sums a datum from all processes with result left on all processes.
6052!> \param[in,out] msg Datum to sum (input) and result (output)
6053!> \param[in] comm Message passing environment identifier
6054!> \par MPI mapping
6055!> mpi_allreduce
6056! **************************************************************************************************
6057 SUBROUTINE mp_sum_i (msg, comm)
6058 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6059 CLASS(mp_comm_type), INTENT(IN) :: comm
6060
6061 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_i'
6062
6063 INTEGER :: handle
6064#if defined(__parallel)
6065 INTEGER :: ierr, msglen
6066#endif
6067
6068 CALL mp_timeset(routinen, handle)
6069
6070#if defined(__parallel)
6071 msglen = 1
6072 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6073 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6074 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6075#else
6076 mark_used(msg)
6077 mark_used(comm)
6078#endif
6079 CALL mp_timestop(handle)
6080 END SUBROUTINE mp_sum_i
6081
6082! **************************************************************************************************
6083!> \brief Element-wise sum of a rank-1 array on all processes.
6084!> \param[in,out] msg Vector to sum and result
6085!> \param comm ...
6086!> \note see mp_sum_i
6087! **************************************************************************************************
6088 SUBROUTINE mp_sum_iv(msg, comm)
6089 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6090 CLASS(mp_comm_type), INTENT(IN) :: comm
6091
6092 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_iv'
6093
6094 INTEGER :: handle
6095#if defined(__parallel)
6096 INTEGER :: ierr, msglen
6097#endif
6098
6099 CALL mp_timeset(routinen, handle)
6100
6101#if defined(__parallel)
6102 msglen = SIZE(msg)
6103 IF (msglen > 0) THEN
6104 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6105 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6106 END IF
6107 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6108#else
6109 mark_used(msg)
6110 mark_used(comm)
6111#endif
6112 CALL mp_timestop(handle)
6113 END SUBROUTINE mp_sum_iv
6114
6115! **************************************************************************************************
6116!> \brief Element-wise sum of a rank-1 array on all processes.
6117!> \param[in,out] msg Vector to sum and result
6118!> \param comm ...
6119!> \note see mp_sum_i
6120! **************************************************************************************************
6121 SUBROUTINE mp_isum_iv(msg, comm, request)
6122 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6123 CLASS(mp_comm_type), INTENT(IN) :: comm
6124 TYPE(mp_request_type), INTENT(OUT) :: request
6125
6126 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_iv'
6127
6128 INTEGER :: handle
6129#if defined(__parallel)
6130 INTEGER :: ierr, msglen
6131#endif
6132
6133 CALL mp_timeset(routinen, handle)
6134
6135#if defined(__parallel)
6136#if !defined(__GNUC__) || __GNUC__ >= 9
6137 cpassert(is_contiguous(msg))
6138#endif
6139 msglen = SIZE(msg)
6140 IF (msglen > 0) THEN
6141 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, request%handle, ierr)
6142 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
6143 ELSE
6144 request = mp_request_null
6145 END IF
6146 CALL add_perf(perf_id=23, count=1, msg_size=msglen*int_4_size)
6147#else
6148 mark_used(msg)
6149 mark_used(comm)
6150 request = mp_request_null
6151#endif
6152 CALL mp_timestop(handle)
6153 END SUBROUTINE mp_isum_iv
6154
6155! **************************************************************************************************
6156!> \brief Element-wise sum of a rank-2 array on all processes.
6157!> \param[in] msg Matrix to sum and result
6158!> \param comm ...
6159!> \note see mp_sum_i
6160! **************************************************************************************************
6161 SUBROUTINE mp_sum_im(msg, comm)
6162 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6163 CLASS(mp_comm_type), INTENT(IN) :: comm
6164
6165 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im'
6166
6167 INTEGER :: handle
6168#if defined(__parallel)
6169 INTEGER, PARAMETER :: max_msg = 2**25
6170 INTEGER :: ierr, m1, msglen, step, msglensum
6171#endif
6172
6173 CALL mp_timeset(routinen, handle)
6174
6175#if defined(__parallel)
6176 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
6177 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
6178 msglensum = 0
6179 DO m1 = lbound(msg, 2), ubound(msg, 2), step
6180 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
6181 msglensum = msglensum + msglen
6182 IF (msglen > 0) THEN
6183 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6184 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6185 END IF
6186 END DO
6187 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_4_size)
6188#else
6189 mark_used(msg)
6190 mark_used(comm)
6191#endif
6192 CALL mp_timestop(handle)
6193 END SUBROUTINE mp_sum_im
6194
6195! **************************************************************************************************
6196!> \brief Element-wise sum of a rank-3 array on all processes.
6197!> \param[in] msg Array to sum and result
6198!> \param comm ...
6199!> \note see mp_sum_i
6200! **************************************************************************************************
6201 SUBROUTINE mp_sum_im3(msg, comm)
6202 INTEGER(KIND=int_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
6203 CLASS(mp_comm_type), INTENT(IN) :: comm
6204
6205 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im3'
6206
6207 INTEGER :: handle
6208#if defined(__parallel)
6209 INTEGER :: ierr, msglen
6210#endif
6211
6212 CALL mp_timeset(routinen, handle)
6213
6214#if defined(__parallel)
6215 msglen = SIZE(msg)
6216 IF (msglen > 0) THEN
6217 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6218 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6219 END IF
6220 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6221#else
6222 mark_used(msg)
6223 mark_used(comm)
6224#endif
6225 CALL mp_timestop(handle)
6226 END SUBROUTINE mp_sum_im3
6227
6228! **************************************************************************************************
6229!> \brief Element-wise sum of a rank-4 array on all processes.
6230!> \param[in] msg Array to sum and result
6231!> \param comm ...
6232!> \note see mp_sum_i
6233! **************************************************************************************************
6234 SUBROUTINE mp_sum_im4(msg, comm)
6235 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
6236 CLASS(mp_comm_type), INTENT(IN) :: comm
6237
6238 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im4'
6239
6240 INTEGER :: handle
6241#if defined(__parallel)
6242 INTEGER :: ierr, msglen
6243#endif
6244
6245 CALL mp_timeset(routinen, handle)
6246
6247#if defined(__parallel)
6248 msglen = SIZE(msg)
6249 IF (msglen > 0) THEN
6250 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6251 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6252 END IF
6253 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6254#else
6255 mark_used(msg)
6256 mark_used(comm)
6257#endif
6258 CALL mp_timestop(handle)
6259 END SUBROUTINE mp_sum_im4
6260
6261! **************************************************************************************************
6262!> \brief Element-wise sum of data from all processes with result left only on
6263!> one.
6264!> \param[in,out] msg Vector to sum (input) and (only on process root)
6265!> result (output)
6266!> \param root ...
6267!> \param[in] comm Message passing environment identifier
6268!> \par MPI mapping
6269!> mpi_reduce
6270! **************************************************************************************************
6271 SUBROUTINE mp_sum_root_iv(msg, root, comm)
6272 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6273 INTEGER, INTENT(IN) :: root
6274 CLASS(mp_comm_type), INTENT(IN) :: comm
6275
6276 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_iv'
6277
6278 INTEGER :: handle
6279#if defined(__parallel)
6280 INTEGER :: ierr, m1, msglen, taskid
6281 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
6282#endif
6283
6284 CALL mp_timeset(routinen, handle)
6285
6286#if defined(__parallel)
6287 msglen = SIZE(msg)
6288 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6289 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6290 IF (msglen > 0) THEN
6291 m1 = SIZE(msg, 1)
6292 ALLOCATE (res(m1))
6293 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_sum, &
6294 root, comm%handle, ierr)
6295 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6296 IF (taskid == root) THEN
6297 msg = res
6298 END IF
6299 DEALLOCATE (res)
6300 END IF
6301 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6302#else
6303 mark_used(msg)
6304 mark_used(root)
6305 mark_used(comm)
6306#endif
6307 CALL mp_timestop(handle)
6308 END SUBROUTINE mp_sum_root_iv
6309
6310! **************************************************************************************************
6311!> \brief Element-wise sum of data from all processes with result left only on
6312!> one.
6313!> \param[in,out] msg Matrix to sum (input) and (only on process root)
6314!> result (output)
6315!> \param root ...
6316!> \param comm ...
6317!> \note see mp_sum_root_iv
6318! **************************************************************************************************
6319 SUBROUTINE mp_sum_root_im(msg, root, comm)
6320 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6321 INTEGER, INTENT(IN) :: root
6322 CLASS(mp_comm_type), INTENT(IN) :: comm
6323
6324 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
6325
6326 INTEGER :: handle
6327#if defined(__parallel)
6328 INTEGER :: ierr, m1, m2, msglen, taskid
6329 INTEGER(KIND=int_4), ALLOCATABLE :: res(:, :)
6330#endif
6331
6332 CALL mp_timeset(routinen, handle)
6333
6334#if defined(__parallel)
6335 msglen = SIZE(msg)
6336 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6337 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6338 IF (msglen > 0) THEN
6339 m1 = SIZE(msg, 1)
6340 m2 = SIZE(msg, 2)
6341 ALLOCATE (res(m1, m2))
6342 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_sum, root, comm%handle, ierr)
6343 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6344 IF (taskid == root) THEN
6345 msg = res
6346 END IF
6347 DEALLOCATE (res)
6348 END IF
6349 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6350#else
6351 mark_used(root)
6352 mark_used(msg)
6353 mark_used(comm)
6354#endif
6355 CALL mp_timestop(handle)
6356 END SUBROUTINE mp_sum_root_im
6357
6358! **************************************************************************************************
6359!> \brief Partial sum of data from all processes with result on each process.
6360!> \param[in] msg Matrix to sum (input)
6361!> \param[out] res Matrix containing result (output)
6362!> \param[in] comm Message passing environment identifier
6363! **************************************************************************************************
6364 SUBROUTINE mp_sum_partial_im(msg, res, comm)
6365 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
6366 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
6367 CLASS(mp_comm_type), INTENT(IN) :: comm
6368
6369 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_im'
6370
6371 INTEGER :: handle
6372#if defined(__parallel)
6373 INTEGER :: ierr, msglen, taskid
6374#endif
6375
6376 CALL mp_timeset(routinen, handle)
6377
6378#if defined(__parallel)
6379 msglen = SIZE(msg)
6380 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6381 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6382 IF (msglen > 0) THEN
6383 CALL mpi_scan(msg, res, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6384 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
6385 END IF
6386 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6387 ! perf_id is same as for other summation routines
6388#else
6389 res = msg
6390 mark_used(comm)
6391#endif
6392 CALL mp_timestop(handle)
6393 END SUBROUTINE mp_sum_partial_im
6394
6395! **************************************************************************************************
6396!> \brief Finds the maximum of a datum with the result left on all processes.
6397!> \param[in,out] msg Find maximum among these data (input) and
6398!> maximum (output)
6399!> \param[in] comm Message passing environment identifier
6400!> \par MPI mapping
6401!> mpi_allreduce
6402! **************************************************************************************************
6403 SUBROUTINE mp_max_i (msg, comm)
6404 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6405 CLASS(mp_comm_type), INTENT(IN) :: comm
6406
6407 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_i'
6408
6409 INTEGER :: handle
6410#if defined(__parallel)
6411 INTEGER :: ierr, msglen
6412#endif
6413
6414 CALL mp_timeset(routinen, handle)
6415
6416#if defined(__parallel)
6417 msglen = 1
6418 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6419 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6420 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6421#else
6422 mark_used(msg)
6423 mark_used(comm)
6424#endif
6425 CALL mp_timestop(handle)
6426 END SUBROUTINE mp_max_i
6427
6428! **************************************************************************************************
6429!> \brief Finds the maximum of a datum with the result left on all processes.
6430!> \param[in,out] msg Find maximum among these data (input) and
6431!> maximum (output)
6432!> \param[in] comm Message passing environment identifier
6433!> \par MPI mapping
6434!> mpi_allreduce
6435! **************************************************************************************************
6436 SUBROUTINE mp_max_root_i (msg, root, comm)
6437 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6438 INTEGER, INTENT(IN) :: root
6439 CLASS(mp_comm_type), INTENT(IN) :: comm
6440
6441 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_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 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_max, root, comm%handle, ierr)
6454 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6455 IF (root == comm%mepos) msg = res
6456 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6457#else
6458 mark_used(msg)
6459 mark_used(comm)
6460 mark_used(root)
6461#endif
6462 CALL mp_timestop(handle)
6463 END SUBROUTINE mp_max_root_i
6464
6465! **************************************************************************************************
6466!> \brief Finds the element-wise maximum of a vector with the result left on
6467!> all processes.
6468!> \param[in,out] msg Find maximum among these data (input) and
6469!> maximum (output)
6470!> \param comm ...
6471!> \note see mp_max_i
6472! **************************************************************************************************
6473 SUBROUTINE mp_max_iv(msg, comm)
6474 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6475 CLASS(mp_comm_type), INTENT(IN) :: comm
6476
6477 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_iv'
6478
6479 INTEGER :: handle
6480#if defined(__parallel)
6481 INTEGER :: ierr, msglen
6482#endif
6483
6484 CALL mp_timeset(routinen, handle)
6485
6486#if defined(__parallel)
6487 msglen = SIZE(msg)
6488 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6489 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6490 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6491#else
6492 mark_used(msg)
6493 mark_used(comm)
6494#endif
6495 CALL mp_timestop(handle)
6496 END SUBROUTINE mp_max_iv
6497
6498! **************************************************************************************************
6499!> \brief Finds the element-wise maximum of a vector with the result left on
6500!> all processes.
6501!> \param[in,out] msg Find maximum among these data (input) and
6502!> maximum (output)
6503!> \param comm ...
6504!> \note see mp_max_i
6505! **************************************************************************************************
6506 SUBROUTINE mp_max_root_im(msg, root, comm)
6507 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6508 INTEGER :: root
6509 CLASS(mp_comm_type), INTENT(IN) :: comm
6510
6511 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_im'
6512
6513 INTEGER :: handle
6514#if defined(__parallel)
6515 INTEGER :: ierr, msglen
6516 INTEGER(KIND=int_4) :: res(size(msg, 1), size(msg, 2))
6517#endif
6518
6519 CALL mp_timeset(routinen, handle)
6520
6521#if defined(__parallel)
6522 msglen = SIZE(msg)
6523 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_max, root, comm%handle, ierr)
6524 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6525 IF (root == comm%mepos) msg = res
6526 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6527#else
6528 mark_used(msg)
6529 mark_used(comm)
6530 mark_used(root)
6531#endif
6532 CALL mp_timestop(handle)
6533 END SUBROUTINE mp_max_root_im
6534
6535! **************************************************************************************************
6536!> \brief Finds the minimum of a datum with the result left on all processes.
6537!> \param[in,out] msg Find minimum among these data (input) and
6538!> maximum (output)
6539!> \param[in] comm Message passing environment identifier
6540!> \par MPI mapping
6541!> mpi_allreduce
6542! **************************************************************************************************
6543 SUBROUTINE mp_min_i (msg, comm)
6544 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6545 CLASS(mp_comm_type), INTENT(IN) :: comm
6546
6547 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_i'
6548
6549 INTEGER :: handle
6550#if defined(__parallel)
6551 INTEGER :: ierr, msglen
6552#endif
6553
6554 CALL mp_timeset(routinen, handle)
6555
6556#if defined(__parallel)
6557 msglen = 1
6558 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6559 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6560 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6561#else
6562 mark_used(msg)
6563 mark_used(comm)
6564#endif
6565 CALL mp_timestop(handle)
6566 END SUBROUTINE mp_min_i
6567
6568! **************************************************************************************************
6569!> \brief Finds the element-wise minimum of vector with the result left on
6570!> all processes.
6571!> \param[in,out] msg Find minimum among these data (input) and
6572!> maximum (output)
6573!> \param comm ...
6574!> \par MPI mapping
6575!> mpi_allreduce
6576!> \note see mp_min_i
6577! **************************************************************************************************
6578 SUBROUTINE mp_min_iv(msg, comm)
6579 INTEGER(KIND=int_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
6580 CLASS(mp_comm_type), INTENT(IN) :: comm
6581
6582 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_iv'
6583
6584 INTEGER :: handle
6585#if defined(__parallel)
6586 INTEGER :: ierr, msglen
6587#endif
6588
6589 CALL mp_timeset(routinen, handle)
6590
6591#if defined(__parallel)
6592 msglen = SIZE(msg)
6593 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6594 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6595 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6596#else
6597 mark_used(msg)
6598 mark_used(comm)
6599#endif
6600 CALL mp_timestop(handle)
6601 END SUBROUTINE mp_min_iv
6602
6603! **************************************************************************************************
6604!> \brief Multiplies a set of numbers scattered across a number of processes,
6605!> then replicates the result.
6606!> \param[in,out] msg a number to multiply (input) and result (output)
6607!> \param[in] comm message passing environment identifier
6608!> \par MPI mapping
6609!> mpi_allreduce
6610! **************************************************************************************************
6611 SUBROUTINE mp_prod_i (msg, comm)
6612 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6613 CLASS(mp_comm_type), INTENT(IN) :: comm
6614
6615 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_i'
6616
6617 INTEGER :: handle
6618#if defined(__parallel)
6619 INTEGER :: ierr, msglen
6620#endif
6621
6622 CALL mp_timeset(routinen, handle)
6623
6624#if defined(__parallel)
6625 msglen = 1
6626 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_prod, comm%handle, ierr)
6627 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6628 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6629#else
6630 mark_used(msg)
6631 mark_used(comm)
6632#endif
6633 CALL mp_timestop(handle)
6634 END SUBROUTINE mp_prod_i
6635
6636! **************************************************************************************************
6637!> \brief Scatters data from one processes to all others
6638!> \param[in] msg_scatter Data to scatter (for root process)
6639!> \param[out] msg Received data
6640!> \param[in] root Process which scatters data
6641!> \param[in] comm Message passing environment identifier
6642!> \par MPI mapping
6643!> mpi_scatter
6644! **************************************************************************************************
6645 SUBROUTINE mp_scatter_iv(msg_scatter, msg, root, comm)
6646 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
6647 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
6648 INTEGER, INTENT(IN) :: root
6649 CLASS(mp_comm_type), INTENT(IN) :: comm
6650
6651 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_iv'
6652
6653 INTEGER :: handle
6654#if defined(__parallel)
6655 INTEGER :: ierr, msglen
6656#endif
6657
6658 CALL mp_timeset(routinen, handle)
6659
6660#if defined(__parallel)
6661 msglen = SIZE(msg)
6662 CALL mpi_scatter(msg_scatter, msglen, mpi_integer, msg, &
6663 msglen, mpi_integer, root, comm%handle, ierr)
6664 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
6665 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6666#else
6667 mark_used(root)
6668 mark_used(comm)
6669 msg = msg_scatter
6670#endif
6671 CALL mp_timestop(handle)
6672 END SUBROUTINE mp_scatter_iv
6673
6674! **************************************************************************************************
6675!> \brief Scatters data from one processes to all others
6676!> \param[in] msg_scatter Data to scatter (for root process)
6677!> \param[in] root Process which scatters data
6678!> \param[in] comm Message passing environment identifier
6679!> \par MPI mapping
6680!> mpi_scatter
6681! **************************************************************************************************
6682 SUBROUTINE mp_iscatter_i (msg_scatter, msg, root, comm, request)
6683 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:)
6684 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6685 INTEGER, INTENT(IN) :: root
6686 CLASS(mp_comm_type), INTENT(IN) :: comm
6687 TYPE(mp_request_type), INTENT(OUT) :: request
6688
6689 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_i'
6690
6691 INTEGER :: handle
6692#if defined(__parallel)
6693 INTEGER :: ierr, msglen
6694#endif
6695
6696 CALL mp_timeset(routinen, handle)
6697
6698#if defined(__parallel)
6699#if !defined(__GNUC__) || __GNUC__ >= 9
6700 cpassert(is_contiguous(msg_scatter))
6701#endif
6702 msglen = 1
6703 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer, msg, &
6704 msglen, mpi_integer, root, comm%handle, request%handle, ierr)
6705 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
6706 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6707#else
6708 mark_used(root)
6709 mark_used(comm)
6710 msg = msg_scatter(1)
6711 request = mp_request_null
6712#endif
6713 CALL mp_timestop(handle)
6714 END SUBROUTINE mp_iscatter_i
6715
6716! **************************************************************************************************
6717!> \brief Scatters data from one processes to all others
6718!> \param[in] msg_scatter Data to scatter (for root process)
6719!> \param[in] root Process which scatters data
6720!> \param[in] comm Message passing environment identifier
6721!> \par MPI mapping
6722!> mpi_scatter
6723! **************************************************************************************************
6724 SUBROUTINE mp_iscatter_iv2(msg_scatter, msg, root, comm, request)
6725 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:, :)
6726 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6727 INTEGER, INTENT(IN) :: root
6728 CLASS(mp_comm_type), INTENT(IN) :: comm
6729 TYPE(mp_request_type), INTENT(OUT) :: request
6730
6731 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_iv2'
6732
6733 INTEGER :: handle
6734#if defined(__parallel)
6735 INTEGER :: ierr, msglen
6736#endif
6737
6738 CALL mp_timeset(routinen, handle)
6739
6740#if defined(__parallel)
6741#if !defined(__GNUC__) || __GNUC__ >= 9
6742 cpassert(is_contiguous(msg_scatter))
6743#endif
6744 msglen = SIZE(msg)
6745 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer, msg, &
6746 msglen, mpi_integer, root, comm%handle, request%handle, ierr)
6747 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
6748 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6749#else
6750 mark_used(root)
6751 mark_used(comm)
6752 msg(:) = msg_scatter(:, 1)
6753 request = mp_request_null
6754#endif
6755 CALL mp_timestop(handle)
6756 END SUBROUTINE mp_iscatter_iv2
6757
6758! **************************************************************************************************
6759!> \brief Scatters data from one processes to all others
6760!> \param[in] msg_scatter Data to scatter (for root process)
6761!> \param[in] root Process which scatters data
6762!> \param[in] comm Message passing environment identifier
6763!> \par MPI mapping
6764!> mpi_scatter
6765! **************************************************************************************************
6766 SUBROUTINE mp_iscatterv_iv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
6767 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:)
6768 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
6769 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6770 INTEGER, INTENT(IN) :: recvcount, root
6771 CLASS(mp_comm_type), INTENT(IN) :: comm
6772 TYPE(mp_request_type), INTENT(OUT) :: request
6773
6774 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_iv'
6775
6776 INTEGER :: handle
6777#if defined(__parallel)
6778 INTEGER :: ierr
6779#endif
6780
6781 CALL mp_timeset(routinen, handle)
6782
6783#if defined(__parallel)
6784#if !defined(__GNUC__) || __GNUC__ >= 9
6785 cpassert(is_contiguous(msg_scatter))
6786 cpassert(is_contiguous(msg))
6787 cpassert(is_contiguous(sendcounts))
6788 cpassert(is_contiguous(displs))
6789#endif
6790 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_integer, msg, &
6791 recvcount, mpi_integer, root, comm%handle, request%handle, ierr)
6792 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
6793 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6794#else
6795 mark_used(sendcounts)
6796 mark_used(displs)
6797 mark_used(recvcount)
6798 mark_used(root)
6799 mark_used(comm)
6800 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
6801 request = mp_request_null
6802#endif
6803 CALL mp_timestop(handle)
6804 END SUBROUTINE mp_iscatterv_iv
6805
6806! **************************************************************************************************
6807!> \brief Gathers a datum from all processes to one
6808!> \param[in] msg Datum to send to root
6809!> \param[out] msg_gather Received data (on root)
6810!> \param[in] root Process which gathers the data
6811!> \param[in] comm Message passing environment identifier
6812!> \par MPI mapping
6813!> mpi_gather
6814! **************************************************************************************************
6815 SUBROUTINE mp_gather_i (msg, msg_gather, root, comm)
6816 INTEGER(KIND=int_4), INTENT(IN) :: msg
6817 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
6818 INTEGER, INTENT(IN) :: root
6819 CLASS(mp_comm_type), INTENT(IN) :: comm
6820
6821 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_i'
6822
6823 INTEGER :: handle
6824#if defined(__parallel)
6825 INTEGER :: ierr, msglen
6826#endif
6827
6828 CALL mp_timeset(routinen, handle)
6829
6830#if defined(__parallel)
6831 msglen = 1
6832 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
6833 msglen, mpi_integer, root, comm%handle, ierr)
6834 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
6835 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6836#else
6837 mark_used(root)
6838 mark_used(comm)
6839 msg_gather(1) = msg
6840#endif
6841 CALL mp_timestop(handle)
6842 END SUBROUTINE mp_gather_i
6843
6844! **************************************************************************************************
6845!> \brief Gathers a datum from all processes to one, uses the source process of comm
6846!> \param[in] msg Datum to send to root
6847!> \param[out] msg_gather Received data (on root)
6848!> \param[in] comm Message passing environment identifier
6849!> \par MPI mapping
6850!> mpi_gather
6851! **************************************************************************************************
6852 SUBROUTINE mp_gather_i_src(msg, msg_gather, comm)
6853 INTEGER(KIND=int_4), INTENT(IN) :: msg
6854 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
6855 CLASS(mp_comm_type), INTENT(IN) :: comm
6856
6857 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_i_src'
6858
6859 INTEGER :: handle
6860#if defined(__parallel)
6861 INTEGER :: ierr, msglen
6862#endif
6863
6864 CALL mp_timeset(routinen, handle)
6865
6866#if defined(__parallel)
6867 msglen = 1
6868 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
6869 msglen, mpi_integer, comm%source, comm%handle, ierr)
6870 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
6871 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6872#else
6873 mark_used(comm)
6874 msg_gather(1) = msg
6875#endif
6876 CALL mp_timestop(handle)
6877 END SUBROUTINE mp_gather_i_src
6878
6879! **************************************************************************************************
6880!> \brief Gathers data from all processes to one
6881!> \param[in] msg Datum to send to root
6882!> \param msg_gather ...
6883!> \param root ...
6884!> \param comm ...
6885!> \par Data length
6886!> All data (msg) is equal-sized
6887!> \par MPI mapping
6888!> mpi_gather
6889!> \note see mp_gather_i
6890! **************************************************************************************************
6891 SUBROUTINE mp_gather_iv(msg, msg_gather, root, comm)
6892 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
6893 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
6894 INTEGER, INTENT(IN) :: root
6895 CLASS(mp_comm_type), INTENT(IN) :: comm
6896
6897 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_iv'
6898
6899 INTEGER :: handle
6900#if defined(__parallel)
6901 INTEGER :: ierr, msglen
6902#endif
6903
6904 CALL mp_timeset(routinen, handle)
6905
6906#if defined(__parallel)
6907 msglen = SIZE(msg)
6908 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
6909 msglen, mpi_integer, root, comm%handle, ierr)
6910 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
6911 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6912#else
6913 mark_used(root)
6914 mark_used(comm)
6915 msg_gather = msg
6916#endif
6917 CALL mp_timestop(handle)
6918 END SUBROUTINE mp_gather_iv
6919
6920! **************************************************************************************************
6921!> \brief Gathers data from all processes to one. Gathers from comm%source
6922!> \param[in] msg Datum to send to root
6923!> \param msg_gather ...
6924!> \param comm ...
6925!> \par Data length
6926!> All data (msg) is equal-sized
6927!> \par MPI mapping
6928!> mpi_gather
6929!> \note see mp_gather_i
6930! **************************************************************************************************
6931 SUBROUTINE mp_gather_iv_src(msg, msg_gather, comm)
6932 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
6933 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
6934 CLASS(mp_comm_type), INTENT(IN) :: comm
6935
6936 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_iv_src'
6937
6938 INTEGER :: handle
6939#if defined(__parallel)
6940 INTEGER :: ierr, msglen
6941#endif
6942
6943 CALL mp_timeset(routinen, handle)
6944
6945#if defined(__parallel)
6946 msglen = SIZE(msg)
6947 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
6948 msglen, mpi_integer, comm%source, comm%handle, ierr)
6949 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
6950 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6951#else
6952 mark_used(comm)
6953 msg_gather = msg
6954#endif
6955 CALL mp_timestop(handle)
6956 END SUBROUTINE mp_gather_iv_src
6957
6958! **************************************************************************************************
6959!> \brief Gathers data from all processes to one
6960!> \param[in] msg Datum to send to root
6961!> \param msg_gather ...
6962!> \param root ...
6963!> \param comm ...
6964!> \par Data length
6965!> All data (msg) is equal-sized
6966!> \par MPI mapping
6967!> mpi_gather
6968!> \note see mp_gather_i
6969! **************************************************************************************************
6970 SUBROUTINE mp_gather_im(msg, msg_gather, root, comm)
6971 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
6972 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
6973 INTEGER, INTENT(IN) :: root
6974 CLASS(mp_comm_type), INTENT(IN) :: comm
6975
6976 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_im'
6977
6978 INTEGER :: handle
6979#if defined(__parallel)
6980 INTEGER :: ierr, msglen
6981#endif
6982
6983 CALL mp_timeset(routinen, handle)
6984
6985#if defined(__parallel)
6986 msglen = SIZE(msg)
6987 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
6988 msglen, mpi_integer, root, comm%handle, ierr)
6989 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
6990 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6991#else
6992 mark_used(root)
6993 mark_used(comm)
6994 msg_gather = msg
6995#endif
6996 CALL mp_timestop(handle)
6997 END SUBROUTINE mp_gather_im
6998
6999! **************************************************************************************************
7000!> \brief Gathers data from all processes to one. Gathers from comm%source
7001!> \param[in] msg Datum to send to root
7002!> \param msg_gather ...
7003!> \param comm ...
7004!> \par Data length
7005!> All data (msg) is equal-sized
7006!> \par MPI mapping
7007!> mpi_gather
7008!> \note see mp_gather_i
7009! **************************************************************************************************
7010 SUBROUTINE mp_gather_im_src(msg, msg_gather, comm)
7011 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
7012 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
7013 CLASS(mp_comm_type), INTENT(IN) :: comm
7014
7015 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_im_src'
7016
7017 INTEGER :: handle
7018#if defined(__parallel)
7019 INTEGER :: ierr, msglen
7020#endif
7021
7022 CALL mp_timeset(routinen, handle)
7023
7024#if defined(__parallel)
7025 msglen = SIZE(msg)
7026 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7027 msglen, mpi_integer, comm%source, comm%handle, ierr)
7028 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7029 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7030#else
7031 mark_used(comm)
7032 msg_gather = msg
7033#endif
7034 CALL mp_timestop(handle)
7035 END SUBROUTINE mp_gather_im_src
7036
7037! **************************************************************************************************
7038!> \brief Gathers data from all processes to one.
7039!> \param[in] sendbuf Data to send to root
7040!> \param[out] recvbuf Received data (on root)
7041!> \param[in] recvcounts Sizes of data received from processes
7042!> \param[in] displs Offsets of data received from processes
7043!> \param[in] root Process which gathers the data
7044!> \param[in] comm Message passing environment identifier
7045!> \par Data length
7046!> Data can have different lengths
7047!> \par Offsets
7048!> Offsets start at 0
7049!> \par MPI mapping
7050!> mpi_gather
7051! **************************************************************************************************
7052 SUBROUTINE mp_gatherv_iv(sendbuf, recvbuf, recvcounts, displs, root, comm)
7053
7054 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
7055 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
7056 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7057 INTEGER, INTENT(IN) :: root
7058 CLASS(mp_comm_type), INTENT(IN) :: comm
7059
7060 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_iv'
7061
7062 INTEGER :: handle
7063#if defined(__parallel)
7064 INTEGER :: ierr, sendcount
7065#endif
7066
7067 CALL mp_timeset(routinen, handle)
7068
7069#if defined(__parallel)
7070 sendcount = SIZE(sendbuf)
7071 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7072 recvbuf, recvcounts, displs, mpi_integer, &
7073 root, comm%handle, ierr)
7074 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7075 CALL add_perf(perf_id=4, &
7076 count=1, &
7077 msg_size=sendcount*int_4_size)
7078#else
7079 mark_used(recvcounts)
7080 mark_used(root)
7081 mark_used(comm)
7082 recvbuf(1 + displs(1):) = sendbuf
7083#endif
7084 CALL mp_timestop(handle)
7085 END SUBROUTINE mp_gatherv_iv
7086
7087! **************************************************************************************************
7088!> \brief Gathers data from all processes to one. Gathers from comm%source
7089!> \param[in] sendbuf Data to send to root
7090!> \param[out] recvbuf Received data (on root)
7091!> \param[in] recvcounts Sizes of data received from processes
7092!> \param[in] displs Offsets of data received from processes
7093!> \param[in] comm Message passing environment identifier
7094!> \par Data length
7095!> Data can have different lengths
7096!> \par Offsets
7097!> Offsets start at 0
7098!> \par MPI mapping
7099!> mpi_gather
7100! **************************************************************************************************
7101 SUBROUTINE mp_gatherv_iv_src(sendbuf, recvbuf, recvcounts, displs, comm)
7102
7103 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
7104 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
7105 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7106 CLASS(mp_comm_type), INTENT(IN) :: comm
7107
7108 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_iv_src'
7109
7110 INTEGER :: handle
7111#if defined(__parallel)
7112 INTEGER :: ierr, sendcount
7113#endif
7114
7115 CALL mp_timeset(routinen, handle)
7116
7117#if defined(__parallel)
7118 sendcount = SIZE(sendbuf)
7119 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7120 recvbuf, recvcounts, displs, mpi_integer, &
7121 comm%source, comm%handle, ierr)
7122 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7123 CALL add_perf(perf_id=4, &
7124 count=1, &
7125 msg_size=sendcount*int_4_size)
7126#else
7127 mark_used(recvcounts)
7128 mark_used(comm)
7129 recvbuf(1 + displs(1):) = sendbuf
7130#endif
7131 CALL mp_timestop(handle)
7132 END SUBROUTINE mp_gatherv_iv_src
7133
7134! **************************************************************************************************
7135!> \brief Gathers data from all processes to one.
7136!> \param[in] sendbuf Data to send to root
7137!> \param[out] recvbuf Received data (on root)
7138!> \param[in] recvcounts Sizes of data received from processes
7139!> \param[in] displs Offsets of data received from processes
7140!> \param[in] root Process which gathers the data
7141!> \param[in] comm Message passing environment identifier
7142!> \par Data length
7143!> Data can have different lengths
7144!> \par Offsets
7145!> Offsets start at 0
7146!> \par MPI mapping
7147!> mpi_gather
7148! **************************************************************************************************
7149 SUBROUTINE mp_gatherv_im2(sendbuf, recvbuf, recvcounts, displs, root, comm)
7150
7151 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
7152 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
7153 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7154 INTEGER, INTENT(IN) :: root
7155 CLASS(mp_comm_type), INTENT(IN) :: comm
7156
7157 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_im2'
7158
7159 INTEGER :: handle
7160#if defined(__parallel)
7161 INTEGER :: ierr, sendcount
7162#endif
7163
7164 CALL mp_timeset(routinen, handle)
7165
7166#if defined(__parallel)
7167 sendcount = SIZE(sendbuf)
7168 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7169 recvbuf, recvcounts, displs, mpi_integer, &
7170 root, comm%handle, ierr)
7171 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7172 CALL add_perf(perf_id=4, &
7173 count=1, &
7174 msg_size=sendcount*int_4_size)
7175#else
7176 mark_used(recvcounts)
7177 mark_used(root)
7178 mark_used(comm)
7179 recvbuf(:, 1 + displs(1):) = sendbuf
7180#endif
7181 CALL mp_timestop(handle)
7182 END SUBROUTINE mp_gatherv_im2
7183
7184! **************************************************************************************************
7185!> \brief Gathers data from all processes to one.
7186!> \param[in] sendbuf Data to send to root
7187!> \param[out] recvbuf Received data (on root)
7188!> \param[in] recvcounts Sizes of data received from processes
7189!> \param[in] displs Offsets of data received from processes
7190!> \param[in] comm Message passing environment identifier
7191!> \par Data length
7192!> Data can have different lengths
7193!> \par Offsets
7194!> Offsets start at 0
7195!> \par MPI mapping
7196!> mpi_gather
7197! **************************************************************************************************
7198 SUBROUTINE mp_gatherv_im2_src(sendbuf, recvbuf, recvcounts, displs, comm)
7199
7200 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
7201 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
7202 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7203 CLASS(mp_comm_type), INTENT(IN) :: comm
7204
7205 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_im2_src'
7206
7207 INTEGER :: handle
7208#if defined(__parallel)
7209 INTEGER :: ierr, sendcount
7210#endif
7211
7212 CALL mp_timeset(routinen, handle)
7213
7214#if defined(__parallel)
7215 sendcount = SIZE(sendbuf)
7216 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7217 recvbuf, recvcounts, displs, mpi_integer, &
7218 comm%source, comm%handle, ierr)
7219 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7220 CALL add_perf(perf_id=4, &
7221 count=1, &
7222 msg_size=sendcount*int_4_size)
7223#else
7224 mark_used(recvcounts)
7225 mark_used(comm)
7226 recvbuf(:, 1 + displs(1):) = sendbuf
7227#endif
7228 CALL mp_timestop(handle)
7229 END SUBROUTINE mp_gatherv_im2_src
7230
7231! **************************************************************************************************
7232!> \brief Gathers data from all processes to one.
7233!> \param[in] sendbuf Data to send to root
7234!> \param[out] recvbuf Received data (on root)
7235!> \param[in] recvcounts Sizes of data received from processes
7236!> \param[in] displs Offsets of data received from processes
7237!> \param[in] root Process which gathers the data
7238!> \param[in] comm Message passing environment identifier
7239!> \par Data length
7240!> Data can have different lengths
7241!> \par Offsets
7242!> Offsets start at 0
7243!> \par MPI mapping
7244!> mpi_gather
7245! **************************************************************************************************
7246 SUBROUTINE mp_igatherv_iv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
7247 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: sendbuf
7248 INTEGER(KIND=int_4), DIMENSION(:), INTENT(OUT) :: recvbuf
7249 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7250 INTEGER, INTENT(IN) :: sendcount, root
7251 CLASS(mp_comm_type), INTENT(IN) :: comm
7252 TYPE(mp_request_type), INTENT(OUT) :: request
7253
7254 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_iv'
7255
7256 INTEGER :: handle
7257#if defined(__parallel)
7258 INTEGER :: ierr
7259#endif
7260
7261 CALL mp_timeset(routinen, handle)
7262
7263#if defined(__parallel)
7264#if !defined(__GNUC__) || __GNUC__ >= 9
7265 cpassert(is_contiguous(sendbuf))
7266 cpassert(is_contiguous(recvbuf))
7267 cpassert(is_contiguous(recvcounts))
7268 cpassert(is_contiguous(displs))
7269#endif
7270 CALL mpi_igatherv(sendbuf, sendcount, mpi_integer, &
7271 recvbuf, recvcounts, displs, mpi_integer, &
7272 root, comm%handle, request%handle, ierr)
7273 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7274 CALL add_perf(perf_id=24, &
7275 count=1, &
7276 msg_size=sendcount*int_4_size)
7277#else
7278 mark_used(sendcount)
7279 mark_used(recvcounts)
7280 mark_used(root)
7281 mark_used(comm)
7282 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
7283 request = mp_request_null
7284#endif
7285 CALL mp_timestop(handle)
7286 END SUBROUTINE mp_igatherv_iv
7287
7288! **************************************************************************************************
7289!> \brief Gathers a datum from all processes and all processes receive the
7290!> same data
7291!> \param[in] msgout Datum to send
7292!> \param[out] msgin Received data
7293!> \param[in] comm Message passing environment identifier
7294!> \par Data size
7295!> All processes send equal-sized data
7296!> \par MPI mapping
7297!> mpi_allgather
7298! **************************************************************************************************
7299 SUBROUTINE mp_allgather_i (msgout, msgin, comm)
7300 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7301 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
7302 CLASS(mp_comm_type), INTENT(IN) :: comm
7303
7304 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i'
7305
7306 INTEGER :: handle
7307#if defined(__parallel)
7308 INTEGER :: ierr, rcount, scount
7309#endif
7310
7311 CALL mp_timeset(routinen, handle)
7312
7313#if defined(__parallel)
7314 scount = 1
7315 rcount = 1
7316 CALL mpi_allgather(msgout, scount, mpi_integer, &
7317 msgin, rcount, mpi_integer, &
7318 comm%handle, ierr)
7319 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7320#else
7321 mark_used(comm)
7322 msgin = msgout
7323#endif
7324 CALL mp_timestop(handle)
7325 END SUBROUTINE mp_allgather_i
7326
7327! **************************************************************************************************
7328!> \brief Gathers a datum from all processes and all processes receive the
7329!> same data
7330!> \param[in] msgout Datum to send
7331!> \param[out] msgin Received data
7332!> \param[in] comm Message passing environment identifier
7333!> \par Data size
7334!> All processes send equal-sized data
7335!> \par MPI mapping
7336!> mpi_allgather
7337! **************************************************************************************************
7338 SUBROUTINE mp_allgather_i2(msgout, msgin, comm)
7339 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7340 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7341 CLASS(mp_comm_type), INTENT(IN) :: comm
7342
7343 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i2'
7344
7345 INTEGER :: handle
7346#if defined(__parallel)
7347 INTEGER :: ierr, rcount, scount
7348#endif
7349
7350 CALL mp_timeset(routinen, handle)
7351
7352#if defined(__parallel)
7353 scount = 1
7354 rcount = 1
7355 CALL mpi_allgather(msgout, scount, mpi_integer, &
7356 msgin, rcount, mpi_integer, &
7357 comm%handle, ierr)
7358 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7359#else
7360 mark_used(comm)
7361 msgin = msgout
7362#endif
7363 CALL mp_timestop(handle)
7364 END SUBROUTINE mp_allgather_i2
7365
7366! **************************************************************************************************
7367!> \brief Gathers a datum from all processes and all processes receive the
7368!> same data
7369!> \param[in] msgout Datum to send
7370!> \param[out] msgin Received data
7371!> \param[in] comm Message passing environment identifier
7372!> \par Data size
7373!> All processes send equal-sized data
7374!> \par MPI mapping
7375!> mpi_allgather
7376! **************************************************************************************************
7377 SUBROUTINE mp_iallgather_i (msgout, msgin, comm, request)
7378 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7379 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7380 CLASS(mp_comm_type), INTENT(IN) :: comm
7381 TYPE(mp_request_type), INTENT(OUT) :: request
7382
7383 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i'
7384
7385 INTEGER :: handle
7386#if defined(__parallel)
7387 INTEGER :: ierr, rcount, scount
7388#endif
7389
7390 CALL mp_timeset(routinen, handle)
7391
7392#if defined(__parallel)
7393#if !defined(__GNUC__) || __GNUC__ >= 9
7394 cpassert(is_contiguous(msgin))
7395#endif
7396 scount = 1
7397 rcount = 1
7398 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7399 msgin, rcount, mpi_integer, &
7400 comm%handle, request%handle, ierr)
7401 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7402#else
7403 mark_used(comm)
7404 msgin = msgout
7405 request = mp_request_null
7406#endif
7407 CALL mp_timestop(handle)
7408 END SUBROUTINE mp_iallgather_i
7409
7410! **************************************************************************************************
7411!> \brief Gathers vector data from all processes and all processes receive the
7412!> same data
7413!> \param[in] msgout Rank-1 data to send
7414!> \param[out] msgin Received data
7415!> \param[in] comm Message passing environment identifier
7416!> \par Data size
7417!> All processes send equal-sized data
7418!> \par Ranks
7419!> The last rank counts the processes
7420!> \par MPI mapping
7421!> mpi_allgather
7422! **************************************************************************************************
7423 SUBROUTINE mp_allgather_i12(msgout, msgin, comm)
7424 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:)
7425 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7426 CLASS(mp_comm_type), INTENT(IN) :: comm
7427
7428 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i12'
7429
7430 INTEGER :: handle
7431#if defined(__parallel)
7432 INTEGER :: ierr, rcount, scount
7433#endif
7434
7435 CALL mp_timeset(routinen, handle)
7436
7437#if defined(__parallel)
7438 scount = SIZE(msgout(:))
7439 rcount = scount
7440 CALL mpi_allgather(msgout, scount, mpi_integer, &
7441 msgin, rcount, mpi_integer, &
7442 comm%handle, ierr)
7443 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7444#else
7445 mark_used(comm)
7446 msgin(:, 1) = msgout(:)
7447#endif
7448 CALL mp_timestop(handle)
7449 END SUBROUTINE mp_allgather_i12
7450
7451! **************************************************************************************************
7452!> \brief Gathers matrix data from all processes and all processes receive the
7453!> same data
7454!> \param[in] msgout Rank-2 data to send
7455!> \param msgin ...
7456!> \param comm ...
7457!> \note see mp_allgather_i12
7458! **************************************************************************************************
7459 SUBROUTINE mp_allgather_i23(msgout, msgin, comm)
7460 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
7461 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
7462 CLASS(mp_comm_type), INTENT(IN) :: comm
7463
7464 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i23'
7465
7466 INTEGER :: handle
7467#if defined(__parallel)
7468 INTEGER :: ierr, rcount, scount
7469#endif
7470
7471 CALL mp_timeset(routinen, handle)
7472
7473#if defined(__parallel)
7474 scount = SIZE(msgout(:, :))
7475 rcount = scount
7476 CALL mpi_allgather(msgout, scount, mpi_integer, &
7477 msgin, rcount, mpi_integer, &
7478 comm%handle, ierr)
7479 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7480#else
7481 mark_used(comm)
7482 msgin(:, :, 1) = msgout(:, :)
7483#endif
7484 CALL mp_timestop(handle)
7485 END SUBROUTINE mp_allgather_i23
7486
7487! **************************************************************************************************
7488!> \brief Gathers rank-3 data from all processes and all processes receive the
7489!> same data
7490!> \param[in] msgout Rank-3 data to send
7491!> \param msgin ...
7492!> \param comm ...
7493!> \note see mp_allgather_i12
7494! **************************************************************************************************
7495 SUBROUTINE mp_allgather_i34(msgout, msgin, comm)
7496 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
7497 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
7498 CLASS(mp_comm_type), INTENT(IN) :: comm
7499
7500 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i34'
7501
7502 INTEGER :: handle
7503#if defined(__parallel)
7504 INTEGER :: ierr, rcount, scount
7505#endif
7506
7507 CALL mp_timeset(routinen, handle)
7508
7509#if defined(__parallel)
7510 scount = SIZE(msgout(:, :, :))
7511 rcount = scount
7512 CALL mpi_allgather(msgout, scount, mpi_integer, &
7513 msgin, rcount, mpi_integer, &
7514 comm%handle, ierr)
7515 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7516#else
7517 mark_used(comm)
7518 msgin(:, :, :, 1) = msgout(:, :, :)
7519#endif
7520 CALL mp_timestop(handle)
7521 END SUBROUTINE mp_allgather_i34
7522
7523! **************************************************************************************************
7524!> \brief Gathers rank-2 data from all processes and all processes receive the
7525!> same data
7526!> \param[in] msgout Rank-2 data to send
7527!> \param msgin ...
7528!> \param comm ...
7529!> \note see mp_allgather_i12
7530! **************************************************************************************************
7531 SUBROUTINE mp_allgather_i22(msgout, msgin, comm)
7532 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
7533 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7534 CLASS(mp_comm_type), INTENT(IN) :: comm
7535
7536 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i22'
7537
7538 INTEGER :: handle
7539#if defined(__parallel)
7540 INTEGER :: ierr, rcount, scount
7541#endif
7542
7543 CALL mp_timeset(routinen, handle)
7544
7545#if defined(__parallel)
7546 scount = SIZE(msgout(:, :))
7547 rcount = scount
7548 CALL mpi_allgather(msgout, scount, mpi_integer, &
7549 msgin, rcount, mpi_integer, &
7550 comm%handle, ierr)
7551 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7552#else
7553 mark_used(comm)
7554 msgin(:, :) = msgout(:, :)
7555#endif
7556 CALL mp_timestop(handle)
7557 END SUBROUTINE mp_allgather_i22
7558
7559! **************************************************************************************************
7560!> \brief Gathers rank-1 data from all processes and all processes receive the
7561!> same data
7562!> \param[in] msgout Rank-1 data to send
7563!> \param msgin ...
7564!> \param comm ...
7565!> \param request ...
7566!> \note see mp_allgather_i11
7567! **************************************************************************************************
7568 SUBROUTINE mp_iallgather_i11(msgout, msgin, comm, request)
7569 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7570 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7571 CLASS(mp_comm_type), INTENT(IN) :: comm
7572 TYPE(mp_request_type), INTENT(OUT) :: request
7573
7574 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i11'
7575
7576 INTEGER :: handle
7577#if defined(__parallel)
7578 INTEGER :: ierr, rcount, scount
7579#endif
7580
7581 CALL mp_timeset(routinen, handle)
7582
7583#if defined(__parallel)
7584#if !defined(__GNUC__) || __GNUC__ >= 9
7585 cpassert(is_contiguous(msgout))
7586 cpassert(is_contiguous(msgin))
7587#endif
7588 scount = SIZE(msgout(:))
7589 rcount = scount
7590 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7591 msgin, rcount, mpi_integer, &
7592 comm%handle, request%handle, ierr)
7593 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7594#else
7595 mark_used(comm)
7596 msgin = msgout
7597 request = mp_request_null
7598#endif
7599 CALL mp_timestop(handle)
7600 END SUBROUTINE mp_iallgather_i11
7601
7602! **************************************************************************************************
7603!> \brief Gathers rank-2 data from all processes and all processes receive the
7604!> same data
7605!> \param[in] msgout Rank-2 data to send
7606!> \param msgin ...
7607!> \param comm ...
7608!> \param request ...
7609!> \note see mp_allgather_i12
7610! **************************************************************************************************
7611 SUBROUTINE mp_iallgather_i13(msgout, msgin, comm, request)
7612 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7613 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :)
7614 CLASS(mp_comm_type), INTENT(IN) :: comm
7615 TYPE(mp_request_type), INTENT(OUT) :: request
7616
7617 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i13'
7618
7619 INTEGER :: handle
7620#if defined(__parallel)
7621 INTEGER :: ierr, rcount, scount
7622#endif
7623
7624 CALL mp_timeset(routinen, handle)
7625
7626#if defined(__parallel)
7627#if !defined(__GNUC__) || __GNUC__ >= 9
7628 cpassert(is_contiguous(msgout))
7629 cpassert(is_contiguous(msgin))
7630#endif
7631
7632 scount = SIZE(msgout(:))
7633 rcount = scount
7634 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7635 msgin, rcount, mpi_integer, &
7636 comm%handle, request%handle, ierr)
7637 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7638#else
7639 mark_used(comm)
7640 msgin(:, 1, 1) = msgout(:)
7641 request = mp_request_null
7642#endif
7643 CALL mp_timestop(handle)
7644 END SUBROUTINE mp_iallgather_i13
7645
7646! **************************************************************************************************
7647!> \brief Gathers rank-2 data from all processes and all processes receive the
7648!> same data
7649!> \param[in] msgout Rank-2 data to send
7650!> \param msgin ...
7651!> \param comm ...
7652!> \param request ...
7653!> \note see mp_allgather_i12
7654! **************************************************************************************************
7655 SUBROUTINE mp_iallgather_i22(msgout, msgin, comm, request)
7656 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :)
7657 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :)
7658 CLASS(mp_comm_type), INTENT(IN) :: comm
7659 TYPE(mp_request_type), INTENT(OUT) :: request
7660
7661 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i22'
7662
7663 INTEGER :: handle
7664#if defined(__parallel)
7665 INTEGER :: ierr, rcount, scount
7666#endif
7667
7668 CALL mp_timeset(routinen, handle)
7669
7670#if defined(__parallel)
7671#if !defined(__GNUC__) || __GNUC__ >= 9
7672 cpassert(is_contiguous(msgout))
7673 cpassert(is_contiguous(msgin))
7674#endif
7675
7676 scount = SIZE(msgout(:, :))
7677 rcount = scount
7678 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7679 msgin, rcount, mpi_integer, &
7680 comm%handle, request%handle, ierr)
7681 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7682#else
7683 mark_used(comm)
7684 msgin(:, :) = msgout(:, :)
7685 request = mp_request_null
7686#endif
7687 CALL mp_timestop(handle)
7688 END SUBROUTINE mp_iallgather_i22
7689
7690! **************************************************************************************************
7691!> \brief Gathers rank-2 data from all processes and all processes receive the
7692!> same data
7693!> \param[in] msgout Rank-2 data to send
7694!> \param msgin ...
7695!> \param comm ...
7696!> \param request ...
7697!> \note see mp_allgather_i12
7698! **************************************************************************************************
7699 SUBROUTINE mp_iallgather_i24(msgout, msgin, comm, request)
7700 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :)
7701 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :, :)
7702 CLASS(mp_comm_type), INTENT(IN) :: comm
7703 TYPE(mp_request_type), INTENT(OUT) :: request
7704
7705 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i24'
7706
7707 INTEGER :: handle
7708#if defined(__parallel)
7709 INTEGER :: ierr, rcount, scount
7710#endif
7711
7712 CALL mp_timeset(routinen, handle)
7713
7714#if defined(__parallel)
7715#if !defined(__GNUC__) || __GNUC__ >= 9
7716 cpassert(is_contiguous(msgout))
7717 cpassert(is_contiguous(msgin))
7718#endif
7719
7720 scount = SIZE(msgout(:, :))
7721 rcount = scount
7722 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7723 msgin, rcount, mpi_integer, &
7724 comm%handle, request%handle, ierr)
7725 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7726#else
7727 mark_used(comm)
7728 msgin(:, :, 1, 1) = msgout(:, :)
7729 request = mp_request_null
7730#endif
7731 CALL mp_timestop(handle)
7732 END SUBROUTINE mp_iallgather_i24
7733
7734! **************************************************************************************************
7735!> \brief Gathers rank-3 data from all processes and all processes receive the
7736!> same data
7737!> \param[in] msgout Rank-3 data to send
7738!> \param msgin ...
7739!> \param comm ...
7740!> \param request ...
7741!> \note see mp_allgather_i12
7742! **************************************************************************************************
7743 SUBROUTINE mp_iallgather_i33(msgout, msgin, comm, request)
7744 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :, :)
7745 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :)
7746 CLASS(mp_comm_type), INTENT(IN) :: comm
7747 TYPE(mp_request_type), INTENT(OUT) :: request
7748
7749 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i33'
7750
7751 INTEGER :: handle
7752#if defined(__parallel)
7753 INTEGER :: ierr, rcount, scount
7754#endif
7755
7756 CALL mp_timeset(routinen, handle)
7757
7758#if defined(__parallel)
7759#if !defined(__GNUC__) || __GNUC__ >= 9
7760 cpassert(is_contiguous(msgout))
7761 cpassert(is_contiguous(msgin))
7762#endif
7763
7764 scount = SIZE(msgout(:, :, :))
7765 rcount = scount
7766 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7767 msgin, rcount, mpi_integer, &
7768 comm%handle, request%handle, ierr)
7769 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7770#else
7771 mark_used(comm)
7772 msgin(:, :, :) = msgout(:, :, :)
7773 request = mp_request_null
7774#endif
7775 CALL mp_timestop(handle)
7776 END SUBROUTINE mp_iallgather_i33
7777
7778! **************************************************************************************************
7779!> \brief Gathers vector data from all processes and all processes receive the
7780!> same data
7781!> \param[in] msgout Rank-1 data to send
7782!> \param[out] msgin Received data
7783!> \param[in] rcount Size of sent data for every process
7784!> \param[in] rdispl Offset of sent data for every process
7785!> \param[in] comm Message passing environment identifier
7786!> \par Data size
7787!> Processes can send different-sized data
7788!> \par Ranks
7789!> The last rank counts the processes
7790!> \par Offsets
7791!> Offsets are from 0
7792!> \par MPI mapping
7793!> mpi_allgather
7794! **************************************************************************************************
7795 SUBROUTINE mp_allgatherv_iv(msgout, msgin, rcount, rdispl, comm)
7796 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
7797 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
7798 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
7799 CLASS(mp_comm_type), INTENT(IN) :: comm
7800
7801 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_iv'
7802
7803 INTEGER :: handle
7804#if defined(__parallel)
7805 INTEGER :: ierr, scount
7806#endif
7807
7808 CALL mp_timeset(routinen, handle)
7809
7810#if defined(__parallel)
7811 scount = SIZE(msgout)
7812 CALL mpi_allgatherv(msgout, scount, mpi_integer, msgin, rcount, &
7813 rdispl, mpi_integer, comm%handle, ierr)
7814 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
7815#else
7816 mark_used(rcount)
7817 mark_used(rdispl)
7818 mark_used(comm)
7819 msgin = msgout
7820#endif
7821 CALL mp_timestop(handle)
7822 END SUBROUTINE mp_allgatherv_iv
7823
7824! **************************************************************************************************
7825!> \brief Gathers vector data from all processes and all processes receive the
7826!> same data
7827!> \param[in] msgout Rank-1 data to send
7828!> \param[out] msgin Received data
7829!> \param[in] rcount Size of sent data for every process
7830!> \param[in] rdispl Offset of sent data for every process
7831!> \param[in] comm Message passing environment identifier
7832!> \par Data size
7833!> Processes can send different-sized data
7834!> \par Ranks
7835!> The last rank counts the processes
7836!> \par Offsets
7837!> Offsets are from 0
7838!> \par MPI mapping
7839!> mpi_allgather
7840! **************************************************************************************************
7841 SUBROUTINE mp_allgatherv_im2(msgout, msgin, rcount, rdispl, comm)
7842 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
7843 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
7844 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
7845 CLASS(mp_comm_type), INTENT(IN) :: comm
7846
7847 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_iv'
7848
7849 INTEGER :: handle
7850#if defined(__parallel)
7851 INTEGER :: ierr, scount
7852#endif
7853
7854 CALL mp_timeset(routinen, handle)
7855
7856#if defined(__parallel)
7857 scount = SIZE(msgout)
7858 CALL mpi_allgatherv(msgout, scount, mpi_integer, msgin, rcount, &
7859 rdispl, mpi_integer, comm%handle, ierr)
7860 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
7861#else
7862 mark_used(rcount)
7863 mark_used(rdispl)
7864 mark_used(comm)
7865 msgin = msgout
7866#endif
7867 CALL mp_timestop(handle)
7868 END SUBROUTINE mp_allgatherv_im2
7869
7870! **************************************************************************************************
7871!> \brief Gathers vector data from all processes and all processes receive the
7872!> same data
7873!> \param[in] msgout Rank-1 data to send
7874!> \param[out] msgin Received data
7875!> \param[in] rcount Size of sent data for every process
7876!> \param[in] rdispl Offset of sent data for every process
7877!> \param[in] comm Message passing environment identifier
7878!> \par Data size
7879!> Processes can send different-sized data
7880!> \par Ranks
7881!> The last rank counts the processes
7882!> \par Offsets
7883!> Offsets are from 0
7884!> \par MPI mapping
7885!> mpi_allgather
7886! **************************************************************************************************
7887 SUBROUTINE mp_iallgatherv_iv(msgout, msgin, rcount, rdispl, comm, request)
7888 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7889 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7890 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
7891 CLASS(mp_comm_type), INTENT(IN) :: comm
7892 TYPE(mp_request_type), INTENT(OUT) :: request
7893
7894 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_iv'
7895
7896 INTEGER :: handle
7897#if defined(__parallel)
7898 INTEGER :: ierr, scount, rsize
7899#endif
7900
7901 CALL mp_timeset(routinen, handle)
7902
7903#if defined(__parallel)
7904#if !defined(__GNUC__) || __GNUC__ >= 9
7905 cpassert(is_contiguous(msgout))
7906 cpassert(is_contiguous(msgin))
7907 cpassert(is_contiguous(rcount))
7908 cpassert(is_contiguous(rdispl))
7909#endif
7910
7911 scount = SIZE(msgout)
7912 rsize = SIZE(rcount)
7913 CALL mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, &
7914 rdispl, comm, request, ierr)
7915 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
7916#else
7917 mark_used(rcount)
7918 mark_used(rdispl)
7919 mark_used(comm)
7920 msgin = msgout
7921 request = mp_request_null
7922#endif
7923 CALL mp_timestop(handle)
7924 END SUBROUTINE mp_iallgatherv_iv
7925
7926! **************************************************************************************************
7927!> \brief Gathers vector data from all processes and all processes receive the
7928!> same data
7929!> \param[in] msgout Rank-1 data to send
7930!> \param[out] msgin Received data
7931!> \param[in] rcount Size of sent data for every process
7932!> \param[in] rdispl Offset of sent data for every process
7933!> \param[in] comm Message passing environment identifier
7934!> \par Data size
7935!> Processes can send different-sized data
7936!> \par Ranks
7937!> The last rank counts the processes
7938!> \par Offsets
7939!> Offsets are from 0
7940!> \par MPI mapping
7941!> mpi_allgather
7942! **************************************************************************************************
7943 SUBROUTINE mp_iallgatherv_iv2(msgout, msgin, rcount, rdispl, comm, request)
7944 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7945 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7946 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
7947 CLASS(mp_comm_type), INTENT(IN) :: comm
7948 TYPE(mp_request_type), INTENT(OUT) :: request
7949
7950 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_iv2'
7951
7952 INTEGER :: handle
7953#if defined(__parallel)
7954 INTEGER :: ierr, scount, rsize
7955#endif
7956
7957 CALL mp_timeset(routinen, handle)
7958
7959#if defined(__parallel)
7960#if !defined(__GNUC__) || __GNUC__ >= 9
7961 cpassert(is_contiguous(msgout))
7962 cpassert(is_contiguous(msgin))
7963 cpassert(is_contiguous(rcount))
7964 cpassert(is_contiguous(rdispl))
7965#endif
7966
7967 scount = SIZE(msgout)
7968 rsize = SIZE(rcount)
7969 CALL mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, &
7970 rdispl, comm, request, ierr)
7971 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
7972#else
7973 mark_used(rcount)
7974 mark_used(rdispl)
7975 mark_used(comm)
7976 msgin = msgout
7977 request = mp_request_null
7978#endif
7979 CALL mp_timestop(handle)
7980 END SUBROUTINE mp_iallgatherv_iv2
7981
7982! **************************************************************************************************
7983!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
7984!> the issue is with the rank of rcount and rdispl
7985!> \param count ...
7986!> \param array_of_requests ...
7987!> \param array_of_statuses ...
7988!> \param ierr ...
7989!> \author Alfio Lazzaro
7990! **************************************************************************************************
7991#if defined(__parallel)
7992 SUBROUTINE mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
7993 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
7994 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
7995 INTEGER, INTENT(IN) :: rsize
7996 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
7997 CLASS(mp_comm_type), INTENT(IN) :: comm
7998 TYPE(mp_request_type), INTENT(OUT) :: request
7999 INTEGER, INTENT(INOUT) :: ierr
8000
8001 CALL mpi_iallgatherv(msgout, scount, mpi_integer, msgin, rcount, &
8002 rdispl, mpi_integer, comm%handle, request%handle, ierr)
8003
8004 END SUBROUTINE mp_iallgatherv_iv_internal
8005#endif
8006
8007! **************************************************************************************************
8008!> \brief Sums a vector and partitions the result among processes
8009!> \param[in] msgout Data to sum
8010!> \param[out] msgin Received portion of summed data
8011!> \param[in] rcount Partition sizes of the summed data for
8012!> every process
8013!> \param[in] comm Message passing environment identifier
8014! **************************************************************************************************
8015 SUBROUTINE mp_sum_scatter_iv(msgout, msgin, rcount, comm)
8016 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
8017 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
8018 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
8019 CLASS(mp_comm_type), INTENT(IN) :: comm
8020
8021 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_iv'
8022
8023 INTEGER :: handle
8024#if defined(__parallel)
8025 INTEGER :: ierr
8026#endif
8027
8028 CALL mp_timeset(routinen, handle)
8029
8030#if defined(__parallel)
8031 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_integer, mpi_sum, &
8032 comm%handle, ierr)
8033 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
8034
8035 CALL add_perf(perf_id=3, count=1, &
8036 msg_size=rcount(1)*2*int_4_size)
8037#else
8038 mark_used(rcount)
8039 mark_used(comm)
8040 msgin = msgout(:, 1)
8041#endif
8042 CALL mp_timestop(handle)
8043 END SUBROUTINE mp_sum_scatter_iv
8044
8045! **************************************************************************************************
8046!> \brief Sends and receives vector data
8047!> \param[in] msgin Data to send
8048!> \param[in] dest Process to send data to
8049!> \param[out] msgout Received data
8050!> \param[in] source Process from which to receive
8051!> \param[in] comm Message passing environment identifier
8052!> \param[in] tag Send and recv tag (default: 0)
8053! **************************************************************************************************
8054 SUBROUTINE mp_sendrecv_i (msgin, dest, msgout, source, comm, tag)
8055 INTEGER(KIND=int_4), INTENT(IN) :: msgin
8056 INTEGER, INTENT(IN) :: dest
8057 INTEGER(KIND=int_4), INTENT(OUT) :: msgout
8058 INTEGER, INTENT(IN) :: source
8059 CLASS(mp_comm_type), INTENT(IN) :: comm
8060 INTEGER, INTENT(IN), OPTIONAL :: tag
8061
8062 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_i'
8063
8064 INTEGER :: handle
8065#if defined(__parallel)
8066 INTEGER :: ierr, msglen_in, msglen_out, &
8067 recv_tag, send_tag
8068#endif
8069
8070 CALL mp_timeset(routinen, handle)
8071
8072#if defined(__parallel)
8073 msglen_in = 1
8074 msglen_out = 1
8075 send_tag = 0 ! cannot think of something better here, this might be dangerous
8076 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8077 IF (PRESENT(tag)) THEN
8078 send_tag = tag
8079 recv_tag = tag
8080 END IF
8081 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8082 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8083 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8084 CALL add_perf(perf_id=7, count=1, &
8085 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8086#else
8087 mark_used(dest)
8088 mark_used(source)
8089 mark_used(comm)
8090 mark_used(tag)
8091 msgout = msgin
8092#endif
8093 CALL mp_timestop(handle)
8094 END SUBROUTINE mp_sendrecv_i
8095
8096! **************************************************************************************************
8097!> \brief Sends and receives vector data
8098!> \param[in] msgin Data to send
8099!> \param[in] dest Process to send data to
8100!> \param[out] msgout Received data
8101!> \param[in] source Process from which to receive
8102!> \param[in] comm Message passing environment identifier
8103!> \param[in] tag Send and recv tag (default: 0)
8104! **************************************************************************************************
8105 SUBROUTINE mp_sendrecv_iv(msgin, dest, msgout, source, comm, tag)
8106 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
8107 INTEGER, INTENT(IN) :: dest
8108 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
8109 INTEGER, INTENT(IN) :: source
8110 CLASS(mp_comm_type), INTENT(IN) :: comm
8111 INTEGER, INTENT(IN), OPTIONAL :: tag
8112
8113 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_iv'
8114
8115 INTEGER :: handle
8116#if defined(__parallel)
8117 INTEGER :: ierr, msglen_in, msglen_out, &
8118 recv_tag, send_tag
8119#endif
8120
8121 CALL mp_timeset(routinen, handle)
8122
8123#if defined(__parallel)
8124 msglen_in = SIZE(msgin)
8125 msglen_out = SIZE(msgout)
8126 send_tag = 0 ! cannot think of something better here, this might be dangerous
8127 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8128 IF (PRESENT(tag)) THEN
8129 send_tag = tag
8130 recv_tag = tag
8131 END IF
8132 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8133 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8134 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8135 CALL add_perf(perf_id=7, count=1, &
8136 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8137#else
8138 mark_used(dest)
8139 mark_used(source)
8140 mark_used(comm)
8141 mark_used(tag)
8142 msgout = msgin
8143#endif
8144 CALL mp_timestop(handle)
8145 END SUBROUTINE mp_sendrecv_iv
8146
8147! **************************************************************************************************
8148!> \brief Sends and receives matrix data
8149!> \param msgin ...
8150!> \param dest ...
8151!> \param msgout ...
8152!> \param source ...
8153!> \param comm ...
8154!> \param tag ...
8155!> \note see mp_sendrecv_iv
8156! **************************************************************************************************
8157 SUBROUTINE mp_sendrecv_im2(msgin, dest, msgout, source, comm, tag)
8158 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
8159 INTEGER, INTENT(IN) :: dest
8160 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
8161 INTEGER, INTENT(IN) :: source
8162 CLASS(mp_comm_type), INTENT(IN) :: comm
8163 INTEGER, INTENT(IN), OPTIONAL :: tag
8164
8165 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im2'
8166
8167 INTEGER :: handle
8168#if defined(__parallel)
8169 INTEGER :: ierr, msglen_in, msglen_out, &
8170 recv_tag, send_tag
8171#endif
8172
8173 CALL mp_timeset(routinen, handle)
8174
8175#if defined(__parallel)
8176 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
8177 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
8178 send_tag = 0 ! cannot think of something better here, this might be dangerous
8179 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8180 IF (PRESENT(tag)) THEN
8181 send_tag = tag
8182 recv_tag = tag
8183 END IF
8184 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8185 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8186 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8187 CALL add_perf(perf_id=7, count=1, &
8188 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8189#else
8190 mark_used(dest)
8191 mark_used(source)
8192 mark_used(comm)
8193 mark_used(tag)
8194 msgout = msgin
8195#endif
8196 CALL mp_timestop(handle)
8197 END SUBROUTINE mp_sendrecv_im2
8198
8199! **************************************************************************************************
8200!> \brief Sends and receives rank-3 data
8201!> \param msgin ...
8202!> \param dest ...
8203!> \param msgout ...
8204!> \param source ...
8205!> \param comm ...
8206!> \note see mp_sendrecv_iv
8207! **************************************************************************************************
8208 SUBROUTINE mp_sendrecv_im3(msgin, dest, msgout, source, comm, tag)
8209 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
8210 INTEGER, INTENT(IN) :: dest
8211 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
8212 INTEGER, INTENT(IN) :: source
8213 CLASS(mp_comm_type), INTENT(IN) :: comm
8214 INTEGER, INTENT(IN), OPTIONAL :: tag
8215
8216 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im3'
8217
8218 INTEGER :: handle
8219#if defined(__parallel)
8220 INTEGER :: ierr, msglen_in, msglen_out, &
8221 recv_tag, send_tag
8222#endif
8223
8224 CALL mp_timeset(routinen, handle)
8225
8226#if defined(__parallel)
8227 msglen_in = SIZE(msgin)
8228 msglen_out = SIZE(msgout)
8229 send_tag = 0 ! cannot think of something better here, this might be dangerous
8230 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8231 IF (PRESENT(tag)) THEN
8232 send_tag = tag
8233 recv_tag = tag
8234 END IF
8235 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8236 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8237 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8238 CALL add_perf(perf_id=7, count=1, &
8239 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8240#else
8241 mark_used(dest)
8242 mark_used(source)
8243 mark_used(comm)
8244 mark_used(tag)
8245 msgout = msgin
8246#endif
8247 CALL mp_timestop(handle)
8248 END SUBROUTINE mp_sendrecv_im3
8249
8250! **************************************************************************************************
8251!> \brief Sends and receives rank-4 data
8252!> \param msgin ...
8253!> \param dest ...
8254!> \param msgout ...
8255!> \param source ...
8256!> \param comm ...
8257!> \note see mp_sendrecv_iv
8258! **************************************************************************************************
8259 SUBROUTINE mp_sendrecv_im4(msgin, dest, msgout, source, comm, tag)
8260 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
8261 INTEGER, INTENT(IN) :: dest
8262 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
8263 INTEGER, INTENT(IN) :: source
8264 CLASS(mp_comm_type), INTENT(IN) :: comm
8265 INTEGER, INTENT(IN), OPTIONAL :: tag
8266
8267 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im4'
8268
8269 INTEGER :: handle
8270#if defined(__parallel)
8271 INTEGER :: ierr, msglen_in, msglen_out, &
8272 recv_tag, send_tag
8273#endif
8274
8275 CALL mp_timeset(routinen, handle)
8276
8277#if defined(__parallel)
8278 msglen_in = SIZE(msgin)
8279 msglen_out = SIZE(msgout)
8280 send_tag = 0 ! cannot think of something better here, this might be dangerous
8281 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8282 IF (PRESENT(tag)) THEN
8283 send_tag = tag
8284 recv_tag = tag
8285 END IF
8286 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8287 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8288 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8289 CALL add_perf(perf_id=7, count=1, &
8290 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8291#else
8292 mark_used(dest)
8293 mark_used(source)
8294 mark_used(comm)
8295 mark_used(tag)
8296 msgout = msgin
8297#endif
8298 CALL mp_timestop(handle)
8299 END SUBROUTINE mp_sendrecv_im4
8300
8301! **************************************************************************************************
8302!> \brief Non-blocking send and receive of a scalar
8303!> \param[in] msgin Scalar data to send
8304!> \param[in] dest Which process to send to
8305!> \param[out] msgout Receive data into this pointer
8306!> \param[in] source Process to receive from
8307!> \param[in] comm Message passing environment identifier
8308!> \param[out] send_request Request handle for the send
8309!> \param[out] recv_request Request handle for the receive
8310!> \param[in] tag (optional) tag to differentiate requests
8311!> \par Implementation
8312!> Calls mpi_isend and mpi_irecv.
8313!> \par History
8314!> 02.2005 created [Alfio Lazzaro]
8315! **************************************************************************************************
8316 SUBROUTINE mp_isendrecv_i (msgin, dest, msgout, source, comm, send_request, &
8317 recv_request, tag)
8318 INTEGER(KIND=int_4), INTENT(IN) :: msgin
8319 INTEGER, INTENT(IN) :: dest
8320 INTEGER(KIND=int_4), INTENT(INOUT) :: msgout
8321 INTEGER, INTENT(IN) :: source
8322 CLASS(mp_comm_type), INTENT(IN) :: comm
8323 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
8324 INTEGER, INTENT(in), OPTIONAL :: tag
8325
8326 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_i'
8327
8328 INTEGER :: handle
8329#if defined(__parallel)
8330 INTEGER :: ierr, my_tag
8331#endif
8332
8333 CALL mp_timeset(routinen, handle)
8334
8335#if defined(__parallel)
8336 my_tag = 0
8337 IF (PRESENT(tag)) my_tag = tag
8338
8339 CALL mpi_irecv(msgout, 1, mpi_integer, source, my_tag, &
8340 comm%handle, recv_request%handle, ierr)
8341 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8342
8343 CALL mpi_isend(msgin, 1, mpi_integer, dest, my_tag, &
8344 comm%handle, send_request%handle, ierr)
8345 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8346
8347 CALL add_perf(perf_id=8, count=1, msg_size=2*int_4_size)
8348#else
8349 mark_used(dest)
8350 mark_used(source)
8351 mark_used(comm)
8352 mark_used(tag)
8353 send_request = mp_request_null
8354 recv_request = mp_request_null
8355 msgout = msgin
8356#endif
8357 CALL mp_timestop(handle)
8358 END SUBROUTINE mp_isendrecv_i
8359
8360! **************************************************************************************************
8361!> \brief Non-blocking send and receive of a vector
8362!> \param[in] msgin Vector data to send
8363!> \param[in] dest Which process to send to
8364!> \param[out] msgout Receive data into this pointer
8365!> \param[in] source Process to receive from
8366!> \param[in] comm Message passing environment identifier
8367!> \param[out] send_request Request handle for the send
8368!> \param[out] recv_request Request handle for the receive
8369!> \param[in] tag (optional) tag to differentiate requests
8370!> \par Implementation
8371!> Calls mpi_isend and mpi_irecv.
8372!> \par History
8373!> 11.2004 created [Joost VandeVondele]
8374!> \note
8375!> arrays can be pointers or assumed shape, but they must be contiguous!
8376! **************************************************************************************************
8377 SUBROUTINE mp_isendrecv_iv(msgin, dest, msgout, source, comm, send_request, &
8378 recv_request, tag)
8379 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: msgin
8380 INTEGER, INTENT(IN) :: dest
8381 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT) :: msgout
8382 INTEGER, INTENT(IN) :: source
8383 CLASS(mp_comm_type), INTENT(IN) :: comm
8384 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
8385 INTEGER, INTENT(in), OPTIONAL :: tag
8386
8387 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_iv'
8388
8389 INTEGER :: handle
8390#if defined(__parallel)
8391 INTEGER :: ierr, msglen, my_tag
8392 INTEGER(KIND=int_4) :: foo
8393#endif
8394
8395 CALL mp_timeset(routinen, handle)
8396
8397#if defined(__parallel)
8398#if !defined(__GNUC__) || __GNUC__ >= 9
8399 cpassert(is_contiguous(msgout))
8400 cpassert(is_contiguous(msgin))
8401#endif
8402
8403 my_tag = 0
8404 IF (PRESENT(tag)) my_tag = tag
8405
8406 msglen = SIZE(msgout, 1)
8407 IF (msglen > 0) THEN
8408 CALL mpi_irecv(msgout(1), msglen, mpi_integer, source, my_tag, &
8409 comm%handle, recv_request%handle, ierr)
8410 ELSE
8411 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8412 comm%handle, recv_request%handle, ierr)
8413 END IF
8414 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8415
8416 msglen = SIZE(msgin, 1)
8417 IF (msglen > 0) THEN
8418 CALL mpi_isend(msgin(1), msglen, mpi_integer, dest, my_tag, &
8419 comm%handle, send_request%handle, ierr)
8420 ELSE
8421 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8422 comm%handle, send_request%handle, ierr)
8423 END IF
8424 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8425
8426 msglen = (msglen + SIZE(msgout, 1) + 1)/2
8427 CALL add_perf(perf_id=8, count=1, msg_size=msglen*int_4_size)
8428#else
8429 mark_used(dest)
8430 mark_used(source)
8431 mark_used(comm)
8432 mark_used(tag)
8433 send_request = mp_request_null
8434 recv_request = mp_request_null
8435 msgout = msgin
8436#endif
8437 CALL mp_timestop(handle)
8438 END SUBROUTINE mp_isendrecv_iv
8439
8440! **************************************************************************************************
8441!> \brief Non-blocking send of vector data
8442!> \param msgin ...
8443!> \param dest ...
8444!> \param comm ...
8445!> \param request ...
8446!> \param tag ...
8447!> \par History
8448!> 08.2003 created [f&j]
8449!> \note see mp_isendrecv_iv
8450!> \note
8451!> arrays can be pointers or assumed shape, but they must be contiguous!
8452! **************************************************************************************************
8453 SUBROUTINE mp_isend_iv(msgin, dest, comm, request, tag)
8454 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: msgin
8455 INTEGER, INTENT(IN) :: dest
8456 CLASS(mp_comm_type), INTENT(IN) :: comm
8457 TYPE(mp_request_type), INTENT(out) :: request
8458 INTEGER, INTENT(in), OPTIONAL :: tag
8459
8460 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_iv'
8461
8462 INTEGER :: handle, ierr
8463#if defined(__parallel)
8464 INTEGER :: msglen, my_tag
8465 INTEGER(KIND=int_4) :: foo(1)
8466#endif
8467
8468 CALL mp_timeset(routinen, handle)
8469
8470#if defined(__parallel)
8471#if !defined(__GNUC__) || __GNUC__ >= 9
8472 cpassert(is_contiguous(msgin))
8473#endif
8474 my_tag = 0
8475 IF (PRESENT(tag)) my_tag = tag
8476
8477 msglen = SIZE(msgin)
8478 IF (msglen > 0) THEN
8479 CALL mpi_isend(msgin(1), msglen, mpi_integer, dest, my_tag, &
8480 comm%handle, request%handle, ierr)
8481 ELSE
8482 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8483 comm%handle, request%handle, ierr)
8484 END IF
8485 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8486
8487 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8488#else
8489 mark_used(msgin)
8490 mark_used(dest)
8491 mark_used(comm)
8492 mark_used(request)
8493 mark_used(tag)
8494 ierr = 1
8495 request = mp_request_null
8496 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8497#endif
8498 CALL mp_timestop(handle)
8499 END SUBROUTINE mp_isend_iv
8500
8501! **************************************************************************************************
8502!> \brief Non-blocking send of matrix data
8503!> \param msgin ...
8504!> \param dest ...
8505!> \param comm ...
8506!> \param request ...
8507!> \param tag ...
8508!> \par History
8509!> 2009-11-25 [UB] Made type-generic for templates
8510!> \author fawzi
8511!> \note see mp_isendrecv_iv
8512!> \note see mp_isend_iv
8513!> \note
8514!> arrays can be pointers or assumed shape, but they must be contiguous!
8515! **************************************************************************************************
8516 SUBROUTINE mp_isend_im2(msgin, dest, comm, request, tag)
8517 INTEGER(KIND=int_4), DIMENSION(:, :), INTENT(IN) :: msgin
8518 INTEGER, INTENT(IN) :: dest
8519 CLASS(mp_comm_type), INTENT(IN) :: comm
8520 TYPE(mp_request_type), INTENT(out) :: request
8521 INTEGER, INTENT(in), OPTIONAL :: tag
8522
8523 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im2'
8524
8525 INTEGER :: handle, ierr
8526#if defined(__parallel)
8527 INTEGER :: msglen, my_tag
8528 INTEGER(KIND=int_4) :: foo(1)
8529#endif
8530
8531 CALL mp_timeset(routinen, handle)
8532
8533#if defined(__parallel)
8534#if !defined(__GNUC__) || __GNUC__ >= 9
8535 cpassert(is_contiguous(msgin))
8536#endif
8537
8538 my_tag = 0
8539 IF (PRESENT(tag)) my_tag = tag
8540
8541 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
8542 IF (msglen > 0) THEN
8543 CALL mpi_isend(msgin(1, 1), msglen, mpi_integer, dest, my_tag, &
8544 comm%handle, request%handle, ierr)
8545 ELSE
8546 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8547 comm%handle, request%handle, ierr)
8548 END IF
8549 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8550
8551 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8552#else
8553 mark_used(msgin)
8554 mark_used(dest)
8555 mark_used(comm)
8556 mark_used(request)
8557 mark_used(tag)
8558 ierr = 1
8559 request = mp_request_null
8560 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8561#endif
8562 CALL mp_timestop(handle)
8563 END SUBROUTINE mp_isend_im2
8564
8565! **************************************************************************************************
8566!> \brief Non-blocking send of rank-3 data
8567!> \param msgin ...
8568!> \param dest ...
8569!> \param comm ...
8570!> \param request ...
8571!> \param tag ...
8572!> \par History
8573!> 9.2008 added _rm3 subroutine [Iain Bethune]
8574!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
8575!> 2009-11-25 [UB] Made type-generic for templates
8576!> \author fawzi
8577!> \note see mp_isendrecv_iv
8578!> \note see mp_isend_iv
8579!> \note
8580!> arrays can be pointers or assumed shape, but they must be contiguous!
8581! **************************************************************************************************
8582 SUBROUTINE mp_isend_im3(msgin, dest, comm, request, tag)
8583 INTEGER(KIND=int_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
8584 INTEGER, INTENT(IN) :: dest
8585 CLASS(mp_comm_type), INTENT(IN) :: comm
8586 TYPE(mp_request_type), INTENT(out) :: request
8587 INTEGER, INTENT(in), OPTIONAL :: tag
8588
8589 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im3'
8590
8591 INTEGER :: handle, ierr
8592#if defined(__parallel)
8593 INTEGER :: msglen, my_tag
8594 INTEGER(KIND=int_4) :: foo(1)
8595#endif
8596
8597 CALL mp_timeset(routinen, handle)
8598
8599#if defined(__parallel)
8600#if !defined(__GNUC__) || __GNUC__ >= 9
8601 cpassert(is_contiguous(msgin))
8602#endif
8603
8604 my_tag = 0
8605 IF (PRESENT(tag)) my_tag = tag
8606
8607 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
8608 IF (msglen > 0) THEN
8609 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_integer, dest, my_tag, &
8610 comm%handle, request%handle, ierr)
8611 ELSE
8612 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8613 comm%handle, request%handle, ierr)
8614 END IF
8615 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8616
8617 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8618#else
8619 mark_used(msgin)
8620 mark_used(dest)
8621 mark_used(comm)
8622 mark_used(request)
8623 mark_used(tag)
8624 ierr = 1
8625 request = mp_request_null
8626 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8627#endif
8628 CALL mp_timestop(handle)
8629 END SUBROUTINE mp_isend_im3
8630
8631! **************************************************************************************************
8632!> \brief Non-blocking send of rank-4 data
8633!> \param msgin the input message
8634!> \param dest the destination processor
8635!> \param comm the communicator object
8636!> \param request the communication request id
8637!> \param tag the message tag
8638!> \par History
8639!> 2.2016 added _im4 subroutine [Nico Holmberg]
8640!> \author fawzi
8641!> \note see mp_isend_iv
8642!> \note
8643!> arrays can be pointers or assumed shape, but they must be contiguous!
8644! **************************************************************************************************
8645 SUBROUTINE mp_isend_im4(msgin, dest, comm, request, tag)
8646 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
8647 INTEGER, INTENT(IN) :: dest
8648 CLASS(mp_comm_type), INTENT(IN) :: comm
8649 TYPE(mp_request_type), INTENT(out) :: request
8650 INTEGER, INTENT(in), OPTIONAL :: tag
8651
8652 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im4'
8653
8654 INTEGER :: handle, ierr
8655#if defined(__parallel)
8656 INTEGER :: msglen, my_tag
8657 INTEGER(KIND=int_4) :: foo(1)
8658#endif
8659
8660 CALL mp_timeset(routinen, handle)
8661
8662#if defined(__parallel)
8663#if !defined(__GNUC__) || __GNUC__ >= 9
8664 cpassert(is_contiguous(msgin))
8665#endif
8666
8667 my_tag = 0
8668 IF (PRESENT(tag)) my_tag = tag
8669
8670 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
8671 IF (msglen > 0) THEN
8672 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_integer, dest, my_tag, &
8673 comm%handle, request%handle, ierr)
8674 ELSE
8675 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8676 comm%handle, request%handle, ierr)
8677 END IF
8678 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8679
8680 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8681#else
8682 mark_used(msgin)
8683 mark_used(dest)
8684 mark_used(comm)
8685 mark_used(request)
8686 mark_used(tag)
8687 ierr = 1
8688 request = mp_request_null
8689 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8690#endif
8691 CALL mp_timestop(handle)
8692 END SUBROUTINE mp_isend_im4
8693
8694! **************************************************************************************************
8695!> \brief Non-blocking receive of vector data
8696!> \param msgout ...
8697!> \param source ...
8698!> \param comm ...
8699!> \param request ...
8700!> \param tag ...
8701!> \par History
8702!> 08.2003 created [f&j]
8703!> 2009-11-25 [UB] Made type-generic for templates
8704!> \note see mp_isendrecv_iv
8705!> \note
8706!> arrays can be pointers or assumed shape, but they must be contiguous!
8707! **************************************************************************************************
8708 SUBROUTINE mp_irecv_iv(msgout, source, comm, request, tag)
8709 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT) :: msgout
8710 INTEGER, INTENT(IN) :: source
8711 CLASS(mp_comm_type), INTENT(IN) :: comm
8712 TYPE(mp_request_type), INTENT(out) :: request
8713 INTEGER, INTENT(in), OPTIONAL :: tag
8714
8715 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_iv'
8716
8717 INTEGER :: handle
8718#if defined(__parallel)
8719 INTEGER :: ierr, msglen, my_tag
8720 INTEGER(KIND=int_4) :: foo(1)
8721#endif
8722
8723 CALL mp_timeset(routinen, handle)
8724
8725#if defined(__parallel)
8726#if !defined(__GNUC__) || __GNUC__ >= 9
8727 cpassert(is_contiguous(msgout))
8728#endif
8729
8730 my_tag = 0
8731 IF (PRESENT(tag)) my_tag = tag
8732
8733 msglen = SIZE(msgout)
8734 IF (msglen > 0) THEN
8735 CALL mpi_irecv(msgout(1), msglen, mpi_integer, source, my_tag, &
8736 comm%handle, request%handle, ierr)
8737 ELSE
8738 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8739 comm%handle, request%handle, ierr)
8740 END IF
8741 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8742
8743 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8744#else
8745 cpabort("mp_irecv called in non parallel case")
8746 mark_used(msgout)
8747 mark_used(source)
8748 mark_used(comm)
8749 mark_used(tag)
8750 request = mp_request_null
8751#endif
8752 CALL mp_timestop(handle)
8753 END SUBROUTINE mp_irecv_iv
8754
8755! **************************************************************************************************
8756!> \brief Non-blocking receive of matrix data
8757!> \param msgout ...
8758!> \param source ...
8759!> \param comm ...
8760!> \param request ...
8761!> \param tag ...
8762!> \par History
8763!> 2009-11-25 [UB] Made type-generic for templates
8764!> \author fawzi
8765!> \note see mp_isendrecv_iv
8766!> \note see mp_irecv_iv
8767!> \note
8768!> arrays can be pointers or assumed shape, but they must be contiguous!
8769! **************************************************************************************************
8770 SUBROUTINE mp_irecv_im2(msgout, source, comm, request, tag)
8771 INTEGER(KIND=int_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
8772 INTEGER, INTENT(IN) :: source
8773 CLASS(mp_comm_type), INTENT(IN) :: comm
8774 TYPE(mp_request_type), INTENT(out) :: request
8775 INTEGER, INTENT(in), OPTIONAL :: tag
8776
8777 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im2'
8778
8779 INTEGER :: handle
8780#if defined(__parallel)
8781 INTEGER :: ierr, msglen, my_tag
8782 INTEGER(KIND=int_4) :: foo(1)
8783#endif
8784
8785 CALL mp_timeset(routinen, handle)
8786
8787#if defined(__parallel)
8788#if !defined(__GNUC__) || __GNUC__ >= 9
8789 cpassert(is_contiguous(msgout))
8790#endif
8791
8792 my_tag = 0
8793 IF (PRESENT(tag)) my_tag = tag
8794
8795 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
8796 IF (msglen > 0) THEN
8797 CALL mpi_irecv(msgout(1, 1), msglen, mpi_integer, source, my_tag, &
8798 comm%handle, request%handle, ierr)
8799 ELSE
8800 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8801 comm%handle, request%handle, ierr)
8802 END IF
8803 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8804
8805 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8806#else
8807 mark_used(msgout)
8808 mark_used(source)
8809 mark_used(comm)
8810 mark_used(tag)
8811 request = mp_request_null
8812 cpabort("mp_irecv called in non parallel case")
8813#endif
8814 CALL mp_timestop(handle)
8815 END SUBROUTINE mp_irecv_im2
8816
8817! **************************************************************************************************
8818!> \brief Non-blocking send of rank-3 data
8819!> \param msgout ...
8820!> \param source ...
8821!> \param comm ...
8822!> \param request ...
8823!> \param tag ...
8824!> \par History
8825!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
8826!> 2009-11-25 [UB] Made type-generic for templates
8827!> \author fawzi
8828!> \note see mp_isendrecv_iv
8829!> \note see mp_irecv_iv
8830!> \note
8831!> arrays can be pointers or assumed shape, but they must be contiguous!
8832! **************************************************************************************************
8833 SUBROUTINE mp_irecv_im3(msgout, source, comm, request, tag)
8834 INTEGER(KIND=int_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
8835 INTEGER, INTENT(IN) :: source
8836 CLASS(mp_comm_type), INTENT(IN) :: comm
8837 TYPE(mp_request_type), INTENT(out) :: request
8838 INTEGER, INTENT(in), OPTIONAL :: tag
8839
8840 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im3'
8841
8842 INTEGER :: handle
8843#if defined(__parallel)
8844 INTEGER :: ierr, msglen, my_tag
8845 INTEGER(KIND=int_4) :: foo(1)
8846#endif
8847
8848 CALL mp_timeset(routinen, handle)
8849
8850#if defined(__parallel)
8851#if !defined(__GNUC__) || __GNUC__ >= 9
8852 cpassert(is_contiguous(msgout))
8853#endif
8854
8855 my_tag = 0
8856 IF (PRESENT(tag)) my_tag = tag
8857
8858 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
8859 IF (msglen > 0) THEN
8860 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_integer, source, my_tag, &
8861 comm%handle, request%handle, ierr)
8862 ELSE
8863 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8864 comm%handle, request%handle, ierr)
8865 END IF
8866 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
8867
8868 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8869#else
8870 mark_used(msgout)
8871 mark_used(source)
8872 mark_used(comm)
8873 mark_used(tag)
8874 request = mp_request_null
8875 cpabort("mp_irecv called in non parallel case")
8876#endif
8877 CALL mp_timestop(handle)
8878 END SUBROUTINE mp_irecv_im3
8879
8880! **************************************************************************************************
8881!> \brief Non-blocking receive of rank-4 data
8882!> \param msgout the output message
8883!> \param source the source processor
8884!> \param comm the communicator object
8885!> \param request the communication request id
8886!> \param tag the message tag
8887!> \par History
8888!> 2.2016 added _im4 subroutine [Nico Holmberg]
8889!> \author fawzi
8890!> \note see mp_irecv_iv
8891!> \note
8892!> arrays can be pointers or assumed shape, but they must be contiguous!
8893! **************************************************************************************************
8894 SUBROUTINE mp_irecv_im4(msgout, source, comm, request, tag)
8895 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
8896 INTEGER, INTENT(IN) :: source
8897 CLASS(mp_comm_type), INTENT(IN) :: comm
8898 TYPE(mp_request_type), INTENT(out) :: request
8899 INTEGER, INTENT(in), OPTIONAL :: tag
8900
8901 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im4'
8902
8903 INTEGER :: handle
8904#if defined(__parallel)
8905 INTEGER :: ierr, msglen, my_tag
8906 INTEGER(KIND=int_4) :: foo(1)
8907#endif
8908
8909 CALL mp_timeset(routinen, handle)
8910
8911#if defined(__parallel)
8912#if !defined(__GNUC__) || __GNUC__ >= 9
8913 cpassert(is_contiguous(msgout))
8914#endif
8915
8916 my_tag = 0
8917 IF (PRESENT(tag)) my_tag = tag
8918
8919 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
8920 IF (msglen > 0) THEN
8921 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_integer, source, my_tag, &
8922 comm%handle, request%handle, ierr)
8923 ELSE
8924 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8925 comm%handle, request%handle, ierr)
8926 END IF
8927 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
8928
8929 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8930#else
8931 mark_used(msgout)
8932 mark_used(source)
8933 mark_used(comm)
8934 mark_used(tag)
8935 request = mp_request_null
8936 cpabort("mp_irecv called in non parallel case")
8937#endif
8938 CALL mp_timestop(handle)
8939 END SUBROUTINE mp_irecv_im4
8940
8941! **************************************************************************************************
8942!> \brief Window initialization function for vector data
8943!> \param base ...
8944!> \param comm ...
8945!> \param win ...
8946!> \par History
8947!> 02.2015 created [Alfio Lazzaro]
8948!> \note
8949!> arrays can be pointers or assumed shape, but they must be contiguous!
8950! **************************************************************************************************
8951 SUBROUTINE mp_win_create_iv(base, comm, win)
8952 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
8953 TYPE(mp_comm_type), INTENT(IN) :: comm
8954 CLASS(mp_win_type), INTENT(INOUT) :: win
8955
8956 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_iv'
8957
8958 INTEGER :: handle
8959#if defined(__parallel)
8960 INTEGER :: ierr
8961 INTEGER(kind=mpi_address_kind) :: len
8962 INTEGER(KIND=int_4) :: foo(1)
8963#endif
8964
8965 CALL mp_timeset(routinen, handle)
8966
8967#if defined(__parallel)
8968
8969 len = SIZE(base)*int_4_size
8970 IF (len > 0) THEN
8971 CALL mpi_win_create(base(1), len, int_4_size, mpi_info_null, comm%handle, win%handle, ierr)
8972 ELSE
8973 CALL mpi_win_create(foo, len, int_4_size, mpi_info_null, comm%handle, win%handle, ierr)
8974 END IF
8975 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
8976
8977 CALL add_perf(perf_id=20, count=1)
8978#else
8979 mark_used(base)
8980 mark_used(comm)
8981 win%handle = mp_win_null_handle
8982#endif
8983 CALL mp_timestop(handle)
8984 END SUBROUTINE mp_win_create_iv
8985
8986! **************************************************************************************************
8987!> \brief Single-sided get function for vector data
8988!> \param base ...
8989!> \param comm ...
8990!> \param win ...
8991!> \par History
8992!> 02.2015 created [Alfio Lazzaro]
8993!> \note
8994!> arrays can be pointers or assumed shape, but they must be contiguous!
8995! **************************************************************************************************
8996 SUBROUTINE mp_rget_iv(base, source, win, win_data, myproc, disp, request, &
8997 origin_datatype, target_datatype)
8998 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
8999 INTEGER, INTENT(IN) :: source
9000 CLASS(mp_win_type), INTENT(IN) :: win
9001 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: win_data
9002 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
9003 TYPE(mp_request_type), INTENT(OUT) :: request
9004 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
9005
9006 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_iv'
9007
9008 INTEGER :: handle
9009#if defined(__parallel)
9010 INTEGER :: ierr, len, &
9011 origin_len, target_len
9012 LOGICAL :: do_local_copy
9013 INTEGER(kind=mpi_address_kind) :: disp_aint
9014 mpi_data_type :: handle_origin_datatype, handle_target_datatype
9015#endif
9016
9017 CALL mp_timeset(routinen, handle)
9018
9019#if defined(__parallel)
9020 len = SIZE(base)
9021 disp_aint = 0
9022 IF (PRESENT(disp)) THEN
9023 disp_aint = int(disp, kind=mpi_address_kind)
9024 END IF
9025 handle_origin_datatype = mpi_integer
9026 origin_len = len
9027 IF (PRESENT(origin_datatype)) THEN
9028 handle_origin_datatype = origin_datatype%type_handle
9029 origin_len = 1
9030 END IF
9031 handle_target_datatype = mpi_integer
9032 target_len = len
9033 IF (PRESENT(target_datatype)) THEN
9034 handle_target_datatype = target_datatype%type_handle
9035 target_len = 1
9036 END IF
9037 IF (len > 0) THEN
9038 do_local_copy = .false.
9039 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
9040 IF (myproc .EQ. source) do_local_copy = .true.
9041 END IF
9042 IF (do_local_copy) THEN
9043 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
9044 base(:) = win_data(disp_aint + 1:disp_aint + len)
9045 !$OMP END PARALLEL WORKSHARE
9046 request = mp_request_null
9047 ierr = 0
9048 ELSE
9049 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
9050 target_len, handle_target_datatype, win%handle, request%handle, ierr)
9051 END IF
9052 ELSE
9053 request = mp_request_null
9054 ierr = 0
9055 END IF
9056 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
9057
9058 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*int_4_size)
9059#else
9060 mark_used(source)
9061 mark_used(win)
9062 mark_used(myproc)
9063 mark_used(origin_datatype)
9064 mark_used(target_datatype)
9065
9066 request = mp_request_null
9067 !
9068 IF (PRESENT(disp)) THEN
9069 base(:) = win_data(disp + 1:disp + SIZE(base))
9070 ELSE
9071 base(:) = win_data(:SIZE(base))
9072 END IF
9073
9074#endif
9075 CALL mp_timestop(handle)
9076 END SUBROUTINE mp_rget_iv
9077
9078! **************************************************************************************************
9079!> \brief ...
9080!> \param count ...
9081!> \param lengths ...
9082!> \param displs ...
9083!> \return ...
9084! ***************************************************************************
9085 FUNCTION mp_type_indexed_make_i (count, lengths, displs) &
9086 result(type_descriptor)
9087 INTEGER, INTENT(IN) :: count
9088 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
9089 TYPE(mp_type_descriptor_type) :: type_descriptor
9090
9091 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_i'
9092
9093 INTEGER :: handle
9094#if defined(__parallel)
9095 INTEGER :: ierr
9096#endif
9097
9098 CALL mp_timeset(routinen, handle)
9099
9100#if defined(__parallel)
9101 CALL mpi_type_indexed(count, lengths, displs, mpi_integer, &
9102 type_descriptor%type_handle, ierr)
9103 IF (ierr /= 0) &
9104 cpabort("MPI_Type_Indexed @ "//routinen)
9105 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
9106 IF (ierr /= 0) &
9107 cpabort("MPI_Type_commit @ "//routinen)
9108#else
9109 type_descriptor%type_handle = 17
9110#endif
9111 type_descriptor%length = count
9112 NULLIFY (type_descriptor%subtype)
9113 type_descriptor%vector_descriptor(1:2) = 1
9114 type_descriptor%has_indexing = .true.
9115 type_descriptor%index_descriptor%index => lengths
9116 type_descriptor%index_descriptor%chunks => displs
9117
9118 CALL mp_timestop(handle)
9119
9120 END FUNCTION mp_type_indexed_make_i
9121
9122! **************************************************************************************************
9123!> \brief Allocates special parallel memory
9124!> \param[in] DATA pointer to integer array to allocate
9125!> \param[in] len number of integers to allocate
9126!> \param[out] stat (optional) allocation status result
9127!> \author UB
9128! **************************************************************************************************
9129 SUBROUTINE mp_allocate_i (DATA, len, stat)
9130 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
9131 INTEGER, INTENT(IN) :: len
9132 INTEGER, INTENT(OUT), OPTIONAL :: stat
9133
9134 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_i'
9135
9136 INTEGER :: handle, ierr
9137
9138 CALL mp_timeset(routinen, handle)
9139
9140#if defined(__parallel)
9141 NULLIFY (data)
9142 CALL mp_alloc_mem(DATA, len, stat=ierr)
9143 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
9144 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
9145 CALL add_perf(perf_id=15, count=1)
9146#else
9147 ALLOCATE (DATA(len), stat=ierr)
9148 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
9149 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
9150#endif
9151 IF (PRESENT(stat)) stat = ierr
9152 CALL mp_timestop(handle)
9153 END SUBROUTINE mp_allocate_i
9154
9155! **************************************************************************************************
9156!> \brief Deallocates special parallel memory
9157!> \param[in] DATA pointer to special memory to deallocate
9158!> \param stat ...
9159!> \author UB
9160! **************************************************************************************************
9161 SUBROUTINE mp_deallocate_i (DATA, stat)
9162 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
9163 INTEGER, INTENT(OUT), OPTIONAL :: stat
9164
9165 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_i'
9166
9167 INTEGER :: handle
9168#if defined(__parallel)
9169 INTEGER :: ierr
9170#endif
9171
9172 CALL mp_timeset(routinen, handle)
9173
9174#if defined(__parallel)
9175 CALL mp_free_mem(DATA, ierr)
9176 IF (PRESENT(stat)) THEN
9177 stat = ierr
9178 ELSE
9179 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
9180 END IF
9181 NULLIFY (data)
9182 CALL add_perf(perf_id=15, count=1)
9183#else
9184 DEALLOCATE (data)
9185 IF (PRESENT(stat)) stat = 0
9186#endif
9187 CALL mp_timestop(handle)
9188 END SUBROUTINE mp_deallocate_i
9189
9190! **************************************************************************************************
9191!> \brief (parallel) Blocking individual file write using explicit offsets
9192!> (serial) Unformatted stream write
9193!> \param[in] fh file handle (file storage unit)
9194!> \param[in] offset file offset (position)
9195!> \param[in] msg data to be written to the file
9196!> \param msglen ...
9197!> \par MPI-I/O mapping mpi_file_write_at
9198!> \par STREAM-I/O mapping WRITE
9199!> \param[in](optional) msglen number of the elements of data
9200! **************************************************************************************************
9201 SUBROUTINE mp_file_write_at_iv(fh, offset, msg, msglen)
9202 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
9203 CLASS(mp_file_type), INTENT(IN) :: fh
9204 INTEGER, INTENT(IN), OPTIONAL :: msglen
9205 INTEGER(kind=file_offset), INTENT(IN) :: offset
9206
9207 INTEGER :: msg_len
9208#if defined(__parallel)
9209 INTEGER :: ierr
9210#endif
9211
9212 msg_len = SIZE(msg)
9213 IF (PRESENT(msglen)) msg_len = msglen
9214#if defined(__parallel)
9215 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9216 IF (ierr .NE. 0) &
9217 cpabort("mpi_file_write_at_iv @ mp_file_write_at_iv")
9218#else
9219 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9220#endif
9221 END SUBROUTINE mp_file_write_at_iv
9222
9223! **************************************************************************************************
9224!> \brief ...
9225!> \param fh ...
9226!> \param offset ...
9227!> \param msg ...
9228! **************************************************************************************************
9229 SUBROUTINE mp_file_write_at_i (fh, offset, msg)
9230 INTEGER(KIND=int_4), INTENT(IN) :: msg
9231 CLASS(mp_file_type), INTENT(IN) :: fh
9232 INTEGER(kind=file_offset), INTENT(IN) :: offset
9233
9234#if defined(__parallel)
9235 INTEGER :: ierr
9236
9237 ierr = 0
9238 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9239 IF (ierr .NE. 0) &
9240 cpabort("mpi_file_write_at_i @ mp_file_write_at_i")
9241#else
9242 WRITE (unit=fh%handle, pos=offset + 1) msg
9243#endif
9244 END SUBROUTINE mp_file_write_at_i
9245
9246! **************************************************************************************************
9247!> \brief (parallel) Blocking collective file write using explicit offsets
9248!> (serial) Unformatted stream write
9249!> \param fh ...
9250!> \param offset ...
9251!> \param msg ...
9252!> \param msglen ...
9253!> \par MPI-I/O mapping mpi_file_write_at_all
9254!> \par STREAM-I/O mapping WRITE
9255! **************************************************************************************************
9256 SUBROUTINE mp_file_write_at_all_iv(fh, offset, msg, msglen)
9257 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
9258 CLASS(mp_file_type), INTENT(IN) :: fh
9259 INTEGER, INTENT(IN), OPTIONAL :: msglen
9260 INTEGER(kind=file_offset), INTENT(IN) :: offset
9261
9262 INTEGER :: msg_len
9263#if defined(__parallel)
9264 INTEGER :: ierr
9265#endif
9266
9267 msg_len = SIZE(msg)
9268 IF (PRESENT(msglen)) msg_len = msglen
9269#if defined(__parallel)
9270 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9271 IF (ierr .NE. 0) &
9272 cpabort("mpi_file_write_at_all_iv @ mp_file_write_at_all_iv")
9273#else
9274 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9275#endif
9276 END SUBROUTINE mp_file_write_at_all_iv
9277
9278! **************************************************************************************************
9279!> \brief ...
9280!> \param fh ...
9281!> \param offset ...
9282!> \param msg ...
9283! **************************************************************************************************
9284 SUBROUTINE mp_file_write_at_all_i (fh, offset, msg)
9285 INTEGER(KIND=int_4), INTENT(IN) :: msg
9286 CLASS(mp_file_type), INTENT(IN) :: fh
9287 INTEGER(kind=file_offset), INTENT(IN) :: offset
9288
9289#if defined(__parallel)
9290 INTEGER :: ierr
9291
9292 ierr = 0
9293 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9294 IF (ierr .NE. 0) &
9295 cpabort("mpi_file_write_at_all_i @ mp_file_write_at_all_i")
9296#else
9297 WRITE (unit=fh%handle, pos=offset + 1) msg
9298#endif
9299 END SUBROUTINE mp_file_write_at_all_i
9300
9301! **************************************************************************************************
9302!> \brief (parallel) Blocking individual file read using explicit offsets
9303!> (serial) Unformatted stream read
9304!> \param[in] fh file handle (file storage unit)
9305!> \param[in] offset file offset (position)
9306!> \param[out] msg data to be read from the file
9307!> \param msglen ...
9308!> \par MPI-I/O mapping mpi_file_read_at
9309!> \par STREAM-I/O mapping READ
9310!> \param[in](optional) msglen number of elements of data
9311! **************************************************************************************************
9312 SUBROUTINE mp_file_read_at_iv(fh, offset, msg, msglen)
9313 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msg(:)
9314 CLASS(mp_file_type), INTENT(IN) :: fh
9315 INTEGER, INTENT(IN), OPTIONAL :: msglen
9316 INTEGER(kind=file_offset), INTENT(IN) :: offset
9317
9318 INTEGER :: msg_len
9319#if defined(__parallel)
9320 INTEGER :: ierr
9321#endif
9322
9323 msg_len = SIZE(msg)
9324 IF (PRESENT(msglen)) msg_len = msglen
9325#if defined(__parallel)
9326 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9327 IF (ierr .NE. 0) &
9328 cpabort("mpi_file_read_at_iv @ mp_file_read_at_iv")
9329#else
9330 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9331#endif
9332 END SUBROUTINE mp_file_read_at_iv
9333
9334! **************************************************************************************************
9335!> \brief ...
9336!> \param fh ...
9337!> \param offset ...
9338!> \param msg ...
9339! **************************************************************************************************
9340 SUBROUTINE mp_file_read_at_i (fh, offset, msg)
9341 INTEGER(KIND=int_4), INTENT(OUT) :: msg
9342 CLASS(mp_file_type), INTENT(IN) :: fh
9343 INTEGER(kind=file_offset), INTENT(IN) :: offset
9344
9345#if defined(__parallel)
9346 INTEGER :: ierr
9347
9348 ierr = 0
9349 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9350 IF (ierr .NE. 0) &
9351 cpabort("mpi_file_read_at_i @ mp_file_read_at_i")
9352#else
9353 READ (unit=fh%handle, pos=offset + 1) msg
9354#endif
9355 END SUBROUTINE mp_file_read_at_i
9356
9357! **************************************************************************************************
9358!> \brief (parallel) Blocking collective file read using explicit offsets
9359!> (serial) Unformatted stream read
9360!> \param fh ...
9361!> \param offset ...
9362!> \param msg ...
9363!> \param msglen ...
9364!> \par MPI-I/O mapping mpi_file_read_at_all
9365!> \par STREAM-I/O mapping READ
9366! **************************************************************************************************
9367 SUBROUTINE mp_file_read_at_all_iv(fh, offset, msg, msglen)
9368 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msg(:)
9369 CLASS(mp_file_type), INTENT(IN) :: fh
9370 INTEGER, INTENT(IN), OPTIONAL :: msglen
9371 INTEGER(kind=file_offset), INTENT(IN) :: offset
9372
9373 INTEGER :: msg_len
9374#if defined(__parallel)
9375 INTEGER :: ierr
9376#endif
9377
9378 msg_len = SIZE(msg)
9379 IF (PRESENT(msglen)) msg_len = msglen
9380#if defined(__parallel)
9381 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9382 IF (ierr .NE. 0) &
9383 cpabort("mpi_file_read_at_all_iv @ mp_file_read_at_all_iv")
9384#else
9385 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9386#endif
9387 END SUBROUTINE mp_file_read_at_all_iv
9388
9389! **************************************************************************************************
9390!> \brief ...
9391!> \param fh ...
9392!> \param offset ...
9393!> \param msg ...
9394! **************************************************************************************************
9395 SUBROUTINE mp_file_read_at_all_i (fh, offset, msg)
9396 INTEGER(KIND=int_4), INTENT(OUT) :: msg
9397 CLASS(mp_file_type), INTENT(IN) :: fh
9398 INTEGER(kind=file_offset), INTENT(IN) :: offset
9399
9400#if defined(__parallel)
9401 INTEGER :: ierr
9402
9403 ierr = 0
9404 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9405 IF (ierr .NE. 0) &
9406 cpabort("mpi_file_read_at_all_i @ mp_file_read_at_all_i")
9407#else
9408 READ (unit=fh%handle, pos=offset + 1) msg
9409#endif
9410 END SUBROUTINE mp_file_read_at_all_i
9411
9412! **************************************************************************************************
9413!> \brief ...
9414!> \param ptr ...
9415!> \param vector_descriptor ...
9416!> \param index_descriptor ...
9417!> \return ...
9418! **************************************************************************************************
9419 FUNCTION mp_type_make_i (ptr, &
9420 vector_descriptor, index_descriptor) &
9421 result(type_descriptor)
9422 INTEGER(KIND=int_4), DIMENSION(:), TARGET, asynchronous :: ptr
9423 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
9424 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
9425 TYPE(mp_type_descriptor_type) :: type_descriptor
9426
9427 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_i'
9428
9429#if defined(__parallel)
9430 INTEGER :: ierr
9431#if defined(__MPI_F08)
9432 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
9433 EXTERNAL :: mpi_get_address
9434#endif
9435#endif
9436
9437 NULLIFY (type_descriptor%subtype)
9438 type_descriptor%length = SIZE(ptr)
9439#if defined(__parallel)
9440 type_descriptor%type_handle = mpi_integer
9441 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
9442 IF (ierr /= 0) &
9443 cpabort("MPI_Get_address @ "//routinen)
9444#else
9445 type_descriptor%type_handle = 17
9446#endif
9447 type_descriptor%vector_descriptor(1:2) = 1
9448 type_descriptor%has_indexing = .false.
9449 type_descriptor%data_i => ptr
9450 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
9451 cpabort(routinen//": Vectors and indices NYI")
9452 END IF
9453 END FUNCTION mp_type_make_i
9454
9455! **************************************************************************************************
9456!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
9457!> as the Fortran version returns an integer, which we take to be a C_PTR
9458!> \param DATA data array to allocate
9459!> \param[in] len length (in data elements) of data array allocation
9460!> \param[out] stat (optional) allocation status result
9461! **************************************************************************************************
9462 SUBROUTINE mp_alloc_mem_i (DATA, len, stat)
9463 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: data
9464 INTEGER, INTENT(IN) :: len
9465 INTEGER, INTENT(OUT), OPTIONAL :: stat
9466
9467#if defined(__parallel)
9468 INTEGER :: size, ierr, length, &
9469 mp_res
9470 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
9471 TYPE(c_ptr) :: mp_baseptr
9472 mpi_info_type :: mp_info
9473
9474 length = max(len, 1)
9475 CALL mpi_type_size(mpi_integer, size, ierr)
9476 mp_size = int(length, kind=mpi_address_kind)*size
9477 IF (mp_size .GT. mp_max_memory_size) THEN
9478 cpabort("MPI cannot allocate more than 2 GiByte")
9479 END IF
9480 mp_info = mpi_info_null
9481 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
9482 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
9483 IF (PRESENT(stat)) stat = mp_res
9484#else
9485 INTEGER :: length, mystat
9486 length = max(len, 1)
9487 IF (PRESENT(stat)) THEN
9488 ALLOCATE (DATA(length), stat=mystat)
9489 stat = mystat ! show to convention checker that stat is used
9490 ELSE
9491 ALLOCATE (DATA(length))
9492 END IF
9493#endif
9494 END SUBROUTINE mp_alloc_mem_i
9495
9496! **************************************************************************************************
9497!> \brief Deallocates am array, ... this is hackish
9498!> as the Fortran version takes an integer, which we hope to get by reference
9499!> \param DATA data array to allocate
9500!> \param[out] stat (optional) allocation status result
9501! **************************************************************************************************
9502 SUBROUTINE mp_free_mem_i (DATA, stat)
9503 INTEGER(KIND=int_4), DIMENSION(:), &
9504 POINTER, asynchronous :: data
9505 INTEGER, INTENT(OUT), OPTIONAL :: stat
9506
9507#if defined(__parallel)
9508 INTEGER :: mp_res
9509 CALL mpi_free_mem(DATA, mp_res)
9510 IF (PRESENT(stat)) stat = mp_res
9511#else
9512 DEALLOCATE (data)
9513 IF (PRESENT(stat)) stat = 0
9514#endif
9515 END SUBROUTINE mp_free_mem_i
9516! **************************************************************************************************
9517!> \brief Shift around the data in msg
9518!> \param[in,out] msg Rank-2 data to shift
9519!> \param[in] comm message passing environment identifier
9520!> \param[in] displ_in displacements (?)
9521!> \par Example
9522!> msg will be moved from rank to rank+displ_in (in a circular way)
9523!> \par Limitations
9524!> * displ_in will be 1 by default (others not tested)
9525!> * the message array needs to be the same size on all processes
9526! **************************************************************************************************
9527 SUBROUTINE mp_shift_lm(msg, comm, displ_in)
9528
9529 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
9530 CLASS(mp_comm_type), INTENT(IN) :: comm
9531 INTEGER, INTENT(IN), OPTIONAL :: displ_in
9532
9533 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_lm'
9534
9535 INTEGER :: handle, ierror
9536#if defined(__parallel)
9537 INTEGER :: displ, left, &
9538 msglen, myrank, nprocs, &
9539 right, tag
9540#endif
9541
9542 ierror = 0
9543 CALL mp_timeset(routinen, handle)
9544
9545#if defined(__parallel)
9546 CALL mpi_comm_rank(comm%handle, myrank, ierror)
9547 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
9548 CALL mpi_comm_size(comm%handle, nprocs, ierror)
9549 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
9550 IF (PRESENT(displ_in)) THEN
9551 displ = displ_in
9552 ELSE
9553 displ = 1
9554 END IF
9555 right = modulo(myrank + displ, nprocs)
9556 left = modulo(myrank - displ, nprocs)
9557 tag = 17
9558 msglen = SIZE(msg)
9559 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer8, right, tag, left, tag, &
9560 comm%handle, mpi_status_ignore, ierror)
9561 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
9562 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_8_size)
9563#else
9564 mark_used(msg)
9565 mark_used(comm)
9566 mark_used(displ_in)
9567#endif
9568 CALL mp_timestop(handle)
9569
9570 END SUBROUTINE mp_shift_lm
9571
9572! **************************************************************************************************
9573!> \brief Shift around the data in msg
9574!> \param[in,out] msg Data to shift
9575!> \param[in] comm message passing environment identifier
9576!> \param[in] displ_in displacements (?)
9577!> \par Example
9578!> msg will be moved from rank to rank+displ_in (in a circular way)
9579!> \par Limitations
9580!> * displ_in will be 1 by default (others not tested)
9581!> * the message array needs to be the same size on all processes
9582! **************************************************************************************************
9583 SUBROUTINE mp_shift_l (msg, comm, displ_in)
9584
9585 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
9586 CLASS(mp_comm_type), INTENT(IN) :: comm
9587 INTEGER, INTENT(IN), OPTIONAL :: displ_in
9588
9589 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_l'
9590
9591 INTEGER :: handle, ierror
9592#if defined(__parallel)
9593 INTEGER :: displ, left, &
9594 msglen, myrank, nprocs, &
9595 right, tag
9596#endif
9597
9598 ierror = 0
9599 CALL mp_timeset(routinen, handle)
9600
9601#if defined(__parallel)
9602 CALL mpi_comm_rank(comm%handle, myrank, ierror)
9603 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
9604 CALL mpi_comm_size(comm%handle, nprocs, ierror)
9605 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
9606 IF (PRESENT(displ_in)) THEN
9607 displ = displ_in
9608 ELSE
9609 displ = 1
9610 END IF
9611 right = modulo(myrank + displ, nprocs)
9612 left = modulo(myrank - displ, nprocs)
9613 tag = 19
9614 msglen = SIZE(msg)
9615 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer8, right, tag, left, &
9616 tag, comm%handle, mpi_status_ignore, ierror)
9617 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
9618 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_8_size)
9619#else
9620 mark_used(msg)
9621 mark_used(comm)
9622 mark_used(displ_in)
9623#endif
9624 CALL mp_timestop(handle)
9625
9626 END SUBROUTINE mp_shift_l
9627
9628! **************************************************************************************************
9629!> \brief All-to-all data exchange, rank-1 data of different sizes
9630!> \param[in] sb Data to send
9631!> \param[in] scount Data counts for data sent to other processes
9632!> \param[in] sdispl Respective data offsets for data sent to process
9633!> \param[in,out] rb Buffer into which to receive data
9634!> \param[in] rcount Data counts for data received from other
9635!> processes
9636!> \param[in] rdispl Respective data offsets for data received from
9637!> other processes
9638!> \param[in] comm Message passing environment identifier
9639!> \par MPI mapping
9640!> mpi_alltoallv
9641!> \par Array sizes
9642!> The scount, rcount, and the sdispl and rdispl arrays have a
9643!> size equal to the number of processes.
9644!> \par Offsets
9645!> Values in sdispl and rdispl start with 0.
9646! **************************************************************************************************
9647 SUBROUTINE mp_alltoall_l11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
9648
9649 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
9650 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
9651 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
9652 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
9653 CLASS(mp_comm_type), INTENT(IN) :: comm
9654
9655 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l11v'
9656
9657 INTEGER :: handle
9658#if defined(__parallel)
9659 INTEGER :: ierr, msglen
9660#else
9661 INTEGER :: i
9662#endif
9663
9664 CALL mp_timeset(routinen, handle)
9665
9666#if defined(__parallel)
9667 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer8, &
9668 rb, rcount, rdispl, mpi_integer8, comm%handle, ierr)
9669 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
9670 msglen = sum(scount) + sum(rcount)
9671 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9672#else
9673 mark_used(comm)
9674 mark_used(scount)
9675 mark_used(sdispl)
9676 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
9677 DO i = 1, rcount(1)
9678 rb(rdispl(1) + i) = sb(sdispl(1) + i)
9679 END DO
9680#endif
9681 CALL mp_timestop(handle)
9682
9683 END SUBROUTINE mp_alltoall_l11v
9684
9685! **************************************************************************************************
9686!> \brief All-to-all data exchange, rank-2 data of different sizes
9687!> \param sb ...
9688!> \param scount ...
9689!> \param sdispl ...
9690!> \param rb ...
9691!> \param rcount ...
9692!> \param rdispl ...
9693!> \param comm ...
9694!> \par MPI mapping
9695!> mpi_alltoallv
9696!> \note see mp_alltoall_l11v
9697! **************************************************************************************************
9698 SUBROUTINE mp_alltoall_l22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
9699
9700 INTEGER(KIND=int_8), DIMENSION(:, :), &
9701 INTENT(IN), CONTIGUOUS :: sb
9702 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
9703 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, &
9704 INTENT(INOUT) :: rb
9705 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
9706 CLASS(mp_comm_type), INTENT(IN) :: comm
9707
9708 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l22v'
9709
9710 INTEGER :: handle
9711#if defined(__parallel)
9712 INTEGER :: ierr, msglen
9713#endif
9714
9715 CALL mp_timeset(routinen, handle)
9716
9717#if defined(__parallel)
9718 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer8, &
9719 rb, rcount, rdispl, mpi_integer8, comm%handle, ierr)
9720 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
9721 msglen = sum(scount) + sum(rcount)
9722 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*int_8_size)
9723#else
9724 mark_used(comm)
9725 mark_used(scount)
9726 mark_used(sdispl)
9727 mark_used(rcount)
9728 mark_used(rdispl)
9729 rb = sb
9730#endif
9731 CALL mp_timestop(handle)
9732
9733 END SUBROUTINE mp_alltoall_l22v
9734
9735! **************************************************************************************************
9736!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
9737!> \param[in] sb array with data to send
9738!> \param[out] rb array into which data is received
9739!> \param[in] count number of elements to send/receive (product of the
9740!> extents of the first two dimensions)
9741!> \param[in] comm Message passing environment identifier
9742!> \par Index meaning
9743!> \par The first two indices specify the data while the last index counts
9744!> the processes
9745!> \par Sizes of ranks
9746!> All processes have the same data size.
9747!> \par MPI mapping
9748!> mpi_alltoall
9749! **************************************************************************************************
9750 SUBROUTINE mp_alltoall_l (sb, rb, count, comm)
9751
9752 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
9753 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
9754 INTEGER, INTENT(IN) :: count
9755 CLASS(mp_comm_type), INTENT(IN) :: comm
9756
9757 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l'
9758
9759 INTEGER :: handle
9760#if defined(__parallel)
9761 INTEGER :: ierr, msglen, np
9762#endif
9763
9764 CALL mp_timeset(routinen, handle)
9765
9766#if defined(__parallel)
9767 CALL mpi_alltoall(sb, count, mpi_integer8, &
9768 rb, count, mpi_integer8, comm%handle, ierr)
9769 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9770 CALL mpi_comm_size(comm%handle, np, ierr)
9771 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9772 msglen = 2*count*np
9773 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9774#else
9775 mark_used(count)
9776 mark_used(comm)
9777 rb = sb
9778#endif
9779 CALL mp_timestop(handle)
9780
9781 END SUBROUTINE mp_alltoall_l
9782
9783! **************************************************************************************************
9784!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
9785!> \param sb ...
9786!> \param rb ...
9787!> \param count ...
9788!> \param commp ...
9789!> \note see mp_alltoall_l
9790! **************************************************************************************************
9791 SUBROUTINE mp_alltoall_l22(sb, rb, count, comm)
9792
9793 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
9794 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
9795 INTEGER, INTENT(IN) :: count
9796 CLASS(mp_comm_type), INTENT(IN) :: comm
9797
9798 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l22'
9799
9800 INTEGER :: handle
9801#if defined(__parallel)
9802 INTEGER :: ierr, msglen, np
9803#endif
9804
9805 CALL mp_timeset(routinen, handle)
9806
9807#if defined(__parallel)
9808 CALL mpi_alltoall(sb, count, mpi_integer8, &
9809 rb, count, mpi_integer8, comm%handle, ierr)
9810 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9811 CALL mpi_comm_size(comm%handle, np, ierr)
9812 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9813 msglen = 2*SIZE(sb)*np
9814 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9815#else
9816 mark_used(count)
9817 mark_used(comm)
9818 rb = sb
9819#endif
9820 CALL mp_timestop(handle)
9821
9822 END SUBROUTINE mp_alltoall_l22
9823
9824! **************************************************************************************************
9825!> \brief All-to-all data exchange, rank-3 data with equal sizes
9826!> \param sb ...
9827!> \param rb ...
9828!> \param count ...
9829!> \param comm ...
9830!> \note see mp_alltoall_l
9831! **************************************************************************************************
9832 SUBROUTINE mp_alltoall_l33(sb, rb, count, comm)
9833
9834 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
9835 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
9836 INTEGER, INTENT(IN) :: count
9837 CLASS(mp_comm_type), INTENT(IN) :: comm
9838
9839 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l33'
9840
9841 INTEGER :: handle
9842#if defined(__parallel)
9843 INTEGER :: ierr, msglen, np
9844#endif
9845
9846 CALL mp_timeset(routinen, handle)
9847
9848#if defined(__parallel)
9849 CALL mpi_alltoall(sb, count, mpi_integer8, &
9850 rb, count, mpi_integer8, comm%handle, ierr)
9851 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9852 CALL mpi_comm_size(comm%handle, np, ierr)
9853 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9854 msglen = 2*count*np
9855 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9856#else
9857 mark_used(count)
9858 mark_used(comm)
9859 rb = sb
9860#endif
9861 CALL mp_timestop(handle)
9862
9863 END SUBROUTINE mp_alltoall_l33
9864
9865! **************************************************************************************************
9866!> \brief All-to-all data exchange, rank 4 data, equal sizes
9867!> \param sb ...
9868!> \param rb ...
9869!> \param count ...
9870!> \param comm ...
9871!> \note see mp_alltoall_l
9872! **************************************************************************************************
9873 SUBROUTINE mp_alltoall_l44(sb, rb, count, comm)
9874
9875 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
9876 INTENT(IN) :: sb
9877 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
9878 INTENT(OUT) :: rb
9879 INTEGER, INTENT(IN) :: count
9880 CLASS(mp_comm_type), INTENT(IN) :: comm
9881
9882 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l44'
9883
9884 INTEGER :: handle
9885#if defined(__parallel)
9886 INTEGER :: ierr, msglen, np
9887#endif
9888
9889 CALL mp_timeset(routinen, handle)
9890
9891#if defined(__parallel)
9892 CALL mpi_alltoall(sb, count, mpi_integer8, &
9893 rb, count, mpi_integer8, comm%handle, ierr)
9894 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9895 CALL mpi_comm_size(comm%handle, np, ierr)
9896 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9897 msglen = 2*count*np
9898 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9899#else
9900 mark_used(count)
9901 mark_used(comm)
9902 rb = sb
9903#endif
9904 CALL mp_timestop(handle)
9905
9906 END SUBROUTINE mp_alltoall_l44
9907
9908! **************************************************************************************************
9909!> \brief All-to-all data exchange, rank 5 data, equal sizes
9910!> \param sb ...
9911!> \param rb ...
9912!> \param count ...
9913!> \param comm ...
9914!> \note see mp_alltoall_l
9915! **************************************************************************************************
9916 SUBROUTINE mp_alltoall_l55(sb, rb, count, comm)
9917
9918 INTEGER(KIND=int_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
9919 INTENT(IN) :: sb
9920 INTEGER(KIND=int_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
9921 INTENT(OUT) :: rb
9922 INTEGER, INTENT(IN) :: count
9923 CLASS(mp_comm_type), INTENT(IN) :: comm
9924
9925 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l55'
9926
9927 INTEGER :: handle
9928#if defined(__parallel)
9929 INTEGER :: ierr, msglen, np
9930#endif
9931
9932 CALL mp_timeset(routinen, handle)
9933
9934#if defined(__parallel)
9935 CALL mpi_alltoall(sb, count, mpi_integer8, &
9936 rb, count, mpi_integer8, comm%handle, ierr)
9937 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9938 CALL mpi_comm_size(comm%handle, np, ierr)
9939 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9940 msglen = 2*count*np
9941 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9942#else
9943 mark_used(count)
9944 mark_used(comm)
9945 rb = sb
9946#endif
9947 CALL mp_timestop(handle)
9948
9949 END SUBROUTINE mp_alltoall_l55
9950
9951! **************************************************************************************************
9952!> \brief All-to-all data exchange, rank-4 data to rank-5 data
9953!> \param sb ...
9954!> \param rb ...
9955!> \param count ...
9956!> \param comm ...
9957!> \note see mp_alltoall_l
9958!> \note User must ensure size consistency.
9959! **************************************************************************************************
9960 SUBROUTINE mp_alltoall_l45(sb, rb, count, comm)
9961
9962 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
9963 INTENT(IN) :: sb
9964 INTEGER(KIND=int_8), &
9965 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
9966 INTEGER, INTENT(IN) :: count
9967 CLASS(mp_comm_type), INTENT(IN) :: comm
9968
9969 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l45'
9970
9971 INTEGER :: handle
9972#if defined(__parallel)
9973 INTEGER :: ierr, msglen, np
9974#endif
9975
9976 CALL mp_timeset(routinen, handle)
9977
9978#if defined(__parallel)
9979 CALL mpi_alltoall(sb, count, mpi_integer8, &
9980 rb, count, mpi_integer8, comm%handle, ierr)
9981 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9982 CALL mpi_comm_size(comm%handle, np, ierr)
9983 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9984 msglen = 2*count*np
9985 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9986#else
9987 mark_used(count)
9988 mark_used(comm)
9989 rb = reshape(sb, shape(rb))
9990#endif
9991 CALL mp_timestop(handle)
9992
9993 END SUBROUTINE mp_alltoall_l45
9994
9995! **************************************************************************************************
9996!> \brief All-to-all data exchange, rank-3 data to rank-4 data
9997!> \param sb ...
9998!> \param rb ...
9999!> \param count ...
10000!> \param comm ...
10001!> \note see mp_alltoall_l
10002!> \note User must ensure size consistency.
10003! **************************************************************************************************
10004 SUBROUTINE mp_alltoall_l34(sb, rb, count, comm)
10005
10006 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, &
10007 INTENT(IN) :: sb
10008 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10009 INTENT(OUT) :: rb
10010 INTEGER, INTENT(IN) :: count
10011 CLASS(mp_comm_type), INTENT(IN) :: comm
10012
10013 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l34'
10014
10015 INTEGER :: handle
10016#if defined(__parallel)
10017 INTEGER :: ierr, msglen, np
10018#endif
10019
10020 CALL mp_timeset(routinen, handle)
10021
10022#if defined(__parallel)
10023 CALL mpi_alltoall(sb, count, mpi_integer8, &
10024 rb, count, mpi_integer8, comm%handle, ierr)
10025 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10026 CALL mpi_comm_size(comm%handle, np, ierr)
10027 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10028 msglen = 2*count*np
10029 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10030#else
10031 mark_used(count)
10032 mark_used(comm)
10033 rb = reshape(sb, shape(rb))
10034#endif
10035 CALL mp_timestop(handle)
10036
10037 END SUBROUTINE mp_alltoall_l34
10038
10039! **************************************************************************************************
10040!> \brief All-to-all data exchange, rank-5 data to rank-4 data
10041!> \param sb ...
10042!> \param rb ...
10043!> \param count ...
10044!> \param comm ...
10045!> \note see mp_alltoall_l
10046!> \note User must ensure size consistency.
10047! **************************************************************************************************
10048 SUBROUTINE mp_alltoall_l54(sb, rb, count, comm)
10049
10050 INTEGER(KIND=int_8), &
10051 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
10052 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10053 INTENT(OUT) :: rb
10054 INTEGER, INTENT(IN) :: count
10055 CLASS(mp_comm_type), INTENT(IN) :: comm
10056
10057 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l54'
10058
10059 INTEGER :: handle
10060#if defined(__parallel)
10061 INTEGER :: ierr, msglen, np
10062#endif
10063
10064 CALL mp_timeset(routinen, handle)
10065
10066#if defined(__parallel)
10067 CALL mpi_alltoall(sb, count, mpi_integer8, &
10068 rb, count, mpi_integer8, comm%handle, ierr)
10069 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10070 CALL mpi_comm_size(comm%handle, np, ierr)
10071 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10072 msglen = 2*count*np
10073 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10074#else
10075 mark_used(count)
10076 mark_used(comm)
10077 rb = reshape(sb, shape(rb))
10078#endif
10079 CALL mp_timestop(handle)
10080
10081 END SUBROUTINE mp_alltoall_l54
10082
10083! **************************************************************************************************
10084!> \brief Send one datum to another process
10085!> \param[in] msg Scalar to send
10086!> \param[in] dest Destination process
10087!> \param[in] tag Transfer identifier
10088!> \param[in] comm Message passing environment identifier
10089!> \par MPI mapping
10090!> mpi_send
10091! **************************************************************************************************
10092 SUBROUTINE mp_send_l (msg, dest, tag, comm)
10093 INTEGER(KIND=int_8), INTENT(IN) :: msg
10094 INTEGER, INTENT(IN) :: dest, tag
10095 CLASS(mp_comm_type), INTENT(IN) :: comm
10096
10097 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_l'
10098
10099 INTEGER :: handle
10100#if defined(__parallel)
10101 INTEGER :: ierr, msglen
10102#endif
10103
10104 CALL mp_timeset(routinen, handle)
10105
10106#if defined(__parallel)
10107 msglen = 1
10108 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10109 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10110 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10111#else
10112 mark_used(msg)
10113 mark_used(dest)
10114 mark_used(tag)
10115 mark_used(comm)
10116 ! only defined in parallel
10117 cpabort("not in parallel mode")
10118#endif
10119 CALL mp_timestop(handle)
10120 END SUBROUTINE mp_send_l
10121
10122! **************************************************************************************************
10123!> \brief Send rank-1 data to another process
10124!> \param[in] msg Rank-1 data to send
10125!> \param dest ...
10126!> \param tag ...
10127!> \param comm ...
10128!> \note see mp_send_l
10129! **************************************************************************************************
10130 SUBROUTINE mp_send_lv(msg, dest, tag, comm)
10131 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
10132 INTEGER, INTENT(IN) :: dest, tag
10133 CLASS(mp_comm_type), INTENT(IN) :: comm
10134
10135 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_lv'
10136
10137 INTEGER :: handle
10138#if defined(__parallel)
10139 INTEGER :: ierr, msglen
10140#endif
10141
10142 CALL mp_timeset(routinen, handle)
10143
10144#if defined(__parallel)
10145 msglen = SIZE(msg)
10146 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10147 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10148 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10149#else
10150 mark_used(msg)
10151 mark_used(dest)
10152 mark_used(tag)
10153 mark_used(comm)
10154 ! only defined in parallel
10155 cpabort("not in parallel mode")
10156#endif
10157 CALL mp_timestop(handle)
10158 END SUBROUTINE mp_send_lv
10159
10160! **************************************************************************************************
10161!> \brief Send rank-2 data to another process
10162!> \param[in] msg Rank-2 data to send
10163!> \param dest ...
10164!> \param tag ...
10165!> \param comm ...
10166!> \note see mp_send_l
10167! **************************************************************************************************
10168 SUBROUTINE mp_send_lm2(msg, dest, tag, comm)
10169 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
10170 INTEGER, INTENT(IN) :: dest, tag
10171 CLASS(mp_comm_type), INTENT(IN) :: comm
10172
10173 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_lm2'
10174
10175 INTEGER :: handle
10176#if defined(__parallel)
10177 INTEGER :: ierr, msglen
10178#endif
10179
10180 CALL mp_timeset(routinen, handle)
10181
10182#if defined(__parallel)
10183 msglen = SIZE(msg)
10184 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10185 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10186 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10187#else
10188 mark_used(msg)
10189 mark_used(dest)
10190 mark_used(tag)
10191 mark_used(comm)
10192 ! only defined in parallel
10193 cpabort("not in parallel mode")
10194#endif
10195 CALL mp_timestop(handle)
10196 END SUBROUTINE mp_send_lm2
10197
10198! **************************************************************************************************
10199!> \brief Send rank-3 data to another process
10200!> \param[in] msg Rank-3 data to send
10201!> \param dest ...
10202!> \param tag ...
10203!> \param comm ...
10204!> \note see mp_send_l
10205! **************************************************************************************************
10206 SUBROUTINE mp_send_lm3(msg, dest, tag, comm)
10207 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
10208 INTEGER, INTENT(IN) :: dest, tag
10209 CLASS(mp_comm_type), INTENT(IN) :: comm
10210
10211 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
10212
10213 INTEGER :: handle
10214#if defined(__parallel)
10215 INTEGER :: ierr, msglen
10216#endif
10217
10218 CALL mp_timeset(routinen, handle)
10219
10220#if defined(__parallel)
10221 msglen = SIZE(msg)
10222 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10223 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10224 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10225#else
10226 mark_used(msg)
10227 mark_used(dest)
10228 mark_used(tag)
10229 mark_used(comm)
10230 ! only defined in parallel
10231 cpabort("not in parallel mode")
10232#endif
10233 CALL mp_timestop(handle)
10234 END SUBROUTINE mp_send_lm3
10235
10236! **************************************************************************************************
10237!> \brief Receive one datum from another process
10238!> \param[in,out] msg Place received data into this variable
10239!> \param[in,out] source Process to receive from
10240!> \param[in,out] tag Transfer identifier
10241!> \param[in] comm Message passing environment identifier
10242!> \par MPI mapping
10243!> mpi_send
10244! **************************************************************************************************
10245 SUBROUTINE mp_recv_l (msg, source, tag, comm)
10246 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10247 INTEGER, INTENT(INOUT) :: source, tag
10248 CLASS(mp_comm_type), INTENT(IN) :: comm
10249
10250 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_l'
10251
10252 INTEGER :: handle
10253#if defined(__parallel)
10254 INTEGER :: ierr, msglen
10255 mpi_status_type :: status
10256#endif
10257
10258 CALL mp_timeset(routinen, handle)
10259
10260#if defined(__parallel)
10261 msglen = 1
10262 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10263 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10264 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10265 ELSE
10266 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10267 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10268 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10269 source = status mpi_status_extract(mpi_source)
10270 tag = status mpi_status_extract(mpi_tag)
10271 END IF
10272#else
10273 mark_used(msg)
10274 mark_used(source)
10275 mark_used(tag)
10276 mark_used(comm)
10277 ! only defined in parallel
10278 cpabort("not in parallel mode")
10279#endif
10280 CALL mp_timestop(handle)
10281 END SUBROUTINE mp_recv_l
10282
10283! **************************************************************************************************
10284!> \brief Receive rank-1 data from another process
10285!> \param[in,out] msg Place received data into this rank-1 array
10286!> \param source ...
10287!> \param tag ...
10288!> \param comm ...
10289!> \note see mp_recv_l
10290! **************************************************************************************************
10291 SUBROUTINE mp_recv_lv(msg, source, tag, comm)
10292 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10293 INTEGER, INTENT(INOUT) :: source, tag
10294 CLASS(mp_comm_type), INTENT(IN) :: comm
10295
10296 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lv'
10297
10298 INTEGER :: handle
10299#if defined(__parallel)
10300 INTEGER :: ierr, msglen
10301 mpi_status_type :: status
10302#endif
10303
10304 CALL mp_timeset(routinen, handle)
10305
10306#if defined(__parallel)
10307 msglen = SIZE(msg)
10308 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10309 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10310 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10311 ELSE
10312 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10313 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10314 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10315 source = status mpi_status_extract(mpi_source)
10316 tag = status mpi_status_extract(mpi_tag)
10317 END IF
10318#else
10319 mark_used(msg)
10320 mark_used(source)
10321 mark_used(tag)
10322 mark_used(comm)
10323 ! only defined in parallel
10324 cpabort("not in parallel mode")
10325#endif
10326 CALL mp_timestop(handle)
10327 END SUBROUTINE mp_recv_lv
10328
10329! **************************************************************************************************
10330!> \brief Receive rank-2 data from another process
10331!> \param[in,out] msg Place received data into this rank-2 array
10332!> \param source ...
10333!> \param tag ...
10334!> \param comm ...
10335!> \note see mp_recv_l
10336! **************************************************************************************************
10337 SUBROUTINE mp_recv_lm2(msg, source, tag, comm)
10338 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10339 INTEGER, INTENT(INOUT) :: source, tag
10340 CLASS(mp_comm_type), INTENT(IN) :: comm
10341
10342 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lm2'
10343
10344 INTEGER :: handle
10345#if defined(__parallel)
10346 INTEGER :: ierr, msglen
10347 mpi_status_type :: status
10348#endif
10349
10350 CALL mp_timeset(routinen, handle)
10351
10352#if defined(__parallel)
10353 msglen = SIZE(msg)
10354 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10355 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10356 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10357 ELSE
10358 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10359 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10360 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10361 source = status mpi_status_extract(mpi_source)
10362 tag = status mpi_status_extract(mpi_tag)
10363 END IF
10364#else
10365 mark_used(msg)
10366 mark_used(source)
10367 mark_used(tag)
10368 mark_used(comm)
10369 ! only defined in parallel
10370 cpabort("not in parallel mode")
10371#endif
10372 CALL mp_timestop(handle)
10373 END SUBROUTINE mp_recv_lm2
10374
10375! **************************************************************************************************
10376!> \brief Receive rank-3 data from another process
10377!> \param[in,out] msg Place received data into this rank-3 array
10378!> \param source ...
10379!> \param tag ...
10380!> \param comm ...
10381!> \note see mp_recv_l
10382! **************************************************************************************************
10383 SUBROUTINE mp_recv_lm3(msg, source, tag, comm)
10384 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
10385 INTEGER, INTENT(INOUT) :: source, tag
10386 CLASS(mp_comm_type), INTENT(IN) :: comm
10387
10388 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lm3'
10389
10390 INTEGER :: handle
10391#if defined(__parallel)
10392 INTEGER :: ierr, msglen
10393 mpi_status_type :: status
10394#endif
10395
10396 CALL mp_timeset(routinen, handle)
10397
10398#if defined(__parallel)
10399 msglen = SIZE(msg)
10400 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10401 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10402 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10403 ELSE
10404 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10405 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10406 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10407 source = status mpi_status_extract(mpi_source)
10408 tag = status mpi_status_extract(mpi_tag)
10409 END IF
10410#else
10411 mark_used(msg)
10412 mark_used(source)
10413 mark_used(tag)
10414 mark_used(comm)
10415 ! only defined in parallel
10416 cpabort("not in parallel mode")
10417#endif
10418 CALL mp_timestop(handle)
10419 END SUBROUTINE mp_recv_lm3
10420
10421! **************************************************************************************************
10422!> \brief Broadcasts a datum to all processes.
10423!> \param[in] msg Datum to broadcast
10424!> \param[in] source Processes which broadcasts
10425!> \param[in] comm Message passing environment identifier
10426!> \par MPI mapping
10427!> mpi_bcast
10428! **************************************************************************************************
10429 SUBROUTINE mp_bcast_l (msg, source, comm)
10430 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10431 INTEGER, INTENT(IN) :: source
10432 CLASS(mp_comm_type), INTENT(IN) :: comm
10433
10434 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l'
10435
10436 INTEGER :: handle
10437#if defined(__parallel)
10438 INTEGER :: ierr, msglen
10439#endif
10440
10441 CALL mp_timeset(routinen, handle)
10442
10443#if defined(__parallel)
10444 msglen = 1
10445 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10446 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10447 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10448#else
10449 mark_used(msg)
10450 mark_used(source)
10451 mark_used(comm)
10452#endif
10453 CALL mp_timestop(handle)
10454 END SUBROUTINE mp_bcast_l
10455
10456! **************************************************************************************************
10457!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
10458!> \param[in] msg Datum to broadcast
10459!> \param[in] comm Message passing environment identifier
10460!> \par MPI mapping
10461!> mpi_bcast
10462! **************************************************************************************************
10463 SUBROUTINE mp_bcast_l_src(msg, comm)
10464 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10465 CLASS(mp_comm_type), INTENT(IN) :: comm
10466
10467 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l_src'
10468
10469 INTEGER :: handle
10470#if defined(__parallel)
10471 INTEGER :: ierr, msglen
10472#endif
10473
10474 CALL mp_timeset(routinen, handle)
10475
10476#if defined(__parallel)
10477 msglen = 1
10478 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10479 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10480 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10481#else
10482 mark_used(msg)
10483 mark_used(comm)
10484#endif
10485 CALL mp_timestop(handle)
10486 END SUBROUTINE mp_bcast_l_src
10487
10488! **************************************************************************************************
10489!> \brief Broadcasts a datum to all processes.
10490!> \param[in] msg Datum to broadcast
10491!> \param[in] source Processes which broadcasts
10492!> \param[in] comm Message passing environment identifier
10493!> \par MPI mapping
10494!> mpi_bcast
10495! **************************************************************************************************
10496 SUBROUTINE mp_ibcast_l (msg, source, comm, request)
10497 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10498 INTEGER, INTENT(IN) :: source
10499 CLASS(mp_comm_type), INTENT(IN) :: comm
10500 TYPE(mp_request_type), INTENT(OUT) :: request
10501
10502 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_l'
10503
10504 INTEGER :: handle
10505#if defined(__parallel)
10506 INTEGER :: ierr, msglen
10507#endif
10508
10509 CALL mp_timeset(routinen, handle)
10510
10511#if defined(__parallel)
10512 msglen = 1
10513 CALL mpi_ibcast(msg, msglen, mpi_integer8, source, comm%handle, request%handle, ierr)
10514 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
10515 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_8_size)
10516#else
10517 mark_used(msg)
10518 mark_used(source)
10519 mark_used(comm)
10520 request = mp_request_null
10521#endif
10522 CALL mp_timestop(handle)
10523 END SUBROUTINE mp_ibcast_l
10524
10525! **************************************************************************************************
10526!> \brief Broadcasts rank-1 data to all processes
10527!> \param[in] msg Data to broadcast
10528!> \param source ...
10529!> \param comm ...
10530!> \note see mp_bcast_l1
10531! **************************************************************************************************
10532 SUBROUTINE mp_bcast_lv(msg, source, comm)
10533 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10534 INTEGER, INTENT(IN) :: source
10535 CLASS(mp_comm_type), INTENT(IN) :: comm
10536
10537 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lv'
10538
10539 INTEGER :: handle
10540#if defined(__parallel)
10541 INTEGER :: ierr, msglen
10542#endif
10543
10544 CALL mp_timeset(routinen, handle)
10545
10546#if defined(__parallel)
10547 msglen = SIZE(msg)
10548 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10549 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10550 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10551#else
10552 mark_used(msg)
10553 mark_used(source)
10554 mark_used(comm)
10555#endif
10556 CALL mp_timestop(handle)
10557 END SUBROUTINE mp_bcast_lv
10558
10559! **************************************************************************************************
10560!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
10561!> \param[in] msg Data to broadcast
10562!> \param comm ...
10563!> \note see mp_bcast_l1
10564! **************************************************************************************************
10565 SUBROUTINE mp_bcast_lv_src(msg, comm)
10566 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10567 CLASS(mp_comm_type), INTENT(IN) :: comm
10568
10569 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lv_src'
10570
10571 INTEGER :: handle
10572#if defined(__parallel)
10573 INTEGER :: ierr, msglen
10574#endif
10575
10576 CALL mp_timeset(routinen, handle)
10577
10578#if defined(__parallel)
10579 msglen = SIZE(msg)
10580 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10581 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10582 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10583#else
10584 mark_used(msg)
10585 mark_used(comm)
10586#endif
10587 CALL mp_timestop(handle)
10588 END SUBROUTINE mp_bcast_lv_src
10589
10590! **************************************************************************************************
10591!> \brief Broadcasts rank-1 data to all processes
10592!> \param[in] msg Data to broadcast
10593!> \param source ...
10594!> \param comm ...
10595!> \note see mp_bcast_l1
10596! **************************************************************************************************
10597 SUBROUTINE mp_ibcast_lv(msg, source, comm, request)
10598 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
10599 INTEGER, INTENT(IN) :: source
10600 CLASS(mp_comm_type), INTENT(IN) :: comm
10601 TYPE(mp_request_type) :: request
10602
10603 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_lv'
10604
10605 INTEGER :: handle
10606#if defined(__parallel)
10607 INTEGER :: ierr, msglen
10608#endif
10609
10610 CALL mp_timeset(routinen, handle)
10611
10612#if defined(__parallel)
10613#if !defined(__GNUC__) || __GNUC__ >= 9
10614 cpassert(is_contiguous(msg))
10615#endif
10616 msglen = SIZE(msg)
10617 CALL mpi_ibcast(msg, msglen, mpi_integer8, source, comm%handle, request%handle, ierr)
10618 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
10619 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_8_size)
10620#else
10621 mark_used(msg)
10622 mark_used(source)
10623 mark_used(comm)
10624 request = mp_request_null
10625#endif
10626 CALL mp_timestop(handle)
10627 END SUBROUTINE mp_ibcast_lv
10628
10629! **************************************************************************************************
10630!> \brief Broadcasts rank-2 data to all processes
10631!> \param[in] msg Data to broadcast
10632!> \param source ...
10633!> \param comm ...
10634!> \note see mp_bcast_l1
10635! **************************************************************************************************
10636 SUBROUTINE mp_bcast_lm(msg, source, comm)
10637 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10638 INTEGER, INTENT(IN) :: source
10639 CLASS(mp_comm_type), INTENT(IN) :: comm
10640
10641 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lm'
10642
10643 INTEGER :: handle
10644#if defined(__parallel)
10645 INTEGER :: ierr, msglen
10646#endif
10647
10648 CALL mp_timeset(routinen, handle)
10649
10650#if defined(__parallel)
10651 msglen = SIZE(msg)
10652 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10653 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10654 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10655#else
10656 mark_used(msg)
10657 mark_used(source)
10658 mark_used(comm)
10659#endif
10660 CALL mp_timestop(handle)
10661 END SUBROUTINE mp_bcast_lm
10662
10663! **************************************************************************************************
10664!> \brief Broadcasts rank-2 data to all processes
10665!> \param[in] msg Data to broadcast
10666!> \param source ...
10667!> \param comm ...
10668!> \note see mp_bcast_l1
10669! **************************************************************************************************
10670 SUBROUTINE mp_bcast_lm_src(msg, comm)
10671 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10672 CLASS(mp_comm_type), INTENT(IN) :: comm
10673
10674 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lm_src'
10675
10676 INTEGER :: handle
10677#if defined(__parallel)
10678 INTEGER :: ierr, msglen
10679#endif
10680
10681 CALL mp_timeset(routinen, handle)
10682
10683#if defined(__parallel)
10684 msglen = SIZE(msg)
10685 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10686 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10687 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10688#else
10689 mark_used(msg)
10690 mark_used(comm)
10691#endif
10692 CALL mp_timestop(handle)
10693 END SUBROUTINE mp_bcast_lm_src
10694
10695! **************************************************************************************************
10696!> \brief Broadcasts rank-3 data to all processes
10697!> \param[in] msg Data to broadcast
10698!> \param source ...
10699!> \param comm ...
10700!> \note see mp_bcast_l1
10701! **************************************************************************************************
10702 SUBROUTINE mp_bcast_l3(msg, source, comm)
10703 INTEGER(KIND=int_8), CONTIGUOUS :: msg(:, :, :)
10704 INTEGER, INTENT(IN) :: source
10705 CLASS(mp_comm_type), INTENT(IN) :: comm
10706
10707 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l3'
10708
10709 INTEGER :: handle
10710#if defined(__parallel)
10711 INTEGER :: ierr, msglen
10712#endif
10713
10714 CALL mp_timeset(routinen, handle)
10715
10716#if defined(__parallel)
10717 msglen = SIZE(msg)
10718 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10719 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10720 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10721#else
10722 mark_used(msg)
10723 mark_used(source)
10724 mark_used(comm)
10725#endif
10726 CALL mp_timestop(handle)
10727 END SUBROUTINE mp_bcast_l3
10728
10729! **************************************************************************************************
10730!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
10731!> \param[in] msg Data to broadcast
10732!> \param source ...
10733!> \param comm ...
10734!> \note see mp_bcast_l1
10735! **************************************************************************************************
10736 SUBROUTINE mp_bcast_l3_src(msg, comm)
10737 INTEGER(KIND=int_8), CONTIGUOUS :: msg(:, :, :)
10738 CLASS(mp_comm_type), INTENT(IN) :: comm
10739
10740 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l3_src'
10741
10742 INTEGER :: handle
10743#if defined(__parallel)
10744 INTEGER :: ierr, msglen
10745#endif
10746
10747 CALL mp_timeset(routinen, handle)
10748
10749#if defined(__parallel)
10750 msglen = SIZE(msg)
10751 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10752 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10753 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10754#else
10755 mark_used(msg)
10756 mark_used(comm)
10757#endif
10758 CALL mp_timestop(handle)
10759 END SUBROUTINE mp_bcast_l3_src
10760
10761! **************************************************************************************************
10762!> \brief Sums a datum from all processes with result left on all processes.
10763!> \param[in,out] msg Datum to sum (input) and result (output)
10764!> \param[in] comm Message passing environment identifier
10765!> \par MPI mapping
10766!> mpi_allreduce
10767! **************************************************************************************************
10768 SUBROUTINE mp_sum_l (msg, comm)
10769 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10770 CLASS(mp_comm_type), INTENT(IN) :: comm
10771
10772 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_l'
10773
10774 INTEGER :: handle
10775#if defined(__parallel)
10776 INTEGER :: ierr, msglen
10777#endif
10778
10779 CALL mp_timeset(routinen, handle)
10780
10781#if defined(__parallel)
10782 msglen = 1
10783 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10784 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10785 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10786#else
10787 mark_used(msg)
10788 mark_used(comm)
10789#endif
10790 CALL mp_timestop(handle)
10791 END SUBROUTINE mp_sum_l
10792
10793! **************************************************************************************************
10794!> \brief Element-wise sum of a rank-1 array on all processes.
10795!> \param[in,out] msg Vector to sum and result
10796!> \param comm ...
10797!> \note see mp_sum_l
10798! **************************************************************************************************
10799 SUBROUTINE mp_sum_lv(msg, comm)
10800 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10801 CLASS(mp_comm_type), INTENT(IN) :: comm
10802
10803 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lv'
10804
10805 INTEGER :: handle
10806#if defined(__parallel)
10807 INTEGER :: ierr, msglen
10808#endif
10809
10810 CALL mp_timeset(routinen, handle)
10811
10812#if defined(__parallel)
10813 msglen = SIZE(msg)
10814 IF (msglen > 0) THEN
10815 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10816 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10817 END IF
10818 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10819#else
10820 mark_used(msg)
10821 mark_used(comm)
10822#endif
10823 CALL mp_timestop(handle)
10824 END SUBROUTINE mp_sum_lv
10825
10826! **************************************************************************************************
10827!> \brief Element-wise sum of a rank-1 array on all processes.
10828!> \param[in,out] msg Vector to sum and result
10829!> \param comm ...
10830!> \note see mp_sum_l
10831! **************************************************************************************************
10832 SUBROUTINE mp_isum_lv(msg, comm, request)
10833 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
10834 CLASS(mp_comm_type), INTENT(IN) :: comm
10835 TYPE(mp_request_type), INTENT(OUT) :: request
10836
10837 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_lv'
10838
10839 INTEGER :: handle
10840#if defined(__parallel)
10841 INTEGER :: ierr, msglen
10842#endif
10843
10844 CALL mp_timeset(routinen, handle)
10845
10846#if defined(__parallel)
10847#if !defined(__GNUC__) || __GNUC__ >= 9
10848 cpassert(is_contiguous(msg))
10849#endif
10850 msglen = SIZE(msg)
10851 IF (msglen > 0) THEN
10852 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, request%handle, ierr)
10853 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
10854 ELSE
10855 request = mp_request_null
10856 END IF
10857 CALL add_perf(perf_id=23, count=1, msg_size=msglen*int_8_size)
10858#else
10859 mark_used(msg)
10860 mark_used(comm)
10861 request = mp_request_null
10862#endif
10863 CALL mp_timestop(handle)
10864 END SUBROUTINE mp_isum_lv
10865
10866! **************************************************************************************************
10867!> \brief Element-wise sum of a rank-2 array on all processes.
10868!> \param[in] msg Matrix to sum and result
10869!> \param comm ...
10870!> \note see mp_sum_l
10871! **************************************************************************************************
10872 SUBROUTINE mp_sum_lm(msg, comm)
10873 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10874 CLASS(mp_comm_type), INTENT(IN) :: comm
10875
10876 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm'
10877
10878 INTEGER :: handle
10879#if defined(__parallel)
10880 INTEGER, PARAMETER :: max_msg = 2**25
10881 INTEGER :: ierr, m1, msglen, step, msglensum
10882#endif
10883
10884 CALL mp_timeset(routinen, handle)
10885
10886#if defined(__parallel)
10887 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
10888 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
10889 msglensum = 0
10890 DO m1 = lbound(msg, 2), ubound(msg, 2), step
10891 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
10892 msglensum = msglensum + msglen
10893 IF (msglen > 0) THEN
10894 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10895 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10896 END IF
10897 END DO
10898 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_8_size)
10899#else
10900 mark_used(msg)
10901 mark_used(comm)
10902#endif
10903 CALL mp_timestop(handle)
10904 END SUBROUTINE mp_sum_lm
10905
10906! **************************************************************************************************
10907!> \brief Element-wise sum of a rank-3 array on all processes.
10908!> \param[in] msg Array to sum and result
10909!> \param comm ...
10910!> \note see mp_sum_l
10911! **************************************************************************************************
10912 SUBROUTINE mp_sum_lm3(msg, comm)
10913 INTEGER(KIND=int_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
10914 CLASS(mp_comm_type), INTENT(IN) :: comm
10915
10916 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm3'
10917
10918 INTEGER :: handle
10919#if defined(__parallel)
10920 INTEGER :: ierr, msglen
10921#endif
10922
10923 CALL mp_timeset(routinen, handle)
10924
10925#if defined(__parallel)
10926 msglen = SIZE(msg)
10927 IF (msglen > 0) THEN
10928 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10929 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10930 END IF
10931 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10932#else
10933 mark_used(msg)
10934 mark_used(comm)
10935#endif
10936 CALL mp_timestop(handle)
10937 END SUBROUTINE mp_sum_lm3
10938
10939! **************************************************************************************************
10940!> \brief Element-wise sum of a rank-4 array on all processes.
10941!> \param[in] msg Array to sum and result
10942!> \param comm ...
10943!> \note see mp_sum_l
10944! **************************************************************************************************
10945 SUBROUTINE mp_sum_lm4(msg, comm)
10946 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
10947 CLASS(mp_comm_type), INTENT(IN) :: comm
10948
10949 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm4'
10950
10951 INTEGER :: handle
10952#if defined(__parallel)
10953 INTEGER :: ierr, msglen
10954#endif
10955
10956 CALL mp_timeset(routinen, handle)
10957
10958#if defined(__parallel)
10959 msglen = SIZE(msg)
10960 IF (msglen > 0) THEN
10961 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10962 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10963 END IF
10964 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10965#else
10966 mark_used(msg)
10967 mark_used(comm)
10968#endif
10969 CALL mp_timestop(handle)
10970 END SUBROUTINE mp_sum_lm4
10971
10972! **************************************************************************************************
10973!> \brief Element-wise sum of data from all processes with result left only on
10974!> one.
10975!> \param[in,out] msg Vector to sum (input) and (only on process root)
10976!> result (output)
10977!> \param root ...
10978!> \param[in] comm Message passing environment identifier
10979!> \par MPI mapping
10980!> mpi_reduce
10981! **************************************************************************************************
10982 SUBROUTINE mp_sum_root_lv(msg, root, comm)
10983 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10984 INTEGER, INTENT(IN) :: root
10985 CLASS(mp_comm_type), INTENT(IN) :: comm
10986
10987 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_lv'
10988
10989 INTEGER :: handle
10990#if defined(__parallel)
10991 INTEGER :: ierr, m1, msglen, taskid
10992 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
10993#endif
10994
10995 CALL mp_timeset(routinen, handle)
10996
10997#if defined(__parallel)
10998 msglen = SIZE(msg)
10999 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11000 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11001 IF (msglen > 0) THEN
11002 m1 = SIZE(msg, 1)
11003 ALLOCATE (res(m1))
11004 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_sum, &
11005 root, comm%handle, ierr)
11006 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11007 IF (taskid == root) THEN
11008 msg = res
11009 END IF
11010 DEALLOCATE (res)
11011 END IF
11012 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11013#else
11014 mark_used(msg)
11015 mark_used(root)
11016 mark_used(comm)
11017#endif
11018 CALL mp_timestop(handle)
11019 END SUBROUTINE mp_sum_root_lv
11020
11021! **************************************************************************************************
11022!> \brief Element-wise sum of data from all processes with result left only on
11023!> one.
11024!> \param[in,out] msg Matrix to sum (input) and (only on process root)
11025!> result (output)
11026!> \param root ...
11027!> \param comm ...
11028!> \note see mp_sum_root_lv
11029! **************************************************************************************************
11030 SUBROUTINE mp_sum_root_lm(msg, root, comm)
11031 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11032 INTEGER, INTENT(IN) :: root
11033 CLASS(mp_comm_type), INTENT(IN) :: comm
11034
11035 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
11036
11037 INTEGER :: handle
11038#if defined(__parallel)
11039 INTEGER :: ierr, m1, m2, msglen, taskid
11040 INTEGER(KIND=int_8), ALLOCATABLE :: res(:, :)
11041#endif
11042
11043 CALL mp_timeset(routinen, handle)
11044
11045#if defined(__parallel)
11046 msglen = SIZE(msg)
11047 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11048 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11049 IF (msglen > 0) THEN
11050 m1 = SIZE(msg, 1)
11051 m2 = SIZE(msg, 2)
11052 ALLOCATE (res(m1, m2))
11053 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_sum, root, comm%handle, ierr)
11054 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11055 IF (taskid == root) THEN
11056 msg = res
11057 END IF
11058 DEALLOCATE (res)
11059 END IF
11060 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11061#else
11062 mark_used(root)
11063 mark_used(msg)
11064 mark_used(comm)
11065#endif
11066 CALL mp_timestop(handle)
11067 END SUBROUTINE mp_sum_root_lm
11068
11069! **************************************************************************************************
11070!> \brief Partial sum of data from all processes with result on each process.
11071!> \param[in] msg Matrix to sum (input)
11072!> \param[out] res Matrix containing result (output)
11073!> \param[in] comm Message passing environment identifier
11074! **************************************************************************************************
11075 SUBROUTINE mp_sum_partial_lm(msg, res, comm)
11076 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11077 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
11078 CLASS(mp_comm_type), INTENT(IN) :: comm
11079
11080 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_lm'
11081
11082 INTEGER :: handle
11083#if defined(__parallel)
11084 INTEGER :: ierr, msglen, taskid
11085#endif
11086
11087 CALL mp_timeset(routinen, handle)
11088
11089#if defined(__parallel)
11090 msglen = SIZE(msg)
11091 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11092 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11093 IF (msglen > 0) THEN
11094 CALL mpi_scan(msg, res, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11095 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
11096 END IF
11097 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11098 ! perf_id is same as for other summation routines
11099#else
11100 res = msg
11101 mark_used(comm)
11102#endif
11103 CALL mp_timestop(handle)
11104 END SUBROUTINE mp_sum_partial_lm
11105
11106! **************************************************************************************************
11107!> \brief Finds the maximum of a datum with the result left on all processes.
11108!> \param[in,out] msg Find maximum among these data (input) and
11109!> maximum (output)
11110!> \param[in] comm Message passing environment identifier
11111!> \par MPI mapping
11112!> mpi_allreduce
11113! **************************************************************************************************
11114 SUBROUTINE mp_max_l (msg, comm)
11115 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11116 CLASS(mp_comm_type), INTENT(IN) :: comm
11117
11118 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_l'
11119
11120 INTEGER :: handle
11121#if defined(__parallel)
11122 INTEGER :: ierr, msglen
11123#endif
11124
11125 CALL mp_timeset(routinen, handle)
11126
11127#if defined(__parallel)
11128 msglen = 1
11129 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11130 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11131 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11132#else
11133 mark_used(msg)
11134 mark_used(comm)
11135#endif
11136 CALL mp_timestop(handle)
11137 END SUBROUTINE mp_max_l
11138
11139! **************************************************************************************************
11140!> \brief Finds the maximum of a datum with the result left on all processes.
11141!> \param[in,out] msg Find maximum among these data (input) and
11142!> maximum (output)
11143!> \param[in] comm Message passing environment identifier
11144!> \par MPI mapping
11145!> mpi_allreduce
11146! **************************************************************************************************
11147 SUBROUTINE mp_max_root_l (msg, root, comm)
11148 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11149 INTEGER, INTENT(IN) :: root
11150 CLASS(mp_comm_type), INTENT(IN) :: comm
11151
11152 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_l'
11153
11154 INTEGER :: handle
11155#if defined(__parallel)
11156 INTEGER :: ierr, msglen
11157 INTEGER(KIND=int_8) :: res
11158#endif
11159
11160 CALL mp_timeset(routinen, handle)
11161
11162#if defined(__parallel)
11163 msglen = 1
11164 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_max, root, comm%handle, ierr)
11165 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11166 IF (root == comm%mepos) msg = res
11167 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11168#else
11169 mark_used(msg)
11170 mark_used(comm)
11171 mark_used(root)
11172#endif
11173 CALL mp_timestop(handle)
11174 END SUBROUTINE mp_max_root_l
11175
11176! **************************************************************************************************
11177!> \brief Finds the element-wise maximum of a vector with the result left on
11178!> all processes.
11179!> \param[in,out] msg Find maximum among these data (input) and
11180!> maximum (output)
11181!> \param comm ...
11182!> \note see mp_max_l
11183! **************************************************************************************************
11184 SUBROUTINE mp_max_lv(msg, comm)
11185 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
11186 CLASS(mp_comm_type), INTENT(IN) :: comm
11187
11188 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_lv'
11189
11190 INTEGER :: handle
11191#if defined(__parallel)
11192 INTEGER :: ierr, msglen
11193#endif
11194
11195 CALL mp_timeset(routinen, handle)
11196
11197#if defined(__parallel)
11198 msglen = SIZE(msg)
11199 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11200 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11201 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11202#else
11203 mark_used(msg)
11204 mark_used(comm)
11205#endif
11206 CALL mp_timestop(handle)
11207 END SUBROUTINE mp_max_lv
11208
11209! **************************************************************************************************
11210!> \brief Finds the element-wise maximum of a vector with the result left on
11211!> all processes.
11212!> \param[in,out] msg Find maximum among these data (input) and
11213!> maximum (output)
11214!> \param comm ...
11215!> \note see mp_max_l
11216! **************************************************************************************************
11217 SUBROUTINE mp_max_root_lm(msg, root, comm)
11218 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11219 INTEGER :: root
11220 CLASS(mp_comm_type), INTENT(IN) :: comm
11221
11222 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_lm'
11223
11224 INTEGER :: handle
11225#if defined(__parallel)
11226 INTEGER :: ierr, msglen
11227 INTEGER(KIND=int_8) :: res(size(msg, 1), size(msg, 2))
11228#endif
11229
11230 CALL mp_timeset(routinen, handle)
11231
11232#if defined(__parallel)
11233 msglen = SIZE(msg)
11234 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_max, root, comm%handle, ierr)
11235 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11236 IF (root == comm%mepos) msg = res
11237 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11238#else
11239 mark_used(msg)
11240 mark_used(comm)
11241 mark_used(root)
11242#endif
11243 CALL mp_timestop(handle)
11244 END SUBROUTINE mp_max_root_lm
11245
11246! **************************************************************************************************
11247!> \brief Finds the minimum of a datum with the result left on all processes.
11248!> \param[in,out] msg Find minimum among these data (input) and
11249!> maximum (output)
11250!> \param[in] comm Message passing environment identifier
11251!> \par MPI mapping
11252!> mpi_allreduce
11253! **************************************************************************************************
11254 SUBROUTINE mp_min_l (msg, comm)
11255 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11256 CLASS(mp_comm_type), INTENT(IN) :: comm
11257
11258 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_l'
11259
11260 INTEGER :: handle
11261#if defined(__parallel)
11262 INTEGER :: ierr, msglen
11263#endif
11264
11265 CALL mp_timeset(routinen, handle)
11266
11267#if defined(__parallel)
11268 msglen = 1
11269 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11270 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11271 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11272#else
11273 mark_used(msg)
11274 mark_used(comm)
11275#endif
11276 CALL mp_timestop(handle)
11277 END SUBROUTINE mp_min_l
11278
11279! **************************************************************************************************
11280!> \brief Finds the element-wise minimum of vector with the result left on
11281!> all processes.
11282!> \param[in,out] msg Find minimum among these data (input) and
11283!> maximum (output)
11284!> \param comm ...
11285!> \par MPI mapping
11286!> mpi_allreduce
11287!> \note see mp_min_l
11288! **************************************************************************************************
11289 SUBROUTINE mp_min_lv(msg, comm)
11290 INTEGER(KIND=int_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
11291 CLASS(mp_comm_type), INTENT(IN) :: comm
11292
11293 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_lv'
11294
11295 INTEGER :: handle
11296#if defined(__parallel)
11297 INTEGER :: ierr, msglen
11298#endif
11299
11300 CALL mp_timeset(routinen, handle)
11301
11302#if defined(__parallel)
11303 msglen = SIZE(msg)
11304 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11305 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11306 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11307#else
11308 mark_used(msg)
11309 mark_used(comm)
11310#endif
11311 CALL mp_timestop(handle)
11312 END SUBROUTINE mp_min_lv
11313
11314! **************************************************************************************************
11315!> \brief Multiplies a set of numbers scattered across a number of processes,
11316!> then replicates the result.
11317!> \param[in,out] msg a number to multiply (input) and result (output)
11318!> \param[in] comm message passing environment identifier
11319!> \par MPI mapping
11320!> mpi_allreduce
11321! **************************************************************************************************
11322 SUBROUTINE mp_prod_l (msg, comm)
11323 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11324 CLASS(mp_comm_type), INTENT(IN) :: comm
11325
11326 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_l'
11327
11328 INTEGER :: handle
11329#if defined(__parallel)
11330 INTEGER :: ierr, msglen
11331#endif
11332
11333 CALL mp_timeset(routinen, handle)
11334
11335#if defined(__parallel)
11336 msglen = 1
11337 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_prod, comm%handle, ierr)
11338 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
11344 CALL mp_timestop(handle)
11345 END SUBROUTINE mp_prod_l
11346
11347! **************************************************************************************************
11348!> \brief Scatters data from one processes to all others
11349!> \param[in] msg_scatter Data to scatter (for root process)
11350!> \param[out] msg Received data
11351!> \param[in] root Process which scatters data
11352!> \param[in] comm Message passing environment identifier
11353!> \par MPI mapping
11354!> mpi_scatter
11355! **************************************************************************************************
11356 SUBROUTINE mp_scatter_lv(msg_scatter, msg, root, comm)
11357 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
11358 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
11359 INTEGER, INTENT(IN) :: root
11360 CLASS(mp_comm_type), INTENT(IN) :: comm
11361
11362 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_lv'
11363
11364 INTEGER :: handle
11365#if defined(__parallel)
11366 INTEGER :: ierr, msglen
11367#endif
11368
11369 CALL mp_timeset(routinen, handle)
11370
11371#if defined(__parallel)
11372 msglen = SIZE(msg)
11373 CALL mpi_scatter(msg_scatter, msglen, mpi_integer8, msg, &
11374 msglen, mpi_integer8, root, comm%handle, ierr)
11375 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
11376 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11377#else
11378 mark_used(root)
11379 mark_used(comm)
11380 msg = msg_scatter
11381#endif
11382 CALL mp_timestop(handle)
11383 END SUBROUTINE mp_scatter_lv
11384
11385! **************************************************************************************************
11386!> \brief Scatters data from one processes to all others
11387!> \param[in] msg_scatter Data to scatter (for root process)
11388!> \param[in] root Process which scatters data
11389!> \param[in] comm Message passing environment identifier
11390!> \par MPI mapping
11391!> mpi_scatter
11392! **************************************************************************************************
11393 SUBROUTINE mp_iscatter_l (msg_scatter, msg, root, comm, request)
11394 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:)
11395 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11396 INTEGER, INTENT(IN) :: root
11397 CLASS(mp_comm_type), INTENT(IN) :: comm
11398 TYPE(mp_request_type), INTENT(OUT) :: request
11399
11400 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_l'
11401
11402 INTEGER :: handle
11403#if defined(__parallel)
11404 INTEGER :: ierr, msglen
11405#endif
11406
11407 CALL mp_timeset(routinen, handle)
11408
11409#if defined(__parallel)
11410#if !defined(__GNUC__) || __GNUC__ >= 9
11411 cpassert(is_contiguous(msg_scatter))
11412#endif
11413 msglen = 1
11414 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer8, msg, &
11415 msglen, mpi_integer8, root, comm%handle, request%handle, ierr)
11416 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
11417 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11418#else
11419 mark_used(root)
11420 mark_used(comm)
11421 msg = msg_scatter(1)
11422 request = mp_request_null
11423#endif
11424 CALL mp_timestop(handle)
11425 END SUBROUTINE mp_iscatter_l
11426
11427! **************************************************************************************************
11428!> \brief Scatters data from one processes to all others
11429!> \param[in] msg_scatter Data to scatter (for root process)
11430!> \param[in] root Process which scatters data
11431!> \param[in] comm Message passing environment identifier
11432!> \par MPI mapping
11433!> mpi_scatter
11434! **************************************************************************************************
11435 SUBROUTINE mp_iscatter_lv2(msg_scatter, msg, root, comm, request)
11436 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:, :)
11437 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11438 INTEGER, INTENT(IN) :: root
11439 CLASS(mp_comm_type), INTENT(IN) :: comm
11440 TYPE(mp_request_type), INTENT(OUT) :: request
11441
11442 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_lv2'
11443
11444 INTEGER :: handle
11445#if defined(__parallel)
11446 INTEGER :: ierr, msglen
11447#endif
11448
11449 CALL mp_timeset(routinen, handle)
11450
11451#if defined(__parallel)
11452#if !defined(__GNUC__) || __GNUC__ >= 9
11453 cpassert(is_contiguous(msg_scatter))
11454#endif
11455 msglen = SIZE(msg)
11456 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer8, msg, &
11457 msglen, mpi_integer8, root, comm%handle, request%handle, ierr)
11458 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
11459 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11460#else
11461 mark_used(root)
11462 mark_used(comm)
11463 msg(:) = msg_scatter(:, 1)
11464 request = mp_request_null
11465#endif
11466 CALL mp_timestop(handle)
11467 END SUBROUTINE mp_iscatter_lv2
11468
11469! **************************************************************************************************
11470!> \brief Scatters data from one processes to all others
11471!> \param[in] msg_scatter Data to scatter (for root process)
11472!> \param[in] root Process which scatters data
11473!> \param[in] comm Message passing environment identifier
11474!> \par MPI mapping
11475!> mpi_scatter
11476! **************************************************************************************************
11477 SUBROUTINE mp_iscatterv_lv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
11478 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:)
11479 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
11480 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11481 INTEGER, INTENT(IN) :: recvcount, root
11482 CLASS(mp_comm_type), INTENT(IN) :: comm
11483 TYPE(mp_request_type), INTENT(OUT) :: request
11484
11485 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_lv'
11486
11487 INTEGER :: handle
11488#if defined(__parallel)
11489 INTEGER :: ierr
11490#endif
11491
11492 CALL mp_timeset(routinen, handle)
11493
11494#if defined(__parallel)
11495#if !defined(__GNUC__) || __GNUC__ >= 9
11496 cpassert(is_contiguous(msg_scatter))
11497 cpassert(is_contiguous(msg))
11498 cpassert(is_contiguous(sendcounts))
11499 cpassert(is_contiguous(displs))
11500#endif
11501 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_integer8, msg, &
11502 recvcount, mpi_integer8, root, comm%handle, request%handle, ierr)
11503 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
11504 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11505#else
11506 mark_used(sendcounts)
11507 mark_used(displs)
11508 mark_used(recvcount)
11509 mark_used(root)
11510 mark_used(comm)
11511 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
11512 request = mp_request_null
11513#endif
11514 CALL mp_timestop(handle)
11515 END SUBROUTINE mp_iscatterv_lv
11516
11517! **************************************************************************************************
11518!> \brief Gathers a datum from all processes to one
11519!> \param[in] msg Datum to send to root
11520!> \param[out] msg_gather Received data (on root)
11521!> \param[in] root Process which gathers the data
11522!> \param[in] comm Message passing environment identifier
11523!> \par MPI mapping
11524!> mpi_gather
11525! **************************************************************************************************
11526 SUBROUTINE mp_gather_l (msg, msg_gather, root, comm)
11527 INTEGER(KIND=int_8), INTENT(IN) :: msg
11528 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11529 INTEGER, INTENT(IN) :: root
11530 CLASS(mp_comm_type), INTENT(IN) :: comm
11531
11532 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_l'
11533
11534 INTEGER :: handle
11535#if defined(__parallel)
11536 INTEGER :: ierr, msglen
11537#endif
11538
11539 CALL mp_timeset(routinen, handle)
11540
11541#if defined(__parallel)
11542 msglen = 1
11543 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11544 msglen, mpi_integer8, root, comm%handle, ierr)
11545 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11546 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11547#else
11548 mark_used(root)
11549 mark_used(comm)
11550 msg_gather(1) = msg
11551#endif
11552 CALL mp_timestop(handle)
11553 END SUBROUTINE mp_gather_l
11554
11555! **************************************************************************************************
11556!> \brief Gathers a datum from all processes to one, uses the source process of comm
11557!> \param[in] msg Datum to send to root
11558!> \param[out] msg_gather Received data (on root)
11559!> \param[in] comm Message passing environment identifier
11560!> \par MPI mapping
11561!> mpi_gather
11562! **************************************************************************************************
11563 SUBROUTINE mp_gather_l_src(msg, msg_gather, comm)
11564 INTEGER(KIND=int_8), INTENT(IN) :: msg
11565 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11566 CLASS(mp_comm_type), INTENT(IN) :: comm
11567
11568 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_l_src'
11569
11570 INTEGER :: handle
11571#if defined(__parallel)
11572 INTEGER :: ierr, msglen
11573#endif
11574
11575 CALL mp_timeset(routinen, handle)
11576
11577#if defined(__parallel)
11578 msglen = 1
11579 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11580 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11581 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11582 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11583#else
11584 mark_used(comm)
11585 msg_gather(1) = msg
11586#endif
11587 CALL mp_timestop(handle)
11588 END SUBROUTINE mp_gather_l_src
11589
11590! **************************************************************************************************
11591!> \brief Gathers data from all processes to one
11592!> \param[in] msg Datum to send to root
11593!> \param msg_gather ...
11594!> \param root ...
11595!> \param comm ...
11596!> \par Data length
11597!> All data (msg) is equal-sized
11598!> \par MPI mapping
11599!> mpi_gather
11600!> \note see mp_gather_l
11601! **************************************************************************************************
11602 SUBROUTINE mp_gather_lv(msg, msg_gather, root, comm)
11603 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
11604 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11605 INTEGER, INTENT(IN) :: root
11606 CLASS(mp_comm_type), INTENT(IN) :: comm
11607
11608 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lv'
11609
11610 INTEGER :: handle
11611#if defined(__parallel)
11612 INTEGER :: ierr, msglen
11613#endif
11614
11615 CALL mp_timeset(routinen, handle)
11616
11617#if defined(__parallel)
11618 msglen = SIZE(msg)
11619 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11620 msglen, mpi_integer8, root, comm%handle, ierr)
11621 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11622 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11623#else
11624 mark_used(root)
11625 mark_used(comm)
11626 msg_gather = msg
11627#endif
11628 CALL mp_timestop(handle)
11629 END SUBROUTINE mp_gather_lv
11630
11631! **************************************************************************************************
11632!> \brief Gathers data from all processes to one. Gathers from comm%source
11633!> \param[in] msg Datum to send to root
11634!> \param msg_gather ...
11635!> \param comm ...
11636!> \par Data length
11637!> All data (msg) is equal-sized
11638!> \par MPI mapping
11639!> mpi_gather
11640!> \note see mp_gather_l
11641! **************************************************************************************************
11642 SUBROUTINE mp_gather_lv_src(msg, msg_gather, comm)
11643 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
11644 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11645 CLASS(mp_comm_type), INTENT(IN) :: comm
11646
11647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lv_src'
11648
11649 INTEGER :: handle
11650#if defined(__parallel)
11651 INTEGER :: ierr, msglen
11652#endif
11653
11654 CALL mp_timeset(routinen, handle)
11655
11656#if defined(__parallel)
11657 msglen = SIZE(msg)
11658 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11659 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11660 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11661 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11662#else
11663 mark_used(comm)
11664 msg_gather = msg
11665#endif
11666 CALL mp_timestop(handle)
11667 END SUBROUTINE mp_gather_lv_src
11668
11669! **************************************************************************************************
11670!> \brief Gathers data from all processes to one
11671!> \param[in] msg Datum to send to root
11672!> \param msg_gather ...
11673!> \param root ...
11674!> \param comm ...
11675!> \par Data length
11676!> All data (msg) is equal-sized
11677!> \par MPI mapping
11678!> mpi_gather
11679!> \note see mp_gather_l
11680! **************************************************************************************************
11681 SUBROUTINE mp_gather_lm(msg, msg_gather, root, comm)
11682 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11683 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
11684 INTEGER, INTENT(IN) :: root
11685 CLASS(mp_comm_type), INTENT(IN) :: comm
11686
11687 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lm'
11688
11689 INTEGER :: handle
11690#if defined(__parallel)
11691 INTEGER :: ierr, msglen
11692#endif
11693
11694 CALL mp_timeset(routinen, handle)
11695
11696#if defined(__parallel)
11697 msglen = SIZE(msg)
11698 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11699 msglen, mpi_integer8, root, comm%handle, ierr)
11700 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11701 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11702#else
11703 mark_used(root)
11704 mark_used(comm)
11705 msg_gather = msg
11706#endif
11707 CALL mp_timestop(handle)
11708 END SUBROUTINE mp_gather_lm
11709
11710! **************************************************************************************************
11711!> \brief Gathers data from all processes to one. Gathers from comm%source
11712!> \param[in] msg Datum to send to root
11713!> \param msg_gather ...
11714!> \param comm ...
11715!> \par Data length
11716!> All data (msg) is equal-sized
11717!> \par MPI mapping
11718!> mpi_gather
11719!> \note see mp_gather_l
11720! **************************************************************************************************
11721 SUBROUTINE mp_gather_lm_src(msg, msg_gather, comm)
11722 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11723 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
11724 CLASS(mp_comm_type), INTENT(IN) :: comm
11725
11726 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lm_src'
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 msglen = SIZE(msg)
11737 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11738 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11739 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11740 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11741#else
11742 mark_used(comm)
11743 msg_gather = msg
11744#endif
11745 CALL mp_timestop(handle)
11746 END SUBROUTINE mp_gather_lm_src
11747
11748! **************************************************************************************************
11749!> \brief Gathers data from all processes to one.
11750!> \param[in] sendbuf Data to send to root
11751!> \param[out] recvbuf Received data (on root)
11752!> \param[in] recvcounts Sizes of data received from processes
11753!> \param[in] displs Offsets of data received from processes
11754!> \param[in] root Process which gathers the data
11755!> \param[in] comm Message passing environment identifier
11756!> \par Data length
11757!> Data can have different lengths
11758!> \par Offsets
11759!> Offsets start at 0
11760!> \par MPI mapping
11761!> mpi_gather
11762! **************************************************************************************************
11763 SUBROUTINE mp_gatherv_lv(sendbuf, recvbuf, recvcounts, displs, root, comm)
11764
11765 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
11766 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
11767 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
11768 INTEGER, INTENT(IN) :: root
11769 CLASS(mp_comm_type), INTENT(IN) :: comm
11770
11771 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lv'
11772
11773 INTEGER :: handle
11774#if defined(__parallel)
11775 INTEGER :: ierr, sendcount
11776#endif
11777
11778 CALL mp_timeset(routinen, handle)
11779
11780#if defined(__parallel)
11781 sendcount = SIZE(sendbuf)
11782 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
11783 recvbuf, recvcounts, displs, mpi_integer8, &
11784 root, comm%handle, ierr)
11785 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
11786 CALL add_perf(perf_id=4, &
11787 count=1, &
11788 msg_size=sendcount*int_8_size)
11789#else
11790 mark_used(recvcounts)
11791 mark_used(root)
11792 mark_used(comm)
11793 recvbuf(1 + displs(1):) = sendbuf
11794#endif
11795 CALL mp_timestop(handle)
11796 END SUBROUTINE mp_gatherv_lv
11797
11798! **************************************************************************************************
11799!> \brief Gathers data from all processes to one. Gathers from comm%source
11800!> \param[in] sendbuf Data to send to root
11801!> \param[out] recvbuf Received data (on root)
11802!> \param[in] recvcounts Sizes of data received from processes
11803!> \param[in] displs Offsets of data received from processes
11804!> \param[in] comm Message passing environment identifier
11805!> \par Data length
11806!> Data can have different lengths
11807!> \par Offsets
11808!> Offsets start at 0
11809!> \par MPI mapping
11810!> mpi_gather
11811! **************************************************************************************************
11812 SUBROUTINE mp_gatherv_lv_src(sendbuf, recvbuf, recvcounts, displs, comm)
11813
11814 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
11815 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
11816 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
11817 CLASS(mp_comm_type), INTENT(IN) :: comm
11818
11819 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lv_src'
11820
11821 INTEGER :: handle
11822#if defined(__parallel)
11823 INTEGER :: ierr, sendcount
11824#endif
11825
11826 CALL mp_timeset(routinen, handle)
11827
11828#if defined(__parallel)
11829 sendcount = SIZE(sendbuf)
11830 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
11831 recvbuf, recvcounts, displs, mpi_integer8, &
11832 comm%source, comm%handle, ierr)
11833 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
11834 CALL add_perf(perf_id=4, &
11835 count=1, &
11836 msg_size=sendcount*int_8_size)
11837#else
11838 mark_used(recvcounts)
11839 mark_used(comm)
11840 recvbuf(1 + displs(1):) = sendbuf
11841#endif
11842 CALL mp_timestop(handle)
11843 END SUBROUTINE mp_gatherv_lv_src
11844
11845! **************************************************************************************************
11846!> \brief Gathers data from all processes to one.
11847!> \param[in] sendbuf Data to send to root
11848!> \param[out] recvbuf Received data (on root)
11849!> \param[in] recvcounts Sizes of data received from processes
11850!> \param[in] displs Offsets of data received from processes
11851!> \param[in] root Process which gathers the data
11852!> \param[in] comm Message passing environment identifier
11853!> \par Data length
11854!> Data can have different lengths
11855!> \par Offsets
11856!> Offsets start at 0
11857!> \par MPI mapping
11858!> mpi_gather
11859! **************************************************************************************************
11860 SUBROUTINE mp_gatherv_lm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
11861
11862 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
11863 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
11864 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
11865 INTEGER, INTENT(IN) :: root
11866 CLASS(mp_comm_type), INTENT(IN) :: comm
11867
11868 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lm2'
11869
11870 INTEGER :: handle
11871#if defined(__parallel)
11872 INTEGER :: ierr, sendcount
11873#endif
11874
11875 CALL mp_timeset(routinen, handle)
11876
11877#if defined(__parallel)
11878 sendcount = SIZE(sendbuf)
11879 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
11880 recvbuf, recvcounts, displs, mpi_integer8, &
11881 root, comm%handle, ierr)
11882 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
11883 CALL add_perf(perf_id=4, &
11884 count=1, &
11885 msg_size=sendcount*int_8_size)
11886#else
11887 mark_used(recvcounts)
11888 mark_used(root)
11889 mark_used(comm)
11890 recvbuf(:, 1 + displs(1):) = sendbuf
11891#endif
11892 CALL mp_timestop(handle)
11893 END SUBROUTINE mp_gatherv_lm2
11894
11895! **************************************************************************************************
11896!> \brief Gathers data from all processes to one.
11897!> \param[in] sendbuf Data to send to root
11898!> \param[out] recvbuf Received data (on root)
11899!> \param[in] recvcounts Sizes of data received from processes
11900!> \param[in] displs Offsets of data received from processes
11901!> \param[in] comm Message passing environment identifier
11902!> \par Data length
11903!> Data can have different lengths
11904!> \par Offsets
11905!> Offsets start at 0
11906!> \par MPI mapping
11907!> mpi_gather
11908! **************************************************************************************************
11909 SUBROUTINE mp_gatherv_lm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
11910
11911 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
11912 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
11913 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
11914 CLASS(mp_comm_type), INTENT(IN) :: comm
11915
11916 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lm2_src'
11917
11918 INTEGER :: handle
11919#if defined(__parallel)
11920 INTEGER :: ierr, sendcount
11921#endif
11922
11923 CALL mp_timeset(routinen, handle)
11924
11925#if defined(__parallel)
11926 sendcount = SIZE(sendbuf)
11927 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
11928 recvbuf, recvcounts, displs, mpi_integer8, &
11929 comm%source, comm%handle, ierr)
11930 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
11931 CALL add_perf(perf_id=4, &
11932 count=1, &
11933 msg_size=sendcount*int_8_size)
11934#else
11935 mark_used(recvcounts)
11936 mark_used(comm)
11937 recvbuf(:, 1 + displs(1):) = sendbuf
11938#endif
11939 CALL mp_timestop(handle)
11940 END SUBROUTINE mp_gatherv_lm2_src
11941
11942! **************************************************************************************************
11943!> \brief Gathers data from all processes to one.
11944!> \param[in] sendbuf Data to send to root
11945!> \param[out] recvbuf Received data (on root)
11946!> \param[in] recvcounts Sizes of data received from processes
11947!> \param[in] displs Offsets of data received from processes
11948!> \param[in] root Process which gathers the data
11949!> \param[in] comm Message passing environment identifier
11950!> \par Data length
11951!> Data can have different lengths
11952!> \par Offsets
11953!> Offsets start at 0
11954!> \par MPI mapping
11955!> mpi_gather
11956! **************************************************************************************************
11957 SUBROUTINE mp_igatherv_lv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
11958 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: sendbuf
11959 INTEGER(KIND=int_8), DIMENSION(:), INTENT(OUT) :: recvbuf
11960 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
11961 INTEGER, INTENT(IN) :: sendcount, root
11962 CLASS(mp_comm_type), INTENT(IN) :: comm
11963 TYPE(mp_request_type), INTENT(OUT) :: request
11964
11965 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_lv'
11966
11967 INTEGER :: handle
11968#if defined(__parallel)
11969 INTEGER :: ierr
11970#endif
11971
11972 CALL mp_timeset(routinen, handle)
11973
11974#if defined(__parallel)
11975#if !defined(__GNUC__) || __GNUC__ >= 9
11976 cpassert(is_contiguous(sendbuf))
11977 cpassert(is_contiguous(recvbuf))
11978 cpassert(is_contiguous(recvcounts))
11979 cpassert(is_contiguous(displs))
11980#endif
11981 CALL mpi_igatherv(sendbuf, sendcount, mpi_integer8, &
11982 recvbuf, recvcounts, displs, mpi_integer8, &
11983 root, comm%handle, request%handle, ierr)
11984 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
11985 CALL add_perf(perf_id=24, &
11986 count=1, &
11987 msg_size=sendcount*int_8_size)
11988#else
11989 mark_used(sendcount)
11990 mark_used(recvcounts)
11991 mark_used(root)
11992 mark_used(comm)
11993 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
11994 request = mp_request_null
11995#endif
11996 CALL mp_timestop(handle)
11997 END SUBROUTINE mp_igatherv_lv
11998
11999! **************************************************************************************************
12000!> \brief Gathers a datum from all processes and all processes receive the
12001!> same data
12002!> \param[in] msgout Datum to send
12003!> \param[out] msgin Received data
12004!> \param[in] comm Message passing environment identifier
12005!> \par Data size
12006!> All processes send equal-sized data
12007!> \par MPI mapping
12008!> mpi_allgather
12009! **************************************************************************************************
12010 SUBROUTINE mp_allgather_l (msgout, msgin, comm)
12011 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12012 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
12013 CLASS(mp_comm_type), INTENT(IN) :: comm
12014
12015 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l'
12016
12017 INTEGER :: handle
12018#if defined(__parallel)
12019 INTEGER :: ierr, rcount, scount
12020#endif
12021
12022 CALL mp_timeset(routinen, handle)
12023
12024#if defined(__parallel)
12025 scount = 1
12026 rcount = 1
12027 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12028 msgin, rcount, mpi_integer8, &
12029 comm%handle, ierr)
12030 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12031#else
12032 mark_used(comm)
12033 msgin = msgout
12034#endif
12035 CALL mp_timestop(handle)
12036 END SUBROUTINE mp_allgather_l
12037
12038! **************************************************************************************************
12039!> \brief Gathers a datum from all processes and all processes receive the
12040!> same data
12041!> \param[in] msgout Datum to send
12042!> \param[out] msgin Received data
12043!> \param[in] comm Message passing environment identifier
12044!> \par Data size
12045!> All processes send equal-sized data
12046!> \par MPI mapping
12047!> mpi_allgather
12048! **************************************************************************************************
12049 SUBROUTINE mp_allgather_l2(msgout, msgin, comm)
12050 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12051 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12052 CLASS(mp_comm_type), INTENT(IN) :: comm
12053
12054 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l2'
12055
12056 INTEGER :: handle
12057#if defined(__parallel)
12058 INTEGER :: ierr, rcount, scount
12059#endif
12060
12061 CALL mp_timeset(routinen, handle)
12062
12063#if defined(__parallel)
12064 scount = 1
12065 rcount = 1
12066 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12067 msgin, rcount, mpi_integer8, &
12068 comm%handle, ierr)
12069 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12070#else
12071 mark_used(comm)
12072 msgin = msgout
12073#endif
12074 CALL mp_timestop(handle)
12075 END SUBROUTINE mp_allgather_l2
12076
12077! **************************************************************************************************
12078!> \brief Gathers a datum from all processes and all processes receive the
12079!> same data
12080!> \param[in] msgout Datum to send
12081!> \param[out] msgin Received data
12082!> \param[in] comm Message passing environment identifier
12083!> \par Data size
12084!> All processes send equal-sized data
12085!> \par MPI mapping
12086!> mpi_allgather
12087! **************************************************************************************************
12088 SUBROUTINE mp_iallgather_l (msgout, msgin, comm, request)
12089 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12090 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12091 CLASS(mp_comm_type), INTENT(IN) :: comm
12092 TYPE(mp_request_type), INTENT(OUT) :: request
12093
12094 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l'
12095
12096 INTEGER :: handle
12097#if defined(__parallel)
12098 INTEGER :: ierr, rcount, scount
12099#endif
12100
12101 CALL mp_timeset(routinen, handle)
12102
12103#if defined(__parallel)
12104#if !defined(__GNUC__) || __GNUC__ >= 9
12105 cpassert(is_contiguous(msgin))
12106#endif
12107 scount = 1
12108 rcount = 1
12109 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12110 msgin, rcount, mpi_integer8, &
12111 comm%handle, request%handle, ierr)
12112 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12113#else
12114 mark_used(comm)
12115 msgin = msgout
12116 request = mp_request_null
12117#endif
12118 CALL mp_timestop(handle)
12119 END SUBROUTINE mp_iallgather_l
12120
12121! **************************************************************************************************
12122!> \brief Gathers vector data from all processes and all processes receive the
12123!> same data
12124!> \param[in] msgout Rank-1 data to send
12125!> \param[out] msgin Received data
12126!> \param[in] comm Message passing environment identifier
12127!> \par Data size
12128!> All processes send equal-sized data
12129!> \par Ranks
12130!> The last rank counts the processes
12131!> \par MPI mapping
12132!> mpi_allgather
12133! **************************************************************************************************
12134 SUBROUTINE mp_allgather_l12(msgout, msgin, comm)
12135 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:)
12136 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12137 CLASS(mp_comm_type), INTENT(IN) :: comm
12138
12139 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l12'
12140
12141 INTEGER :: handle
12142#if defined(__parallel)
12143 INTEGER :: ierr, rcount, scount
12144#endif
12145
12146 CALL mp_timeset(routinen, handle)
12147
12148#if defined(__parallel)
12149 scount = SIZE(msgout(:))
12150 rcount = scount
12151 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12152 msgin, rcount, mpi_integer8, &
12153 comm%handle, ierr)
12154 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12155#else
12156 mark_used(comm)
12157 msgin(:, 1) = msgout(:)
12158#endif
12159 CALL mp_timestop(handle)
12160 END SUBROUTINE mp_allgather_l12
12161
12162! **************************************************************************************************
12163!> \brief Gathers matrix data from all processes and all processes receive the
12164!> same data
12165!> \param[in] msgout Rank-2 data to send
12166!> \param msgin ...
12167!> \param comm ...
12168!> \note see mp_allgather_l12
12169! **************************************************************************************************
12170 SUBROUTINE mp_allgather_l23(msgout, msgin, comm)
12171 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
12172 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
12173 CLASS(mp_comm_type), INTENT(IN) :: comm
12174
12175 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l23'
12176
12177 INTEGER :: handle
12178#if defined(__parallel)
12179 INTEGER :: ierr, rcount, scount
12180#endif
12181
12182 CALL mp_timeset(routinen, handle)
12183
12184#if defined(__parallel)
12185 scount = SIZE(msgout(:, :))
12186 rcount = scount
12187 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12188 msgin, rcount, mpi_integer8, &
12189 comm%handle, ierr)
12190 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12191#else
12192 mark_used(comm)
12193 msgin(:, :, 1) = msgout(:, :)
12194#endif
12195 CALL mp_timestop(handle)
12196 END SUBROUTINE mp_allgather_l23
12197
12198! **************************************************************************************************
12199!> \brief Gathers rank-3 data from all processes and all processes receive the
12200!> same data
12201!> \param[in] msgout Rank-3 data to send
12202!> \param msgin ...
12203!> \param comm ...
12204!> \note see mp_allgather_l12
12205! **************************************************************************************************
12206 SUBROUTINE mp_allgather_l34(msgout, msgin, comm)
12207 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
12208 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
12209 CLASS(mp_comm_type), INTENT(IN) :: comm
12210
12211 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l34'
12212
12213 INTEGER :: handle
12214#if defined(__parallel)
12215 INTEGER :: ierr, rcount, scount
12216#endif
12217
12218 CALL mp_timeset(routinen, handle)
12219
12220#if defined(__parallel)
12221 scount = SIZE(msgout(:, :, :))
12222 rcount = scount
12223 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12224 msgin, rcount, mpi_integer8, &
12225 comm%handle, ierr)
12226 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12227#else
12228 mark_used(comm)
12229 msgin(:, :, :, 1) = msgout(:, :, :)
12230#endif
12231 CALL mp_timestop(handle)
12232 END SUBROUTINE mp_allgather_l34
12233
12234! **************************************************************************************************
12235!> \brief Gathers rank-2 data from all processes and all processes receive the
12236!> same data
12237!> \param[in] msgout Rank-2 data to send
12238!> \param msgin ...
12239!> \param comm ...
12240!> \note see mp_allgather_l12
12241! **************************************************************************************************
12242 SUBROUTINE mp_allgather_l22(msgout, msgin, comm)
12243 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
12244 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12245 CLASS(mp_comm_type), INTENT(IN) :: comm
12246
12247 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l22'
12248
12249 INTEGER :: handle
12250#if defined(__parallel)
12251 INTEGER :: ierr, rcount, scount
12252#endif
12253
12254 CALL mp_timeset(routinen, handle)
12255
12256#if defined(__parallel)
12257 scount = SIZE(msgout(:, :))
12258 rcount = scount
12259 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12260 msgin, rcount, mpi_integer8, &
12261 comm%handle, ierr)
12262 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12263#else
12264 mark_used(comm)
12265 msgin(:, :) = msgout(:, :)
12266#endif
12267 CALL mp_timestop(handle)
12268 END SUBROUTINE mp_allgather_l22
12269
12270! **************************************************************************************************
12271!> \brief Gathers rank-1 data from all processes and all processes receive the
12272!> same data
12273!> \param[in] msgout Rank-1 data to send
12274!> \param msgin ...
12275!> \param comm ...
12276!> \param request ...
12277!> \note see mp_allgather_l11
12278! **************************************************************************************************
12279 SUBROUTINE mp_iallgather_l11(msgout, msgin, comm, request)
12280 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12281 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12282 CLASS(mp_comm_type), INTENT(IN) :: comm
12283 TYPE(mp_request_type), INTENT(OUT) :: request
12284
12285 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l11'
12286
12287 INTEGER :: handle
12288#if defined(__parallel)
12289 INTEGER :: ierr, rcount, scount
12290#endif
12291
12292 CALL mp_timeset(routinen, handle)
12293
12294#if defined(__parallel)
12295#if !defined(__GNUC__) || __GNUC__ >= 9
12296 cpassert(is_contiguous(msgout))
12297 cpassert(is_contiguous(msgin))
12298#endif
12299 scount = SIZE(msgout(:))
12300 rcount = scount
12301 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12302 msgin, rcount, mpi_integer8, &
12303 comm%handle, request%handle, ierr)
12304 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12305#else
12306 mark_used(comm)
12307 msgin = msgout
12308 request = mp_request_null
12309#endif
12310 CALL mp_timestop(handle)
12311 END SUBROUTINE mp_iallgather_l11
12312
12313! **************************************************************************************************
12314!> \brief Gathers rank-2 data from all processes and all processes receive the
12315!> same data
12316!> \param[in] msgout Rank-2 data to send
12317!> \param msgin ...
12318!> \param comm ...
12319!> \param request ...
12320!> \note see mp_allgather_l12
12321! **************************************************************************************************
12322 SUBROUTINE mp_iallgather_l13(msgout, msgin, comm, request)
12323 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12324 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :)
12325 CLASS(mp_comm_type), INTENT(IN) :: comm
12326 TYPE(mp_request_type), INTENT(OUT) :: request
12327
12328 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l13'
12329
12330 INTEGER :: handle
12331#if defined(__parallel)
12332 INTEGER :: ierr, rcount, scount
12333#endif
12334
12335 CALL mp_timeset(routinen, handle)
12336
12337#if defined(__parallel)
12338#if !defined(__GNUC__) || __GNUC__ >= 9
12339 cpassert(is_contiguous(msgout))
12340 cpassert(is_contiguous(msgin))
12341#endif
12342
12343 scount = SIZE(msgout(:))
12344 rcount = scount
12345 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12346 msgin, rcount, mpi_integer8, &
12347 comm%handle, request%handle, ierr)
12348 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12349#else
12350 mark_used(comm)
12351 msgin(:, 1, 1) = msgout(:)
12352 request = mp_request_null
12353#endif
12354 CALL mp_timestop(handle)
12355 END SUBROUTINE mp_iallgather_l13
12356
12357! **************************************************************************************************
12358!> \brief Gathers rank-2 data from all processes and all processes receive the
12359!> same data
12360!> \param[in] msgout Rank-2 data to send
12361!> \param msgin ...
12362!> \param comm ...
12363!> \param request ...
12364!> \note see mp_allgather_l12
12365! **************************************************************************************************
12366 SUBROUTINE mp_iallgather_l22(msgout, msgin, comm, request)
12367 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :)
12368 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :)
12369 CLASS(mp_comm_type), INTENT(IN) :: comm
12370 TYPE(mp_request_type), INTENT(OUT) :: request
12371
12372 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l22'
12373
12374 INTEGER :: handle
12375#if defined(__parallel)
12376 INTEGER :: ierr, rcount, scount
12377#endif
12378
12379 CALL mp_timeset(routinen, handle)
12380
12381#if defined(__parallel)
12382#if !defined(__GNUC__) || __GNUC__ >= 9
12383 cpassert(is_contiguous(msgout))
12384 cpassert(is_contiguous(msgin))
12385#endif
12386
12387 scount = SIZE(msgout(:, :))
12388 rcount = scount
12389 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12390 msgin, rcount, mpi_integer8, &
12391 comm%handle, request%handle, ierr)
12392 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12393#else
12394 mark_used(comm)
12395 msgin(:, :) = msgout(:, :)
12396 request = mp_request_null
12397#endif
12398 CALL mp_timestop(handle)
12399 END SUBROUTINE mp_iallgather_l22
12400
12401! **************************************************************************************************
12402!> \brief Gathers rank-2 data from all processes and all processes receive the
12403!> same data
12404!> \param[in] msgout Rank-2 data to send
12405!> \param msgin ...
12406!> \param comm ...
12407!> \param request ...
12408!> \note see mp_allgather_l12
12409! **************************************************************************************************
12410 SUBROUTINE mp_iallgather_l24(msgout, msgin, comm, request)
12411 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :)
12412 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :, :)
12413 CLASS(mp_comm_type), INTENT(IN) :: comm
12414 TYPE(mp_request_type), INTENT(OUT) :: request
12415
12416 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l24'
12417
12418 INTEGER :: handle
12419#if defined(__parallel)
12420 INTEGER :: ierr, rcount, scount
12421#endif
12422
12423 CALL mp_timeset(routinen, handle)
12424
12425#if defined(__parallel)
12426#if !defined(__GNUC__) || __GNUC__ >= 9
12427 cpassert(is_contiguous(msgout))
12428 cpassert(is_contiguous(msgin))
12429#endif
12430
12431 scount = SIZE(msgout(:, :))
12432 rcount = scount
12433 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12434 msgin, rcount, mpi_integer8, &
12435 comm%handle, request%handle, ierr)
12436 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12437#else
12438 mark_used(comm)
12439 msgin(:, :, 1, 1) = msgout(:, :)
12440 request = mp_request_null
12441#endif
12442 CALL mp_timestop(handle)
12443 END SUBROUTINE mp_iallgather_l24
12444
12445! **************************************************************************************************
12446!> \brief Gathers rank-3 data from all processes and all processes receive the
12447!> same data
12448!> \param[in] msgout Rank-3 data to send
12449!> \param msgin ...
12450!> \param comm ...
12451!> \param request ...
12452!> \note see mp_allgather_l12
12453! **************************************************************************************************
12454 SUBROUTINE mp_iallgather_l33(msgout, msgin, comm, request)
12455 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :, :)
12456 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :)
12457 CLASS(mp_comm_type), INTENT(IN) :: comm
12458 TYPE(mp_request_type), INTENT(OUT) :: request
12459
12460 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l33'
12461
12462 INTEGER :: handle
12463#if defined(__parallel)
12464 INTEGER :: ierr, rcount, scount
12465#endif
12466
12467 CALL mp_timeset(routinen, handle)
12468
12469#if defined(__parallel)
12470#if !defined(__GNUC__) || __GNUC__ >= 9
12471 cpassert(is_contiguous(msgout))
12472 cpassert(is_contiguous(msgin))
12473#endif
12474
12475 scount = SIZE(msgout(:, :, :))
12476 rcount = scount
12477 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12478 msgin, rcount, mpi_integer8, &
12479 comm%handle, request%handle, ierr)
12480 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12481#else
12482 mark_used(comm)
12483 msgin(:, :, :) = msgout(:, :, :)
12484 request = mp_request_null
12485#endif
12486 CALL mp_timestop(handle)
12487 END SUBROUTINE mp_iallgather_l33
12488
12489! **************************************************************************************************
12490!> \brief Gathers vector data from all processes and all processes receive the
12491!> same data
12492!> \param[in] msgout Rank-1 data to send
12493!> \param[out] msgin Received data
12494!> \param[in] rcount Size of sent data for every process
12495!> \param[in] rdispl Offset of sent data for every process
12496!> \param[in] comm Message passing environment identifier
12497!> \par Data size
12498!> Processes can send different-sized data
12499!> \par Ranks
12500!> The last rank counts the processes
12501!> \par Offsets
12502!> Offsets are from 0
12503!> \par MPI mapping
12504!> mpi_allgather
12505! **************************************************************************************************
12506 SUBROUTINE mp_allgatherv_lv(msgout, msgin, rcount, rdispl, comm)
12507 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
12508 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12509 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12510 CLASS(mp_comm_type), INTENT(IN) :: comm
12511
12512 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_lv'
12513
12514 INTEGER :: handle
12515#if defined(__parallel)
12516 INTEGER :: ierr, scount
12517#endif
12518
12519 CALL mp_timeset(routinen, handle)
12520
12521#if defined(__parallel)
12522 scount = SIZE(msgout)
12523 CALL mpi_allgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12524 rdispl, mpi_integer8, comm%handle, ierr)
12525 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
12526#else
12527 mark_used(rcount)
12528 mark_used(rdispl)
12529 mark_used(comm)
12530 msgin = msgout
12531#endif
12532 CALL mp_timestop(handle)
12533 END SUBROUTINE mp_allgatherv_lv
12534
12535! **************************************************************************************************
12536!> \brief Gathers vector data from all processes and all processes receive the
12537!> same data
12538!> \param[in] msgout Rank-1 data to send
12539!> \param[out] msgin Received data
12540!> \param[in] rcount Size of sent data for every process
12541!> \param[in] rdispl Offset of sent data for every process
12542!> \param[in] comm Message passing environment identifier
12543!> \par Data size
12544!> Processes can send different-sized data
12545!> \par Ranks
12546!> The last rank counts the processes
12547!> \par Offsets
12548!> Offsets are from 0
12549!> \par MPI mapping
12550!> mpi_allgather
12551! **************************************************************************************************
12552 SUBROUTINE mp_allgatherv_lm2(msgout, msgin, rcount, rdispl, comm)
12553 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
12554 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
12555 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12556 CLASS(mp_comm_type), INTENT(IN) :: comm
12557
12558 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_lv'
12559
12560 INTEGER :: handle
12561#if defined(__parallel)
12562 INTEGER :: ierr, scount
12563#endif
12564
12565 CALL mp_timeset(routinen, handle)
12566
12567#if defined(__parallel)
12568 scount = SIZE(msgout)
12569 CALL mpi_allgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12570 rdispl, mpi_integer8, comm%handle, ierr)
12571 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
12572#else
12573 mark_used(rcount)
12574 mark_used(rdispl)
12575 mark_used(comm)
12576 msgin = msgout
12577#endif
12578 CALL mp_timestop(handle)
12579 END SUBROUTINE mp_allgatherv_lm2
12580
12581! **************************************************************************************************
12582!> \brief Gathers vector data from all processes and all processes receive the
12583!> same data
12584!> \param[in] msgout Rank-1 data to send
12585!> \param[out] msgin Received data
12586!> \param[in] rcount Size of sent data for every process
12587!> \param[in] rdispl Offset of sent data for every process
12588!> \param[in] comm Message passing environment identifier
12589!> \par Data size
12590!> Processes can send different-sized data
12591!> \par Ranks
12592!> The last rank counts the processes
12593!> \par Offsets
12594!> Offsets are from 0
12595!> \par MPI mapping
12596!> mpi_allgather
12597! **************************************************************************************************
12598 SUBROUTINE mp_iallgatherv_lv(msgout, msgin, rcount, rdispl, comm, request)
12599 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12600 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12601 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12602 CLASS(mp_comm_type), INTENT(IN) :: comm
12603 TYPE(mp_request_type), INTENT(OUT) :: request
12604
12605 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_lv'
12606
12607 INTEGER :: handle
12608#if defined(__parallel)
12609 INTEGER :: ierr, scount, rsize
12610#endif
12611
12612 CALL mp_timeset(routinen, handle)
12613
12614#if defined(__parallel)
12615#if !defined(__GNUC__) || __GNUC__ >= 9
12616 cpassert(is_contiguous(msgout))
12617 cpassert(is_contiguous(msgin))
12618 cpassert(is_contiguous(rcount))
12619 cpassert(is_contiguous(rdispl))
12620#endif
12621
12622 scount = SIZE(msgout)
12623 rsize = SIZE(rcount)
12624 CALL mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, &
12625 rdispl, comm, request, ierr)
12626 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
12627#else
12628 mark_used(rcount)
12629 mark_used(rdispl)
12630 mark_used(comm)
12631 msgin = msgout
12632 request = mp_request_null
12633#endif
12634 CALL mp_timestop(handle)
12635 END SUBROUTINE mp_iallgatherv_lv
12636
12637! **************************************************************************************************
12638!> \brief Gathers vector data from all processes and all processes receive the
12639!> same data
12640!> \param[in] msgout Rank-1 data to send
12641!> \param[out] msgin Received data
12642!> \param[in] rcount Size of sent data for every process
12643!> \param[in] rdispl Offset of sent data for every process
12644!> \param[in] comm Message passing environment identifier
12645!> \par Data size
12646!> Processes can send different-sized data
12647!> \par Ranks
12648!> The last rank counts the processes
12649!> \par Offsets
12650!> Offsets are from 0
12651!> \par MPI mapping
12652!> mpi_allgather
12653! **************************************************************************************************
12654 SUBROUTINE mp_iallgatherv_lv2(msgout, msgin, rcount, rdispl, comm, request)
12655 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12656 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12657 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
12658 CLASS(mp_comm_type), INTENT(IN) :: comm
12659 TYPE(mp_request_type), INTENT(OUT) :: request
12660
12661 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_lv2'
12662
12663 INTEGER :: handle
12664#if defined(__parallel)
12665 INTEGER :: ierr, scount, rsize
12666#endif
12667
12668 CALL mp_timeset(routinen, handle)
12669
12670#if defined(__parallel)
12671#if !defined(__GNUC__) || __GNUC__ >= 9
12672 cpassert(is_contiguous(msgout))
12673 cpassert(is_contiguous(msgin))
12674 cpassert(is_contiguous(rcount))
12675 cpassert(is_contiguous(rdispl))
12676#endif
12677
12678 scount = SIZE(msgout)
12679 rsize = SIZE(rcount)
12680 CALL mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, &
12681 rdispl, comm, request, ierr)
12682 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
12683#else
12684 mark_used(rcount)
12685 mark_used(rdispl)
12686 mark_used(comm)
12687 msgin = msgout
12688 request = mp_request_null
12689#endif
12690 CALL mp_timestop(handle)
12691 END SUBROUTINE mp_iallgatherv_lv2
12692
12693! **************************************************************************************************
12694!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
12695!> the issue is with the rank of rcount and rdispl
12696!> \param count ...
12697!> \param array_of_requests ...
12698!> \param array_of_statuses ...
12699!> \param ierr ...
12700!> \author Alfio Lazzaro
12701! **************************************************************************************************
12702#if defined(__parallel)
12703 SUBROUTINE mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
12704 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
12705 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12706 INTEGER, INTENT(IN) :: rsize
12707 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
12708 CLASS(mp_comm_type), INTENT(IN) :: comm
12709 TYPE(mp_request_type), INTENT(OUT) :: request
12710 INTEGER, INTENT(INOUT) :: ierr
12711
12712 CALL mpi_iallgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12713 rdispl, mpi_integer8, comm%handle, request%handle, ierr)
12714
12715 END SUBROUTINE mp_iallgatherv_lv_internal
12716#endif
12717
12718! **************************************************************************************************
12719!> \brief Sums a vector and partitions the result among processes
12720!> \param[in] msgout Data to sum
12721!> \param[out] msgin Received portion of summed data
12722!> \param[in] rcount Partition sizes of the summed data for
12723!> every process
12724!> \param[in] comm Message passing environment identifier
12725! **************************************************************************************************
12726 SUBROUTINE mp_sum_scatter_lv(msgout, msgin, rcount, comm)
12727 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
12728 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12729 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
12730 CLASS(mp_comm_type), INTENT(IN) :: comm
12731
12732 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_lv'
12733
12734 INTEGER :: handle
12735#if defined(__parallel)
12736 INTEGER :: ierr
12737#endif
12738
12739 CALL mp_timeset(routinen, handle)
12740
12741#if defined(__parallel)
12742 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_integer8, mpi_sum, &
12743 comm%handle, ierr)
12744 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
12745
12746 CALL add_perf(perf_id=3, count=1, &
12747 msg_size=rcount(1)*2*int_8_size)
12748#else
12749 mark_used(rcount)
12750 mark_used(comm)
12751 msgin = msgout(:, 1)
12752#endif
12753 CALL mp_timestop(handle)
12754 END SUBROUTINE mp_sum_scatter_lv
12755
12756! **************************************************************************************************
12757!> \brief Sends and receives vector data
12758!> \param[in] msgin Data to send
12759!> \param[in] dest Process to send data to
12760!> \param[out] msgout Received data
12761!> \param[in] source Process from which to receive
12762!> \param[in] comm Message passing environment identifier
12763!> \param[in] tag Send and recv tag (default: 0)
12764! **************************************************************************************************
12765 SUBROUTINE mp_sendrecv_l (msgin, dest, msgout, source, comm, tag)
12766 INTEGER(KIND=int_8), INTENT(IN) :: msgin
12767 INTEGER, INTENT(IN) :: dest
12768 INTEGER(KIND=int_8), INTENT(OUT) :: msgout
12769 INTEGER, INTENT(IN) :: source
12770 CLASS(mp_comm_type), INTENT(IN) :: comm
12771 INTEGER, INTENT(IN), OPTIONAL :: tag
12772
12773 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_l'
12774
12775 INTEGER :: handle
12776#if defined(__parallel)
12777 INTEGER :: ierr, msglen_in, msglen_out, &
12778 recv_tag, send_tag
12779#endif
12780
12781 CALL mp_timeset(routinen, handle)
12782
12783#if defined(__parallel)
12784 msglen_in = 1
12785 msglen_out = 1
12786 send_tag = 0 ! cannot think of something better here, this might be dangerous
12787 recv_tag = 0 ! cannot think of something better here, this might be dangerous
12788 IF (PRESENT(tag)) THEN
12789 send_tag = tag
12790 recv_tag = tag
12791 END IF
12792 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
12793 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
12794 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
12795 CALL add_perf(perf_id=7, count=1, &
12796 msg_size=(msglen_in + msglen_out)*int_8_size/2)
12797#else
12798 mark_used(dest)
12799 mark_used(source)
12800 mark_used(comm)
12801 mark_used(tag)
12802 msgout = msgin
12803#endif
12804 CALL mp_timestop(handle)
12805 END SUBROUTINE mp_sendrecv_l
12806
12807! **************************************************************************************************
12808!> \brief Sends and receives vector data
12809!> \param[in] msgin Data to send
12810!> \param[in] dest Process to send data to
12811!> \param[out] msgout Received data
12812!> \param[in] source Process from which to receive
12813!> \param[in] comm Message passing environment identifier
12814!> \param[in] tag Send and recv tag (default: 0)
12815! **************************************************************************************************
12816 SUBROUTINE mp_sendrecv_lv(msgin, dest, msgout, source, comm, tag)
12817 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
12818 INTEGER, INTENT(IN) :: dest
12819 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
12820 INTEGER, INTENT(IN) :: source
12821 CLASS(mp_comm_type), INTENT(IN) :: comm
12822 INTEGER, INTENT(IN), OPTIONAL :: tag
12823
12824 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lv'
12825
12826 INTEGER :: handle
12827#if defined(__parallel)
12828 INTEGER :: ierr, msglen_in, msglen_out, &
12829 recv_tag, send_tag
12830#endif
12831
12832 CALL mp_timeset(routinen, handle)
12833
12834#if defined(__parallel)
12835 msglen_in = SIZE(msgin)
12836 msglen_out = SIZE(msgout)
12837 send_tag = 0 ! cannot think of something better here, this might be dangerous
12838 recv_tag = 0 ! cannot think of something better here, this might be dangerous
12839 IF (PRESENT(tag)) THEN
12840 send_tag = tag
12841 recv_tag = tag
12842 END IF
12843 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
12844 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
12845 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
12846 CALL add_perf(perf_id=7, count=1, &
12847 msg_size=(msglen_in + msglen_out)*int_8_size/2)
12848#else
12849 mark_used(dest)
12850 mark_used(source)
12851 mark_used(comm)
12852 mark_used(tag)
12853 msgout = msgin
12854#endif
12855 CALL mp_timestop(handle)
12856 END SUBROUTINE mp_sendrecv_lv
12857
12858! **************************************************************************************************
12859!> \brief Sends and receives matrix data
12860!> \param msgin ...
12861!> \param dest ...
12862!> \param msgout ...
12863!> \param source ...
12864!> \param comm ...
12865!> \param tag ...
12866!> \note see mp_sendrecv_lv
12867! **************************************************************************************************
12868 SUBROUTINE mp_sendrecv_lm2(msgin, dest, msgout, source, comm, tag)
12869 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
12870 INTEGER, INTENT(IN) :: dest
12871 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
12872 INTEGER, INTENT(IN) :: source
12873 CLASS(mp_comm_type), INTENT(IN) :: comm
12874 INTEGER, INTENT(IN), OPTIONAL :: tag
12875
12876 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm2'
12877
12878 INTEGER :: handle
12879#if defined(__parallel)
12880 INTEGER :: ierr, msglen_in, msglen_out, &
12881 recv_tag, send_tag
12882#endif
12883
12884 CALL mp_timeset(routinen, handle)
12885
12886#if defined(__parallel)
12887 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
12888 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
12889 send_tag = 0 ! cannot think of something better here, this might be dangerous
12890 recv_tag = 0 ! cannot think of something better here, this might be dangerous
12891 IF (PRESENT(tag)) THEN
12892 send_tag = tag
12893 recv_tag = tag
12894 END IF
12895 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
12896 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
12897 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
12898 CALL add_perf(perf_id=7, count=1, &
12899 msg_size=(msglen_in + msglen_out)*int_8_size/2)
12900#else
12901 mark_used(dest)
12902 mark_used(source)
12903 mark_used(comm)
12904 mark_used(tag)
12905 msgout = msgin
12906#endif
12907 CALL mp_timestop(handle)
12908 END SUBROUTINE mp_sendrecv_lm2
12909
12910! **************************************************************************************************
12911!> \brief Sends and receives rank-3 data
12912!> \param msgin ...
12913!> \param dest ...
12914!> \param msgout ...
12915!> \param source ...
12916!> \param comm ...
12917!> \note see mp_sendrecv_lv
12918! **************************************************************************************************
12919 SUBROUTINE mp_sendrecv_lm3(msgin, dest, msgout, source, comm, tag)
12920 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
12921 INTEGER, INTENT(IN) :: dest
12922 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
12923 INTEGER, INTENT(IN) :: source
12924 CLASS(mp_comm_type), INTENT(IN) :: comm
12925 INTEGER, INTENT(IN), OPTIONAL :: tag
12926
12927 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm3'
12928
12929 INTEGER :: handle
12930#if defined(__parallel)
12931 INTEGER :: ierr, msglen_in, msglen_out, &
12932 recv_tag, send_tag
12933#endif
12934
12935 CALL mp_timeset(routinen, handle)
12936
12937#if defined(__parallel)
12938 msglen_in = SIZE(msgin)
12939 msglen_out = SIZE(msgout)
12940 send_tag = 0 ! cannot think of something better here, this might be dangerous
12941 recv_tag = 0 ! cannot think of something better here, this might be dangerous
12942 IF (PRESENT(tag)) THEN
12943 send_tag = tag
12944 recv_tag = tag
12945 END IF
12946 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
12947 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
12948 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
12949 CALL add_perf(perf_id=7, count=1, &
12950 msg_size=(msglen_in + msglen_out)*int_8_size/2)
12951#else
12952 mark_used(dest)
12953 mark_used(source)
12954 mark_used(comm)
12955 mark_used(tag)
12956 msgout = msgin
12957#endif
12958 CALL mp_timestop(handle)
12959 END SUBROUTINE mp_sendrecv_lm3
12960
12961! **************************************************************************************************
12962!> \brief Sends and receives rank-4 data
12963!> \param msgin ...
12964!> \param dest ...
12965!> \param msgout ...
12966!> \param source ...
12967!> \param comm ...
12968!> \note see mp_sendrecv_lv
12969! **************************************************************************************************
12970 SUBROUTINE mp_sendrecv_lm4(msgin, dest, msgout, source, comm, tag)
12971 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
12972 INTEGER, INTENT(IN) :: dest
12973 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
12974 INTEGER, INTENT(IN) :: source
12975 CLASS(mp_comm_type), INTENT(IN) :: comm
12976 INTEGER, INTENT(IN), OPTIONAL :: tag
12977
12978 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm4'
12979
12980 INTEGER :: handle
12981#if defined(__parallel)
12982 INTEGER :: ierr, msglen_in, msglen_out, &
12983 recv_tag, send_tag
12984#endif
12985
12986 CALL mp_timeset(routinen, handle)
12987
12988#if defined(__parallel)
12989 msglen_in = SIZE(msgin)
12990 msglen_out = SIZE(msgout)
12991 send_tag = 0 ! cannot think of something better here, this might be dangerous
12992 recv_tag = 0 ! cannot think of something better here, this might be dangerous
12993 IF (PRESENT(tag)) THEN
12994 send_tag = tag
12995 recv_tag = tag
12996 END IF
12997 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
12998 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
12999 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13000 CALL add_perf(perf_id=7, count=1, &
13001 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13002#else
13003 mark_used(dest)
13004 mark_used(source)
13005 mark_used(comm)
13006 mark_used(tag)
13007 msgout = msgin
13008#endif
13009 CALL mp_timestop(handle)
13010 END SUBROUTINE mp_sendrecv_lm4
13011
13012! **************************************************************************************************
13013!> \brief Non-blocking send and receive of a scalar
13014!> \param[in] msgin Scalar data to send
13015!> \param[in] dest Which process to send to
13016!> \param[out] msgout Receive data into this pointer
13017!> \param[in] source Process to receive from
13018!> \param[in] comm Message passing environment identifier
13019!> \param[out] send_request Request handle for the send
13020!> \param[out] recv_request Request handle for the receive
13021!> \param[in] tag (optional) tag to differentiate requests
13022!> \par Implementation
13023!> Calls mpi_isend and mpi_irecv.
13024!> \par History
13025!> 02.2005 created [Alfio Lazzaro]
13026! **************************************************************************************************
13027 SUBROUTINE mp_isendrecv_l (msgin, dest, msgout, source, comm, send_request, &
13028 recv_request, tag)
13029 INTEGER(KIND=int_8), INTENT(IN) :: msgin
13030 INTEGER, INTENT(IN) :: dest
13031 INTEGER(KIND=int_8), INTENT(INOUT) :: msgout
13032 INTEGER, INTENT(IN) :: source
13033 CLASS(mp_comm_type), INTENT(IN) :: comm
13034 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
13035 INTEGER, INTENT(in), OPTIONAL :: tag
13036
13037 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_l'
13038
13039 INTEGER :: handle
13040#if defined(__parallel)
13041 INTEGER :: ierr, my_tag
13042#endif
13043
13044 CALL mp_timeset(routinen, handle)
13045
13046#if defined(__parallel)
13047 my_tag = 0
13048 IF (PRESENT(tag)) my_tag = tag
13049
13050 CALL mpi_irecv(msgout, 1, mpi_integer8, source, my_tag, &
13051 comm%handle, recv_request%handle, ierr)
13052 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13053
13054 CALL mpi_isend(msgin, 1, mpi_integer8, dest, my_tag, &
13055 comm%handle, send_request%handle, ierr)
13056 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13057
13058 CALL add_perf(perf_id=8, count=1, msg_size=2*int_8_size)
13059#else
13060 mark_used(dest)
13061 mark_used(source)
13062 mark_used(comm)
13063 mark_used(tag)
13064 send_request = mp_request_null
13065 recv_request = mp_request_null
13066 msgout = msgin
13067#endif
13068 CALL mp_timestop(handle)
13069 END SUBROUTINE mp_isendrecv_l
13070
13071! **************************************************************************************************
13072!> \brief Non-blocking send and receive of a vector
13073!> \param[in] msgin Vector data to send
13074!> \param[in] dest Which process to send to
13075!> \param[out] msgout Receive data into this pointer
13076!> \param[in] source Process to receive from
13077!> \param[in] comm Message passing environment identifier
13078!> \param[out] send_request Request handle for the send
13079!> \param[out] recv_request Request handle for the receive
13080!> \param[in] tag (optional) tag to differentiate requests
13081!> \par Implementation
13082!> Calls mpi_isend and mpi_irecv.
13083!> \par History
13084!> 11.2004 created [Joost VandeVondele]
13085!> \note
13086!> arrays can be pointers or assumed shape, but they must be contiguous!
13087! **************************************************************************************************
13088 SUBROUTINE mp_isendrecv_lv(msgin, dest, msgout, source, comm, send_request, &
13089 recv_request, tag)
13090 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: msgin
13091 INTEGER, INTENT(IN) :: dest
13092 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT) :: msgout
13093 INTEGER, INTENT(IN) :: source
13094 CLASS(mp_comm_type), INTENT(IN) :: comm
13095 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
13096 INTEGER, INTENT(in), OPTIONAL :: tag
13097
13098 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_lv'
13099
13100 INTEGER :: handle
13101#if defined(__parallel)
13102 INTEGER :: ierr, msglen, my_tag
13103 INTEGER(KIND=int_8) :: foo
13104#endif
13105
13106 CALL mp_timeset(routinen, handle)
13107
13108#if defined(__parallel)
13109#if !defined(__GNUC__) || __GNUC__ >= 9
13110 cpassert(is_contiguous(msgout))
13111 cpassert(is_contiguous(msgin))
13112#endif
13113
13114 my_tag = 0
13115 IF (PRESENT(tag)) my_tag = tag
13116
13117 msglen = SIZE(msgout, 1)
13118 IF (msglen > 0) THEN
13119 CALL mpi_irecv(msgout(1), msglen, mpi_integer8, source, my_tag, &
13120 comm%handle, recv_request%handle, ierr)
13121 ELSE
13122 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13123 comm%handle, recv_request%handle, ierr)
13124 END IF
13125 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13126
13127 msglen = SIZE(msgin, 1)
13128 IF (msglen > 0) THEN
13129 CALL mpi_isend(msgin(1), msglen, mpi_integer8, dest, my_tag, &
13130 comm%handle, send_request%handle, ierr)
13131 ELSE
13132 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13133 comm%handle, send_request%handle, ierr)
13134 END IF
13135 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13136
13137 msglen = (msglen + SIZE(msgout, 1) + 1)/2
13138 CALL add_perf(perf_id=8, count=1, msg_size=msglen*int_8_size)
13139#else
13140 mark_used(dest)
13141 mark_used(source)
13142 mark_used(comm)
13143 mark_used(tag)
13144 send_request = mp_request_null
13145 recv_request = mp_request_null
13146 msgout = msgin
13147#endif
13148 CALL mp_timestop(handle)
13149 END SUBROUTINE mp_isendrecv_lv
13150
13151! **************************************************************************************************
13152!> \brief Non-blocking send of vector data
13153!> \param msgin ...
13154!> \param dest ...
13155!> \param comm ...
13156!> \param request ...
13157!> \param tag ...
13158!> \par History
13159!> 08.2003 created [f&j]
13160!> \note see mp_isendrecv_lv
13161!> \note
13162!> arrays can be pointers or assumed shape, but they must be contiguous!
13163! **************************************************************************************************
13164 SUBROUTINE mp_isend_lv(msgin, dest, comm, request, tag)
13165 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: msgin
13166 INTEGER, INTENT(IN) :: dest
13167 CLASS(mp_comm_type), INTENT(IN) :: comm
13168 TYPE(mp_request_type), INTENT(out) :: request
13169 INTEGER, INTENT(in), OPTIONAL :: tag
13170
13171 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lv'
13172
13173 INTEGER :: handle, ierr
13174#if defined(__parallel)
13175 INTEGER :: msglen, my_tag
13176 INTEGER(KIND=int_8) :: foo(1)
13177#endif
13178
13179 CALL mp_timeset(routinen, handle)
13180
13181#if defined(__parallel)
13182#if !defined(__GNUC__) || __GNUC__ >= 9
13183 cpassert(is_contiguous(msgin))
13184#endif
13185 my_tag = 0
13186 IF (PRESENT(tag)) my_tag = tag
13187
13188 msglen = SIZE(msgin)
13189 IF (msglen > 0) THEN
13190 CALL mpi_isend(msgin(1), msglen, mpi_integer8, dest, my_tag, &
13191 comm%handle, request%handle, ierr)
13192 ELSE
13193 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13194 comm%handle, request%handle, ierr)
13195 END IF
13196 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13197
13198 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13199#else
13200 mark_used(msgin)
13201 mark_used(dest)
13202 mark_used(comm)
13203 mark_used(request)
13204 mark_used(tag)
13205 ierr = 1
13206 request = mp_request_null
13207 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13208#endif
13209 CALL mp_timestop(handle)
13210 END SUBROUTINE mp_isend_lv
13211
13212! **************************************************************************************************
13213!> \brief Non-blocking send of matrix data
13214!> \param msgin ...
13215!> \param dest ...
13216!> \param comm ...
13217!> \param request ...
13218!> \param tag ...
13219!> \par History
13220!> 2009-11-25 [UB] Made type-generic for templates
13221!> \author fawzi
13222!> \note see mp_isendrecv_lv
13223!> \note see mp_isend_lv
13224!> \note
13225!> arrays can be pointers or assumed shape, but they must be contiguous!
13226! **************************************************************************************************
13227 SUBROUTINE mp_isend_lm2(msgin, dest, comm, request, tag)
13228 INTEGER(KIND=int_8), DIMENSION(:, :), INTENT(IN) :: msgin
13229 INTEGER, INTENT(IN) :: dest
13230 CLASS(mp_comm_type), INTENT(IN) :: comm
13231 TYPE(mp_request_type), INTENT(out) :: request
13232 INTEGER, INTENT(in), OPTIONAL :: tag
13233
13234 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm2'
13235
13236 INTEGER :: handle, ierr
13237#if defined(__parallel)
13238 INTEGER :: msglen, my_tag
13239 INTEGER(KIND=int_8) :: foo(1)
13240#endif
13241
13242 CALL mp_timeset(routinen, handle)
13243
13244#if defined(__parallel)
13245#if !defined(__GNUC__) || __GNUC__ >= 9
13246 cpassert(is_contiguous(msgin))
13247#endif
13248
13249 my_tag = 0
13250 IF (PRESENT(tag)) my_tag = tag
13251
13252 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
13253 IF (msglen > 0) THEN
13254 CALL mpi_isend(msgin(1, 1), msglen, mpi_integer8, dest, my_tag, &
13255 comm%handle, request%handle, ierr)
13256 ELSE
13257 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13258 comm%handle, request%handle, ierr)
13259 END IF
13260 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13261
13262 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13263#else
13264 mark_used(msgin)
13265 mark_used(dest)
13266 mark_used(comm)
13267 mark_used(request)
13268 mark_used(tag)
13269 ierr = 1
13270 request = mp_request_null
13271 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13272#endif
13273 CALL mp_timestop(handle)
13274 END SUBROUTINE mp_isend_lm2
13275
13276! **************************************************************************************************
13277!> \brief Non-blocking send of rank-3 data
13278!> \param msgin ...
13279!> \param dest ...
13280!> \param comm ...
13281!> \param request ...
13282!> \param tag ...
13283!> \par History
13284!> 9.2008 added _rm3 subroutine [Iain Bethune]
13285!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
13286!> 2009-11-25 [UB] Made type-generic for templates
13287!> \author fawzi
13288!> \note see mp_isendrecv_lv
13289!> \note see mp_isend_lv
13290!> \note
13291!> arrays can be pointers or assumed shape, but they must be contiguous!
13292! **************************************************************************************************
13293 SUBROUTINE mp_isend_lm3(msgin, dest, comm, request, tag)
13294 INTEGER(KIND=int_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
13295 INTEGER, INTENT(IN) :: dest
13296 CLASS(mp_comm_type), INTENT(IN) :: comm
13297 TYPE(mp_request_type), INTENT(out) :: request
13298 INTEGER, INTENT(in), OPTIONAL :: tag
13299
13300 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm3'
13301
13302 INTEGER :: handle, ierr
13303#if defined(__parallel)
13304 INTEGER :: msglen, my_tag
13305 INTEGER(KIND=int_8) :: foo(1)
13306#endif
13307
13308 CALL mp_timeset(routinen, handle)
13309
13310#if defined(__parallel)
13311#if !defined(__GNUC__) || __GNUC__ >= 9
13312 cpassert(is_contiguous(msgin))
13313#endif
13314
13315 my_tag = 0
13316 IF (PRESENT(tag)) my_tag = tag
13317
13318 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
13319 IF (msglen > 0) THEN
13320 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_integer8, dest, my_tag, &
13321 comm%handle, request%handle, ierr)
13322 ELSE
13323 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13324 comm%handle, request%handle, ierr)
13325 END IF
13326 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13327
13328 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13329#else
13330 mark_used(msgin)
13331 mark_used(dest)
13332 mark_used(comm)
13333 mark_used(request)
13334 mark_used(tag)
13335 ierr = 1
13336 request = mp_request_null
13337 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13338#endif
13339 CALL mp_timestop(handle)
13340 END SUBROUTINE mp_isend_lm3
13341
13342! **************************************************************************************************
13343!> \brief Non-blocking send of rank-4 data
13344!> \param msgin the input message
13345!> \param dest the destination processor
13346!> \param comm the communicator object
13347!> \param request the communication request id
13348!> \param tag the message tag
13349!> \par History
13350!> 2.2016 added _lm4 subroutine [Nico Holmberg]
13351!> \author fawzi
13352!> \note see mp_isend_lv
13353!> \note
13354!> arrays can be pointers or assumed shape, but they must be contiguous!
13355! **************************************************************************************************
13356 SUBROUTINE mp_isend_lm4(msgin, dest, comm, request, tag)
13357 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
13358 INTEGER, INTENT(IN) :: dest
13359 CLASS(mp_comm_type), INTENT(IN) :: comm
13360 TYPE(mp_request_type), INTENT(out) :: request
13361 INTEGER, INTENT(in), OPTIONAL :: tag
13362
13363 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm4'
13364
13365 INTEGER :: handle, ierr
13366#if defined(__parallel)
13367 INTEGER :: msglen, my_tag
13368 INTEGER(KIND=int_8) :: foo(1)
13369#endif
13370
13371 CALL mp_timeset(routinen, handle)
13372
13373#if defined(__parallel)
13374#if !defined(__GNUC__) || __GNUC__ >= 9
13375 cpassert(is_contiguous(msgin))
13376#endif
13377
13378 my_tag = 0
13379 IF (PRESENT(tag)) my_tag = tag
13380
13381 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
13382 IF (msglen > 0) THEN
13383 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_integer8, dest, my_tag, &
13384 comm%handle, request%handle, ierr)
13385 ELSE
13386 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13387 comm%handle, request%handle, ierr)
13388 END IF
13389 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13390
13391 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13392#else
13393 mark_used(msgin)
13394 mark_used(dest)
13395 mark_used(comm)
13396 mark_used(request)
13397 mark_used(tag)
13398 ierr = 1
13399 request = mp_request_null
13400 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13401#endif
13402 CALL mp_timestop(handle)
13403 END SUBROUTINE mp_isend_lm4
13404
13405! **************************************************************************************************
13406!> \brief Non-blocking receive of vector data
13407!> \param msgout ...
13408!> \param source ...
13409!> \param comm ...
13410!> \param request ...
13411!> \param tag ...
13412!> \par History
13413!> 08.2003 created [f&j]
13414!> 2009-11-25 [UB] Made type-generic for templates
13415!> \note see mp_isendrecv_lv
13416!> \note
13417!> arrays can be pointers or assumed shape, but they must be contiguous!
13418! **************************************************************************************************
13419 SUBROUTINE mp_irecv_lv(msgout, source, comm, request, tag)
13420 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT) :: msgout
13421 INTEGER, INTENT(IN) :: source
13422 CLASS(mp_comm_type), INTENT(IN) :: comm
13423 TYPE(mp_request_type), INTENT(out) :: request
13424 INTEGER, INTENT(in), OPTIONAL :: tag
13425
13426 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lv'
13427
13428 INTEGER :: handle
13429#if defined(__parallel)
13430 INTEGER :: ierr, msglen, my_tag
13431 INTEGER(KIND=int_8) :: foo(1)
13432#endif
13433
13434 CALL mp_timeset(routinen, handle)
13435
13436#if defined(__parallel)
13437#if !defined(__GNUC__) || __GNUC__ >= 9
13438 cpassert(is_contiguous(msgout))
13439#endif
13440
13441 my_tag = 0
13442 IF (PRESENT(tag)) my_tag = tag
13443
13444 msglen = SIZE(msgout)
13445 IF (msglen > 0) THEN
13446 CALL mpi_irecv(msgout(1), msglen, mpi_integer8, source, my_tag, &
13447 comm%handle, request%handle, ierr)
13448 ELSE
13449 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13450 comm%handle, request%handle, ierr)
13451 END IF
13452 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13453
13454 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13455#else
13456 cpabort("mp_irecv called in non parallel case")
13457 mark_used(msgout)
13458 mark_used(source)
13459 mark_used(comm)
13460 mark_used(tag)
13461 request = mp_request_null
13462#endif
13463 CALL mp_timestop(handle)
13464 END SUBROUTINE mp_irecv_lv
13465
13466! **************************************************************************************************
13467!> \brief Non-blocking receive of matrix data
13468!> \param msgout ...
13469!> \param source ...
13470!> \param comm ...
13471!> \param request ...
13472!> \param tag ...
13473!> \par History
13474!> 2009-11-25 [UB] Made type-generic for templates
13475!> \author fawzi
13476!> \note see mp_isendrecv_lv
13477!> \note see mp_irecv_lv
13478!> \note
13479!> arrays can be pointers or assumed shape, but they must be contiguous!
13480! **************************************************************************************************
13481 SUBROUTINE mp_irecv_lm2(msgout, source, comm, request, tag)
13482 INTEGER(KIND=int_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
13483 INTEGER, INTENT(IN) :: source
13484 CLASS(mp_comm_type), INTENT(IN) :: comm
13485 TYPE(mp_request_type), INTENT(out) :: request
13486 INTEGER, INTENT(in), OPTIONAL :: tag
13487
13488 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm2'
13489
13490 INTEGER :: handle
13491#if defined(__parallel)
13492 INTEGER :: ierr, msglen, my_tag
13493 INTEGER(KIND=int_8) :: foo(1)
13494#endif
13495
13496 CALL mp_timeset(routinen, handle)
13497
13498#if defined(__parallel)
13499#if !defined(__GNUC__) || __GNUC__ >= 9
13500 cpassert(is_contiguous(msgout))
13501#endif
13502
13503 my_tag = 0
13504 IF (PRESENT(tag)) my_tag = tag
13505
13506 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
13507 IF (msglen > 0) THEN
13508 CALL mpi_irecv(msgout(1, 1), msglen, mpi_integer8, source, my_tag, &
13509 comm%handle, request%handle, ierr)
13510 ELSE
13511 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13512 comm%handle, request%handle, ierr)
13513 END IF
13514 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13515
13516 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13517#else
13518 mark_used(msgout)
13519 mark_used(source)
13520 mark_used(comm)
13521 mark_used(tag)
13522 request = mp_request_null
13523 cpabort("mp_irecv called in non parallel case")
13524#endif
13525 CALL mp_timestop(handle)
13526 END SUBROUTINE mp_irecv_lm2
13527
13528! **************************************************************************************************
13529!> \brief Non-blocking send of rank-3 data
13530!> \param msgout ...
13531!> \param source ...
13532!> \param comm ...
13533!> \param request ...
13534!> \param tag ...
13535!> \par History
13536!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
13537!> 2009-11-25 [UB] Made type-generic for templates
13538!> \author fawzi
13539!> \note see mp_isendrecv_lv
13540!> \note see mp_irecv_lv
13541!> \note
13542!> arrays can be pointers or assumed shape, but they must be contiguous!
13543! **************************************************************************************************
13544 SUBROUTINE mp_irecv_lm3(msgout, source, comm, request, tag)
13545 INTEGER(KIND=int_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
13546 INTEGER, INTENT(IN) :: source
13547 CLASS(mp_comm_type), INTENT(IN) :: comm
13548 TYPE(mp_request_type), INTENT(out) :: request
13549 INTEGER, INTENT(in), OPTIONAL :: tag
13550
13551 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm3'
13552
13553 INTEGER :: handle
13554#if defined(__parallel)
13555 INTEGER :: ierr, msglen, my_tag
13556 INTEGER(KIND=int_8) :: foo(1)
13557#endif
13558
13559 CALL mp_timeset(routinen, handle)
13560
13561#if defined(__parallel)
13562#if !defined(__GNUC__) || __GNUC__ >= 9
13563 cpassert(is_contiguous(msgout))
13564#endif
13565
13566 my_tag = 0
13567 IF (PRESENT(tag)) my_tag = tag
13568
13569 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
13570 IF (msglen > 0) THEN
13571 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_integer8, source, my_tag, &
13572 comm%handle, request%handle, ierr)
13573 ELSE
13574 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13575 comm%handle, request%handle, ierr)
13576 END IF
13577 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
13578
13579 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13580#else
13581 mark_used(msgout)
13582 mark_used(source)
13583 mark_used(comm)
13584 mark_used(tag)
13585 request = mp_request_null
13586 cpabort("mp_irecv called in non parallel case")
13587#endif
13588 CALL mp_timestop(handle)
13589 END SUBROUTINE mp_irecv_lm3
13590
13591! **************************************************************************************************
13592!> \brief Non-blocking receive of rank-4 data
13593!> \param msgout the output message
13594!> \param source the source processor
13595!> \param comm the communicator object
13596!> \param request the communication request id
13597!> \param tag the message tag
13598!> \par History
13599!> 2.2016 added _lm4 subroutine [Nico Holmberg]
13600!> \author fawzi
13601!> \note see mp_irecv_lv
13602!> \note
13603!> arrays can be pointers or assumed shape, but they must be contiguous!
13604! **************************************************************************************************
13605 SUBROUTINE mp_irecv_lm4(msgout, source, comm, request, tag)
13606 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
13607 INTEGER, INTENT(IN) :: source
13608 CLASS(mp_comm_type), INTENT(IN) :: comm
13609 TYPE(mp_request_type), INTENT(out) :: request
13610 INTEGER, INTENT(in), OPTIONAL :: tag
13611
13612 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm4'
13613
13614 INTEGER :: handle
13615#if defined(__parallel)
13616 INTEGER :: ierr, msglen, my_tag
13617 INTEGER(KIND=int_8) :: foo(1)
13618#endif
13619
13620 CALL mp_timeset(routinen, handle)
13621
13622#if defined(__parallel)
13623#if !defined(__GNUC__) || __GNUC__ >= 9
13624 cpassert(is_contiguous(msgout))
13625#endif
13626
13627 my_tag = 0
13628 IF (PRESENT(tag)) my_tag = tag
13629
13630 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
13631 IF (msglen > 0) THEN
13632 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_integer8, source, my_tag, &
13633 comm%handle, request%handle, ierr)
13634 ELSE
13635 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13636 comm%handle, request%handle, ierr)
13637 END IF
13638 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
13639
13640 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13641#else
13642 mark_used(msgout)
13643 mark_used(source)
13644 mark_used(comm)
13645 mark_used(tag)
13646 request = mp_request_null
13647 cpabort("mp_irecv called in non parallel case")
13648#endif
13649 CALL mp_timestop(handle)
13650 END SUBROUTINE mp_irecv_lm4
13651
13652! **************************************************************************************************
13653!> \brief Window initialization function for vector data
13654!> \param base ...
13655!> \param comm ...
13656!> \param win ...
13657!> \par History
13658!> 02.2015 created [Alfio Lazzaro]
13659!> \note
13660!> arrays can be pointers or assumed shape, but they must be contiguous!
13661! **************************************************************************************************
13662 SUBROUTINE mp_win_create_lv(base, comm, win)
13663 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
13664 TYPE(mp_comm_type), INTENT(IN) :: comm
13665 CLASS(mp_win_type), INTENT(INOUT) :: win
13666
13667 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_lv'
13668
13669 INTEGER :: handle
13670#if defined(__parallel)
13671 INTEGER :: ierr
13672 INTEGER(kind=mpi_address_kind) :: len
13673 INTEGER(KIND=int_8) :: foo(1)
13674#endif
13675
13676 CALL mp_timeset(routinen, handle)
13677
13678#if defined(__parallel)
13679
13680 len = SIZE(base)*int_8_size
13681 IF (len > 0) THEN
13682 CALL mpi_win_create(base(1), len, int_8_size, mpi_info_null, comm%handle, win%handle, ierr)
13683 ELSE
13684 CALL mpi_win_create(foo, len, int_8_size, mpi_info_null, comm%handle, win%handle, ierr)
13685 END IF
13686 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
13687
13688 CALL add_perf(perf_id=20, count=1)
13689#else
13690 mark_used(base)
13691 mark_used(comm)
13692 win%handle = mp_win_null_handle
13693#endif
13694 CALL mp_timestop(handle)
13695 END SUBROUTINE mp_win_create_lv
13696
13697! **************************************************************************************************
13698!> \brief Single-sided get function for vector data
13699!> \param base ...
13700!> \param comm ...
13701!> \param win ...
13702!> \par History
13703!> 02.2015 created [Alfio Lazzaro]
13704!> \note
13705!> arrays can be pointers or assumed shape, but they must be contiguous!
13706! **************************************************************************************************
13707 SUBROUTINE mp_rget_lv(base, source, win, win_data, myproc, disp, request, &
13708 origin_datatype, target_datatype)
13709 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
13710 INTEGER, INTENT(IN) :: source
13711 CLASS(mp_win_type), INTENT(IN) :: win
13712 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: win_data
13713 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
13714 TYPE(mp_request_type), INTENT(OUT) :: request
13715 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
13716
13717 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_lv'
13718
13719 INTEGER :: handle
13720#if defined(__parallel)
13721 INTEGER :: ierr, len, &
13722 origin_len, target_len
13723 LOGICAL :: do_local_copy
13724 INTEGER(kind=mpi_address_kind) :: disp_aint
13725 mpi_data_type :: handle_origin_datatype, handle_target_datatype
13726#endif
13727
13728 CALL mp_timeset(routinen, handle)
13729
13730#if defined(__parallel)
13731 len = SIZE(base)
13732 disp_aint = 0
13733 IF (PRESENT(disp)) THEN
13734 disp_aint = int(disp, kind=mpi_address_kind)
13735 END IF
13736 handle_origin_datatype = mpi_integer8
13737 origin_len = len
13738 IF (PRESENT(origin_datatype)) THEN
13739 handle_origin_datatype = origin_datatype%type_handle
13740 origin_len = 1
13741 END IF
13742 handle_target_datatype = mpi_integer8
13743 target_len = len
13744 IF (PRESENT(target_datatype)) THEN
13745 handle_target_datatype = target_datatype%type_handle
13746 target_len = 1
13747 END IF
13748 IF (len > 0) THEN
13749 do_local_copy = .false.
13750 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
13751 IF (myproc .EQ. source) do_local_copy = .true.
13752 END IF
13753 IF (do_local_copy) THEN
13754 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
13755 base(:) = win_data(disp_aint + 1:disp_aint + len)
13756 !$OMP END PARALLEL WORKSHARE
13757 request = mp_request_null
13758 ierr = 0
13759 ELSE
13760 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
13761 target_len, handle_target_datatype, win%handle, request%handle, ierr)
13762 END IF
13763 ELSE
13764 request = mp_request_null
13765 ierr = 0
13766 END IF
13767 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
13768
13769 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*int_8_size)
13770#else
13771 mark_used(source)
13772 mark_used(win)
13773 mark_used(myproc)
13774 mark_used(origin_datatype)
13775 mark_used(target_datatype)
13776
13777 request = mp_request_null
13778 !
13779 IF (PRESENT(disp)) THEN
13780 base(:) = win_data(disp + 1:disp + SIZE(base))
13781 ELSE
13782 base(:) = win_data(:SIZE(base))
13783 END IF
13784
13785#endif
13786 CALL mp_timestop(handle)
13787 END SUBROUTINE mp_rget_lv
13788
13789! **************************************************************************************************
13790!> \brief ...
13791!> \param count ...
13792!> \param lengths ...
13793!> \param displs ...
13794!> \return ...
13795! ***************************************************************************
13796 FUNCTION mp_type_indexed_make_l (count, lengths, displs) &
13797 result(type_descriptor)
13798 INTEGER, INTENT(IN) :: count
13799 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
13800 TYPE(mp_type_descriptor_type) :: type_descriptor
13801
13802 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_l'
13803
13804 INTEGER :: handle
13805#if defined(__parallel)
13806 INTEGER :: ierr
13807#endif
13808
13809 CALL mp_timeset(routinen, handle)
13810
13811#if defined(__parallel)
13812 CALL mpi_type_indexed(count, lengths, displs, mpi_integer8, &
13813 type_descriptor%type_handle, ierr)
13814 IF (ierr /= 0) &
13815 cpabort("MPI_Type_Indexed @ "//routinen)
13816 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
13817 IF (ierr /= 0) &
13818 cpabort("MPI_Type_commit @ "//routinen)
13819#else
13820 type_descriptor%type_handle = 19
13821#endif
13822 type_descriptor%length = count
13823 NULLIFY (type_descriptor%subtype)
13824 type_descriptor%vector_descriptor(1:2) = 1
13825 type_descriptor%has_indexing = .true.
13826 type_descriptor%index_descriptor%index => lengths
13827 type_descriptor%index_descriptor%chunks => displs
13828
13829 CALL mp_timestop(handle)
13830
13831 END FUNCTION mp_type_indexed_make_l
13832
13833! **************************************************************************************************
13834!> \brief Allocates special parallel memory
13835!> \param[in] DATA pointer to integer array to allocate
13836!> \param[in] len number of integers to allocate
13837!> \param[out] stat (optional) allocation status result
13838!> \author UB
13839! **************************************************************************************************
13840 SUBROUTINE mp_allocate_l (DATA, len, stat)
13841 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
13842 INTEGER, INTENT(IN) :: len
13843 INTEGER, INTENT(OUT), OPTIONAL :: stat
13844
13845 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_l'
13846
13847 INTEGER :: handle, ierr
13848
13849 CALL mp_timeset(routinen, handle)
13850
13851#if defined(__parallel)
13852 NULLIFY (data)
13853 CALL mp_alloc_mem(DATA, len, stat=ierr)
13854 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
13855 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
13856 CALL add_perf(perf_id=15, count=1)
13857#else
13858 ALLOCATE (DATA(len), stat=ierr)
13859 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
13860 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
13861#endif
13862 IF (PRESENT(stat)) stat = ierr
13863 CALL mp_timestop(handle)
13864 END SUBROUTINE mp_allocate_l
13865
13866! **************************************************************************************************
13867!> \brief Deallocates special parallel memory
13868!> \param[in] DATA pointer to special memory to deallocate
13869!> \param stat ...
13870!> \author UB
13871! **************************************************************************************************
13872 SUBROUTINE mp_deallocate_l (DATA, stat)
13873 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
13874 INTEGER, INTENT(OUT), OPTIONAL :: stat
13875
13876 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_l'
13877
13878 INTEGER :: handle
13879#if defined(__parallel)
13880 INTEGER :: ierr
13881#endif
13882
13883 CALL mp_timeset(routinen, handle)
13884
13885#if defined(__parallel)
13886 CALL mp_free_mem(DATA, ierr)
13887 IF (PRESENT(stat)) THEN
13888 stat = ierr
13889 ELSE
13890 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
13891 END IF
13892 NULLIFY (data)
13893 CALL add_perf(perf_id=15, count=1)
13894#else
13895 DEALLOCATE (data)
13896 IF (PRESENT(stat)) stat = 0
13897#endif
13898 CALL mp_timestop(handle)
13899 END SUBROUTINE mp_deallocate_l
13900
13901! **************************************************************************************************
13902!> \brief (parallel) Blocking individual file write using explicit offsets
13903!> (serial) Unformatted stream write
13904!> \param[in] fh file handle (file storage unit)
13905!> \param[in] offset file offset (position)
13906!> \param[in] msg data to be written to the file
13907!> \param msglen ...
13908!> \par MPI-I/O mapping mpi_file_write_at
13909!> \par STREAM-I/O mapping WRITE
13910!> \param[in](optional) msglen number of the elements of data
13911! **************************************************************************************************
13912 SUBROUTINE mp_file_write_at_lv(fh, offset, msg, msglen)
13913 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
13914 CLASS(mp_file_type), INTENT(IN) :: fh
13915 INTEGER, INTENT(IN), OPTIONAL :: msglen
13916 INTEGER(kind=file_offset), INTENT(IN) :: offset
13917
13918 INTEGER :: msg_len
13919#if defined(__parallel)
13920 INTEGER :: ierr
13921#endif
13922
13923 msg_len = SIZE(msg)
13924 IF (PRESENT(msglen)) msg_len = msglen
13925#if defined(__parallel)
13926 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
13927 IF (ierr .NE. 0) &
13928 cpabort("mpi_file_write_at_lv @ mp_file_write_at_lv")
13929#else
13930 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
13931#endif
13932 END SUBROUTINE mp_file_write_at_lv
13933
13934! **************************************************************************************************
13935!> \brief ...
13936!> \param fh ...
13937!> \param offset ...
13938!> \param msg ...
13939! **************************************************************************************************
13940 SUBROUTINE mp_file_write_at_l (fh, offset, msg)
13941 INTEGER(KIND=int_8), INTENT(IN) :: msg
13942 CLASS(mp_file_type), INTENT(IN) :: fh
13943 INTEGER(kind=file_offset), INTENT(IN) :: offset
13944
13945#if defined(__parallel)
13946 INTEGER :: ierr
13947
13948 ierr = 0
13949 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
13950 IF (ierr .NE. 0) &
13951 cpabort("mpi_file_write_at_l @ mp_file_write_at_l")
13952#else
13953 WRITE (unit=fh%handle, pos=offset + 1) msg
13954#endif
13955 END SUBROUTINE mp_file_write_at_l
13956
13957! **************************************************************************************************
13958!> \brief (parallel) Blocking collective file write using explicit offsets
13959!> (serial) Unformatted stream write
13960!> \param fh ...
13961!> \param offset ...
13962!> \param msg ...
13963!> \param msglen ...
13964!> \par MPI-I/O mapping mpi_file_write_at_all
13965!> \par STREAM-I/O mapping WRITE
13966! **************************************************************************************************
13967 SUBROUTINE mp_file_write_at_all_lv(fh, offset, msg, msglen)
13968 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
13969 CLASS(mp_file_type), INTENT(IN) :: fh
13970 INTEGER, INTENT(IN), OPTIONAL :: msglen
13971 INTEGER(kind=file_offset), INTENT(IN) :: offset
13972
13973 INTEGER :: msg_len
13974#if defined(__parallel)
13975 INTEGER :: ierr
13976#endif
13977
13978 msg_len = SIZE(msg)
13979 IF (PRESENT(msglen)) msg_len = msglen
13980#if defined(__parallel)
13981 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
13982 IF (ierr .NE. 0) &
13983 cpabort("mpi_file_write_at_all_lv @ mp_file_write_at_all_lv")
13984#else
13985 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
13986#endif
13987 END SUBROUTINE mp_file_write_at_all_lv
13988
13989! **************************************************************************************************
13990!> \brief ...
13991!> \param fh ...
13992!> \param offset ...
13993!> \param msg ...
13994! **************************************************************************************************
13995 SUBROUTINE mp_file_write_at_all_l (fh, offset, msg)
13996 INTEGER(KIND=int_8), INTENT(IN) :: msg
13997 CLASS(mp_file_type), INTENT(IN) :: fh
13998 INTEGER(kind=file_offset), INTENT(IN) :: offset
13999
14000#if defined(__parallel)
14001 INTEGER :: ierr
14002
14003 ierr = 0
14004 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14005 IF (ierr .NE. 0) &
14006 cpabort("mpi_file_write_at_all_l @ mp_file_write_at_all_l")
14007#else
14008 WRITE (unit=fh%handle, pos=offset + 1) msg
14009#endif
14010 END SUBROUTINE mp_file_write_at_all_l
14011
14012! **************************************************************************************************
14013!> \brief (parallel) Blocking individual file read using explicit offsets
14014!> (serial) Unformatted stream read
14015!> \param[in] fh file handle (file storage unit)
14016!> \param[in] offset file offset (position)
14017!> \param[out] msg data to be read from the file
14018!> \param msglen ...
14019!> \par MPI-I/O mapping mpi_file_read_at
14020!> \par STREAM-I/O mapping READ
14021!> \param[in](optional) msglen number of elements of data
14022! **************************************************************************************************
14023 SUBROUTINE mp_file_read_at_lv(fh, offset, msg, msglen)
14024 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msg(:)
14025 CLASS(mp_file_type), INTENT(IN) :: fh
14026 INTEGER, INTENT(IN), OPTIONAL :: msglen
14027 INTEGER(kind=file_offset), INTENT(IN) :: offset
14028
14029 INTEGER :: msg_len
14030#if defined(__parallel)
14031 INTEGER :: ierr
14032#endif
14033
14034 msg_len = SIZE(msg)
14035 IF (PRESENT(msglen)) msg_len = msglen
14036#if defined(__parallel)
14037 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14038 IF (ierr .NE. 0) &
14039 cpabort("mpi_file_read_at_lv @ mp_file_read_at_lv")
14040#else
14041 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14042#endif
14043 END SUBROUTINE mp_file_read_at_lv
14044
14045! **************************************************************************************************
14046!> \brief ...
14047!> \param fh ...
14048!> \param offset ...
14049!> \param msg ...
14050! **************************************************************************************************
14051 SUBROUTINE mp_file_read_at_l (fh, offset, msg)
14052 INTEGER(KIND=int_8), INTENT(OUT) :: msg
14053 CLASS(mp_file_type), INTENT(IN) :: fh
14054 INTEGER(kind=file_offset), INTENT(IN) :: offset
14055
14056#if defined(__parallel)
14057 INTEGER :: ierr
14058
14059 ierr = 0
14060 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14061 IF (ierr .NE. 0) &
14062 cpabort("mpi_file_read_at_l @ mp_file_read_at_l")
14063#else
14064 READ (unit=fh%handle, pos=offset + 1) msg
14065#endif
14066 END SUBROUTINE mp_file_read_at_l
14067
14068! **************************************************************************************************
14069!> \brief (parallel) Blocking collective file read using explicit offsets
14070!> (serial) Unformatted stream read
14071!> \param fh ...
14072!> \param offset ...
14073!> \param msg ...
14074!> \param msglen ...
14075!> \par MPI-I/O mapping mpi_file_read_at_all
14076!> \par STREAM-I/O mapping READ
14077! **************************************************************************************************
14078 SUBROUTINE mp_file_read_at_all_lv(fh, offset, msg, msglen)
14079 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msg(:)
14080 CLASS(mp_file_type), INTENT(IN) :: fh
14081 INTEGER, INTENT(IN), OPTIONAL :: msglen
14082 INTEGER(kind=file_offset), INTENT(IN) :: offset
14083
14084 INTEGER :: msg_len
14085#if defined(__parallel)
14086 INTEGER :: ierr
14087#endif
14088
14089 msg_len = SIZE(msg)
14090 IF (PRESENT(msglen)) msg_len = msglen
14091#if defined(__parallel)
14092 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14093 IF (ierr .NE. 0) &
14094 cpabort("mpi_file_read_at_all_lv @ mp_file_read_at_all_lv")
14095#else
14096 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14097#endif
14098 END SUBROUTINE mp_file_read_at_all_lv
14099
14100! **************************************************************************************************
14101!> \brief ...
14102!> \param fh ...
14103!> \param offset ...
14104!> \param msg ...
14105! **************************************************************************************************
14106 SUBROUTINE mp_file_read_at_all_l (fh, offset, msg)
14107 INTEGER(KIND=int_8), INTENT(OUT) :: msg
14108 CLASS(mp_file_type), INTENT(IN) :: fh
14109 INTEGER(kind=file_offset), INTENT(IN) :: offset
14110
14111#if defined(__parallel)
14112 INTEGER :: ierr
14113
14114 ierr = 0
14115 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14116 IF (ierr .NE. 0) &
14117 cpabort("mpi_file_read_at_all_l @ mp_file_read_at_all_l")
14118#else
14119 READ (unit=fh%handle, pos=offset + 1) msg
14120#endif
14121 END SUBROUTINE mp_file_read_at_all_l
14122
14123! **************************************************************************************************
14124!> \brief ...
14125!> \param ptr ...
14126!> \param vector_descriptor ...
14127!> \param index_descriptor ...
14128!> \return ...
14129! **************************************************************************************************
14130 FUNCTION mp_type_make_l (ptr, &
14131 vector_descriptor, index_descriptor) &
14132 result(type_descriptor)
14133 INTEGER(KIND=int_8), DIMENSION(:), TARGET, asynchronous :: ptr
14134 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
14135 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
14136 TYPE(mp_type_descriptor_type) :: type_descriptor
14137
14138 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_l'
14139
14140#if defined(__parallel)
14141 INTEGER :: ierr
14142#if defined(__MPI_F08)
14143 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
14144 EXTERNAL :: mpi_get_address
14145#endif
14146#endif
14147
14148 NULLIFY (type_descriptor%subtype)
14149 type_descriptor%length = SIZE(ptr)
14150#if defined(__parallel)
14151 type_descriptor%type_handle = mpi_integer8
14152 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
14153 IF (ierr /= 0) &
14154 cpabort("MPI_Get_address @ "//routinen)
14155#else
14156 type_descriptor%type_handle = 19
14157#endif
14158 type_descriptor%vector_descriptor(1:2) = 1
14159 type_descriptor%has_indexing = .false.
14160 type_descriptor%data_l => ptr
14161 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
14162 cpabort(routinen//": Vectors and indices NYI")
14163 END IF
14164 END FUNCTION mp_type_make_l
14165
14166! **************************************************************************************************
14167!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
14168!> as the Fortran version returns an integer, which we take to be a C_PTR
14169!> \param DATA data array to allocate
14170!> \param[in] len length (in data elements) of data array allocation
14171!> \param[out] stat (optional) allocation status result
14172! **************************************************************************************************
14173 SUBROUTINE mp_alloc_mem_l (DATA, len, stat)
14174 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: data
14175 INTEGER, INTENT(IN) :: len
14176 INTEGER, INTENT(OUT), OPTIONAL :: stat
14177
14178#if defined(__parallel)
14179 INTEGER :: size, ierr, length, &
14180 mp_res
14181 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
14182 TYPE(c_ptr) :: mp_baseptr
14183 mpi_info_type :: mp_info
14184
14185 length = max(len, 1)
14186 CALL mpi_type_size(mpi_integer8, size, ierr)
14187 mp_size = int(length, kind=mpi_address_kind)*size
14188 IF (mp_size .GT. mp_max_memory_size) THEN
14189 cpabort("MPI cannot allocate more than 2 GiByte")
14190 END IF
14191 mp_info = mpi_info_null
14192 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
14193 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
14194 IF (PRESENT(stat)) stat = mp_res
14195#else
14196 INTEGER :: length, mystat
14197 length = max(len, 1)
14198 IF (PRESENT(stat)) THEN
14199 ALLOCATE (DATA(length), stat=mystat)
14200 stat = mystat ! show to convention checker that stat is used
14201 ELSE
14202 ALLOCATE (DATA(length))
14203 END IF
14204#endif
14205 END SUBROUTINE mp_alloc_mem_l
14206
14207! **************************************************************************************************
14208!> \brief Deallocates am array, ... this is hackish
14209!> as the Fortran version takes an integer, which we hope to get by reference
14210!> \param DATA data array to allocate
14211!> \param[out] stat (optional) allocation status result
14212! **************************************************************************************************
14213 SUBROUTINE mp_free_mem_l (DATA, stat)
14214 INTEGER(KIND=int_8), DIMENSION(:), &
14215 POINTER, asynchronous :: data
14216 INTEGER, INTENT(OUT), OPTIONAL :: stat
14217
14218#if defined(__parallel)
14219 INTEGER :: mp_res
14220 CALL mpi_free_mem(DATA, mp_res)
14221 IF (PRESENT(stat)) stat = mp_res
14222#else
14223 DEALLOCATE (data)
14224 IF (PRESENT(stat)) stat = 0
14225#endif
14226 END SUBROUTINE mp_free_mem_l
14227! **************************************************************************************************
14228!> \brief Shift around the data in msg
14229!> \param[in,out] msg Rank-2 data to shift
14230!> \param[in] comm message passing environment identifier
14231!> \param[in] displ_in displacements (?)
14232!> \par Example
14233!> msg will be moved from rank to rank+displ_in (in a circular way)
14234!> \par Limitations
14235!> * displ_in will be 1 by default (others not tested)
14236!> * the message array needs to be the same size on all processes
14237! **************************************************************************************************
14238 SUBROUTINE mp_shift_dm(msg, comm, displ_in)
14239
14240 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
14241 CLASS(mp_comm_type), INTENT(IN) :: comm
14242 INTEGER, INTENT(IN), OPTIONAL :: displ_in
14243
14244 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_dm'
14245
14246 INTEGER :: handle, ierror
14247#if defined(__parallel)
14248 INTEGER :: displ, left, &
14249 msglen, myrank, nprocs, &
14250 right, tag
14251#endif
14252
14253 ierror = 0
14254 CALL mp_timeset(routinen, handle)
14255
14256#if defined(__parallel)
14257 CALL mpi_comm_rank(comm%handle, myrank, ierror)
14258 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
14259 CALL mpi_comm_size(comm%handle, nprocs, ierror)
14260 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
14261 IF (PRESENT(displ_in)) THEN
14262 displ = displ_in
14263 ELSE
14264 displ = 1
14265 END IF
14266 right = modulo(myrank + displ, nprocs)
14267 left = modulo(myrank - displ, nprocs)
14268 tag = 17
14269 msglen = SIZE(msg)
14270 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_precision, right, tag, left, tag, &
14271 comm%handle, mpi_status_ignore, ierror)
14272 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
14273 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_8_size)
14274#else
14275 mark_used(msg)
14276 mark_used(comm)
14277 mark_used(displ_in)
14278#endif
14279 CALL mp_timestop(handle)
14280
14281 END SUBROUTINE mp_shift_dm
14282
14283! **************************************************************************************************
14284!> \brief Shift around the data in msg
14285!> \param[in,out] msg Data to shift
14286!> \param[in] comm message passing environment identifier
14287!> \param[in] displ_in displacements (?)
14288!> \par Example
14289!> msg will be moved from rank to rank+displ_in (in a circular way)
14290!> \par Limitations
14291!> * displ_in will be 1 by default (others not tested)
14292!> * the message array needs to be the same size on all processes
14293! **************************************************************************************************
14294 SUBROUTINE mp_shift_d (msg, comm, displ_in)
14295
14296 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
14297 CLASS(mp_comm_type), INTENT(IN) :: comm
14298 INTEGER, INTENT(IN), OPTIONAL :: displ_in
14299
14300 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_d'
14301
14302 INTEGER :: handle, ierror
14303#if defined(__parallel)
14304 INTEGER :: displ, left, &
14305 msglen, myrank, nprocs, &
14306 right, tag
14307#endif
14308
14309 ierror = 0
14310 CALL mp_timeset(routinen, handle)
14311
14312#if defined(__parallel)
14313 CALL mpi_comm_rank(comm%handle, myrank, ierror)
14314 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
14315 CALL mpi_comm_size(comm%handle, nprocs, ierror)
14316 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
14317 IF (PRESENT(displ_in)) THEN
14318 displ = displ_in
14319 ELSE
14320 displ = 1
14321 END IF
14322 right = modulo(myrank + displ, nprocs)
14323 left = modulo(myrank - displ, nprocs)
14324 tag = 19
14325 msglen = SIZE(msg)
14326 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_precision, right, tag, left, &
14327 tag, comm%handle, mpi_status_ignore, ierror)
14328 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
14329 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_8_size)
14330#else
14331 mark_used(msg)
14332 mark_used(comm)
14333 mark_used(displ_in)
14334#endif
14335 CALL mp_timestop(handle)
14336
14337 END SUBROUTINE mp_shift_d
14338
14339! **************************************************************************************************
14340!> \brief All-to-all data exchange, rank-1 data of different sizes
14341!> \param[in] sb Data to send
14342!> \param[in] scount Data counts for data sent to other processes
14343!> \param[in] sdispl Respective data offsets for data sent to process
14344!> \param[in,out] rb Buffer into which to receive data
14345!> \param[in] rcount Data counts for data received from other
14346!> processes
14347!> \param[in] rdispl Respective data offsets for data received from
14348!> other processes
14349!> \param[in] comm Message passing environment identifier
14350!> \par MPI mapping
14351!> mpi_alltoallv
14352!> \par Array sizes
14353!> The scount, rcount, and the sdispl and rdispl arrays have a
14354!> size equal to the number of processes.
14355!> \par Offsets
14356!> Values in sdispl and rdispl start with 0.
14357! **************************************************************************************************
14358 SUBROUTINE mp_alltoall_d11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
14359
14360 REAL(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
14361 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
14362 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
14363 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
14364 CLASS(mp_comm_type), INTENT(IN) :: comm
14365
14366 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d11v'
14367
14368 INTEGER :: handle
14369#if defined(__parallel)
14370 INTEGER :: ierr, msglen
14371#else
14372 INTEGER :: i
14373#endif
14374
14375 CALL mp_timeset(routinen, handle)
14376
14377#if defined(__parallel)
14378 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_precision, &
14379 rb, rcount, rdispl, mpi_double_precision, comm%handle, ierr)
14380 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
14381 msglen = sum(scount) + sum(rcount)
14382 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14383#else
14384 mark_used(comm)
14385 mark_used(scount)
14386 mark_used(sdispl)
14387 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
14388 DO i = 1, rcount(1)
14389 rb(rdispl(1) + i) = sb(sdispl(1) + i)
14390 END DO
14391#endif
14392 CALL mp_timestop(handle)
14393
14394 END SUBROUTINE mp_alltoall_d11v
14395
14396! **************************************************************************************************
14397!> \brief All-to-all data exchange, rank-2 data of different sizes
14398!> \param sb ...
14399!> \param scount ...
14400!> \param sdispl ...
14401!> \param rb ...
14402!> \param rcount ...
14403!> \param rdispl ...
14404!> \param comm ...
14405!> \par MPI mapping
14406!> mpi_alltoallv
14407!> \note see mp_alltoall_d11v
14408! **************************************************************************************************
14409 SUBROUTINE mp_alltoall_d22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
14410
14411 REAL(kind=real_8), DIMENSION(:, :), &
14412 INTENT(IN), CONTIGUOUS :: sb
14413 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
14414 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, &
14415 INTENT(INOUT) :: rb
14416 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
14417 CLASS(mp_comm_type), INTENT(IN) :: comm
14418
14419 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d22v'
14420
14421 INTEGER :: handle
14422#if defined(__parallel)
14423 INTEGER :: ierr, msglen
14424#endif
14425
14426 CALL mp_timeset(routinen, handle)
14427
14428#if defined(__parallel)
14429 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_precision, &
14430 rb, rcount, rdispl, mpi_double_precision, comm%handle, ierr)
14431 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
14432 msglen = sum(scount) + sum(rcount)
14433 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*real_8_size)
14434#else
14435 mark_used(comm)
14436 mark_used(scount)
14437 mark_used(sdispl)
14438 mark_used(rcount)
14439 mark_used(rdispl)
14440 rb = sb
14441#endif
14442 CALL mp_timestop(handle)
14443
14444 END SUBROUTINE mp_alltoall_d22v
14445
14446! **************************************************************************************************
14447!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
14448!> \param[in] sb array with data to send
14449!> \param[out] rb array into which data is received
14450!> \param[in] count number of elements to send/receive (product of the
14451!> extents of the first two dimensions)
14452!> \param[in] comm Message passing environment identifier
14453!> \par Index meaning
14454!> \par The first two indices specify the data while the last index counts
14455!> the processes
14456!> \par Sizes of ranks
14457!> All processes have the same data size.
14458!> \par MPI mapping
14459!> mpi_alltoall
14460! **************************************************************************************************
14461 SUBROUTINE mp_alltoall_d (sb, rb, count, comm)
14462
14463 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
14464 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
14465 INTEGER, INTENT(IN) :: count
14466 CLASS(mp_comm_type), INTENT(IN) :: comm
14467
14468 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d'
14469
14470 INTEGER :: handle
14471#if defined(__parallel)
14472 INTEGER :: ierr, msglen, np
14473#endif
14474
14475 CALL mp_timeset(routinen, handle)
14476
14477#if defined(__parallel)
14478 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14479 rb, count, mpi_double_precision, comm%handle, ierr)
14480 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14481 CALL mpi_comm_size(comm%handle, np, ierr)
14482 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14483 msglen = 2*count*np
14484 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14485#else
14486 mark_used(count)
14487 mark_used(comm)
14488 rb = sb
14489#endif
14490 CALL mp_timestop(handle)
14491
14492 END SUBROUTINE mp_alltoall_d
14493
14494! **************************************************************************************************
14495!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
14496!> \param sb ...
14497!> \param rb ...
14498!> \param count ...
14499!> \param commp ...
14500!> \note see mp_alltoall_d
14501! **************************************************************************************************
14502 SUBROUTINE mp_alltoall_d22(sb, rb, count, comm)
14503
14504 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
14505 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
14506 INTEGER, INTENT(IN) :: count
14507 CLASS(mp_comm_type), INTENT(IN) :: comm
14508
14509 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d22'
14510
14511 INTEGER :: handle
14512#if defined(__parallel)
14513 INTEGER :: ierr, msglen, np
14514#endif
14515
14516 CALL mp_timeset(routinen, handle)
14517
14518#if defined(__parallel)
14519 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14520 rb, count, mpi_double_precision, comm%handle, ierr)
14521 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14522 CALL mpi_comm_size(comm%handle, np, ierr)
14523 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14524 msglen = 2*SIZE(sb)*np
14525 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14526#else
14527 mark_used(count)
14528 mark_used(comm)
14529 rb = sb
14530#endif
14531 CALL mp_timestop(handle)
14532
14533 END SUBROUTINE mp_alltoall_d22
14534
14535! **************************************************************************************************
14536!> \brief All-to-all data exchange, rank-3 data with equal sizes
14537!> \param sb ...
14538!> \param rb ...
14539!> \param count ...
14540!> \param comm ...
14541!> \note see mp_alltoall_d
14542! **************************************************************************************************
14543 SUBROUTINE mp_alltoall_d33(sb, rb, count, comm)
14544
14545 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
14546 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
14547 INTEGER, INTENT(IN) :: count
14548 CLASS(mp_comm_type), INTENT(IN) :: comm
14549
14550 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d33'
14551
14552 INTEGER :: handle
14553#if defined(__parallel)
14554 INTEGER :: ierr, msglen, np
14555#endif
14556
14557 CALL mp_timeset(routinen, handle)
14558
14559#if defined(__parallel)
14560 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14561 rb, count, mpi_double_precision, comm%handle, ierr)
14562 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14563 CALL mpi_comm_size(comm%handle, np, ierr)
14564 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14565 msglen = 2*count*np
14566 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14567#else
14568 mark_used(count)
14569 mark_used(comm)
14570 rb = sb
14571#endif
14572 CALL mp_timestop(handle)
14573
14574 END SUBROUTINE mp_alltoall_d33
14575
14576! **************************************************************************************************
14577!> \brief All-to-all data exchange, rank 4 data, equal sizes
14578!> \param sb ...
14579!> \param rb ...
14580!> \param count ...
14581!> \param comm ...
14582!> \note see mp_alltoall_d
14583! **************************************************************************************************
14584 SUBROUTINE mp_alltoall_d44(sb, rb, count, comm)
14585
14586 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14587 INTENT(IN) :: sb
14588 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14589 INTENT(OUT) :: rb
14590 INTEGER, INTENT(IN) :: count
14591 CLASS(mp_comm_type), INTENT(IN) :: comm
14592
14593 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d44'
14594
14595 INTEGER :: handle
14596#if defined(__parallel)
14597 INTEGER :: ierr, msglen, np
14598#endif
14599
14600 CALL mp_timeset(routinen, handle)
14601
14602#if defined(__parallel)
14603 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14604 rb, count, mpi_double_precision, comm%handle, ierr)
14605 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14606 CALL mpi_comm_size(comm%handle, np, ierr)
14607 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14608 msglen = 2*count*np
14609 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14610#else
14611 mark_used(count)
14612 mark_used(comm)
14613 rb = sb
14614#endif
14615 CALL mp_timestop(handle)
14616
14617 END SUBROUTINE mp_alltoall_d44
14618
14619! **************************************************************************************************
14620!> \brief All-to-all data exchange, rank 5 data, equal sizes
14621!> \param sb ...
14622!> \param rb ...
14623!> \param count ...
14624!> \param comm ...
14625!> \note see mp_alltoall_d
14626! **************************************************************************************************
14627 SUBROUTINE mp_alltoall_d55(sb, rb, count, comm)
14628
14629 REAL(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
14630 INTENT(IN) :: sb
14631 REAL(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
14632 INTENT(OUT) :: rb
14633 INTEGER, INTENT(IN) :: count
14634 CLASS(mp_comm_type), INTENT(IN) :: comm
14635
14636 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d55'
14637
14638 INTEGER :: handle
14639#if defined(__parallel)
14640 INTEGER :: ierr, msglen, np
14641#endif
14642
14643 CALL mp_timeset(routinen, handle)
14644
14645#if defined(__parallel)
14646 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14647 rb, count, mpi_double_precision, comm%handle, ierr)
14648 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14649 CALL mpi_comm_size(comm%handle, np, ierr)
14650 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14651 msglen = 2*count*np
14652 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14653#else
14654 mark_used(count)
14655 mark_used(comm)
14656 rb = sb
14657#endif
14658 CALL mp_timestop(handle)
14659
14660 END SUBROUTINE mp_alltoall_d55
14661
14662! **************************************************************************************************
14663!> \brief All-to-all data exchange, rank-4 data to rank-5 data
14664!> \param sb ...
14665!> \param rb ...
14666!> \param count ...
14667!> \param comm ...
14668!> \note see mp_alltoall_d
14669!> \note User must ensure size consistency.
14670! **************************************************************************************************
14671 SUBROUTINE mp_alltoall_d45(sb, rb, count, comm)
14672
14673 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14674 INTENT(IN) :: sb
14675 REAL(kind=real_8), &
14676 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
14677 INTEGER, INTENT(IN) :: count
14678 CLASS(mp_comm_type), INTENT(IN) :: comm
14679
14680 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d45'
14681
14682 INTEGER :: handle
14683#if defined(__parallel)
14684 INTEGER :: ierr, msglen, np
14685#endif
14686
14687 CALL mp_timeset(routinen, handle)
14688
14689#if defined(__parallel)
14690 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14691 rb, count, mpi_double_precision, comm%handle, ierr)
14692 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14693 CALL mpi_comm_size(comm%handle, np, ierr)
14694 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14695 msglen = 2*count*np
14696 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14697#else
14698 mark_used(count)
14699 mark_used(comm)
14700 rb = reshape(sb, shape(rb))
14701#endif
14702 CALL mp_timestop(handle)
14703
14704 END SUBROUTINE mp_alltoall_d45
14705
14706! **************************************************************************************************
14707!> \brief All-to-all data exchange, rank-3 data to rank-4 data
14708!> \param sb ...
14709!> \param rb ...
14710!> \param count ...
14711!> \param comm ...
14712!> \note see mp_alltoall_d
14713!> \note User must ensure size consistency.
14714! **************************************************************************************************
14715 SUBROUTINE mp_alltoall_d34(sb, rb, count, comm)
14716
14717 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, &
14718 INTENT(IN) :: sb
14719 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14720 INTENT(OUT) :: rb
14721 INTEGER, INTENT(IN) :: count
14722 CLASS(mp_comm_type), INTENT(IN) :: comm
14723
14724 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d34'
14725
14726 INTEGER :: handle
14727#if defined(__parallel)
14728 INTEGER :: ierr, msglen, np
14729#endif
14730
14731 CALL mp_timeset(routinen, handle)
14732
14733#if defined(__parallel)
14734 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14735 rb, count, mpi_double_precision, comm%handle, ierr)
14736 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14737 CALL mpi_comm_size(comm%handle, np, ierr)
14738 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14739 msglen = 2*count*np
14740 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14741#else
14742 mark_used(count)
14743 mark_used(comm)
14744 rb = reshape(sb, shape(rb))
14745#endif
14746 CALL mp_timestop(handle)
14747
14748 END SUBROUTINE mp_alltoall_d34
14749
14750! **************************************************************************************************
14751!> \brief All-to-all data exchange, rank-5 data to rank-4 data
14752!> \param sb ...
14753!> \param rb ...
14754!> \param count ...
14755!> \param comm ...
14756!> \note see mp_alltoall_d
14757!> \note User must ensure size consistency.
14758! **************************************************************************************************
14759 SUBROUTINE mp_alltoall_d54(sb, rb, count, comm)
14760
14761 REAL(kind=real_8), &
14762 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
14763 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14764 INTENT(OUT) :: rb
14765 INTEGER, INTENT(IN) :: count
14766 CLASS(mp_comm_type), INTENT(IN) :: comm
14767
14768 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d54'
14769
14770 INTEGER :: handle
14771#if defined(__parallel)
14772 INTEGER :: ierr, msglen, np
14773#endif
14774
14775 CALL mp_timeset(routinen, handle)
14776
14777#if defined(__parallel)
14778 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14779 rb, count, mpi_double_precision, comm%handle, ierr)
14780 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14781 CALL mpi_comm_size(comm%handle, np, ierr)
14782 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14783 msglen = 2*count*np
14784 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14785#else
14786 mark_used(count)
14787 mark_used(comm)
14788 rb = reshape(sb, shape(rb))
14789#endif
14790 CALL mp_timestop(handle)
14791
14792 END SUBROUTINE mp_alltoall_d54
14793
14794! **************************************************************************************************
14795!> \brief Send one datum to another process
14796!> \param[in] msg Scalar to send
14797!> \param[in] dest Destination process
14798!> \param[in] tag Transfer identifier
14799!> \param[in] comm Message passing environment identifier
14800!> \par MPI mapping
14801!> mpi_send
14802! **************************************************************************************************
14803 SUBROUTINE mp_send_d (msg, dest, tag, comm)
14804 REAL(kind=real_8), INTENT(IN) :: msg
14805 INTEGER, INTENT(IN) :: dest, tag
14806 CLASS(mp_comm_type), INTENT(IN) :: comm
14807
14808 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_d'
14809
14810 INTEGER :: handle
14811#if defined(__parallel)
14812 INTEGER :: ierr, msglen
14813#endif
14814
14815 CALL mp_timeset(routinen, handle)
14816
14817#if defined(__parallel)
14818 msglen = 1
14819 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
14820 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
14821 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
14822#else
14823 mark_used(msg)
14824 mark_used(dest)
14825 mark_used(tag)
14826 mark_used(comm)
14827 ! only defined in parallel
14828 cpabort("not in parallel mode")
14829#endif
14830 CALL mp_timestop(handle)
14831 END SUBROUTINE mp_send_d
14832
14833! **************************************************************************************************
14834!> \brief Send rank-1 data to another process
14835!> \param[in] msg Rank-1 data to send
14836!> \param dest ...
14837!> \param tag ...
14838!> \param comm ...
14839!> \note see mp_send_d
14840! **************************************************************************************************
14841 SUBROUTINE mp_send_dv(msg, dest, tag, comm)
14842 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
14843 INTEGER, INTENT(IN) :: dest, tag
14844 CLASS(mp_comm_type), INTENT(IN) :: comm
14845
14846 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_dv'
14847
14848 INTEGER :: handle
14849#if defined(__parallel)
14850 INTEGER :: ierr, msglen
14851#endif
14852
14853 CALL mp_timeset(routinen, handle)
14854
14855#if defined(__parallel)
14856 msglen = SIZE(msg)
14857 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
14858 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
14859 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
14860#else
14861 mark_used(msg)
14862 mark_used(dest)
14863 mark_used(tag)
14864 mark_used(comm)
14865 ! only defined in parallel
14866 cpabort("not in parallel mode")
14867#endif
14868 CALL mp_timestop(handle)
14869 END SUBROUTINE mp_send_dv
14870
14871! **************************************************************************************************
14872!> \brief Send rank-2 data to another process
14873!> \param[in] msg Rank-2 data to send
14874!> \param dest ...
14875!> \param tag ...
14876!> \param comm ...
14877!> \note see mp_send_d
14878! **************************************************************************************************
14879 SUBROUTINE mp_send_dm2(msg, dest, tag, comm)
14880 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
14881 INTEGER, INTENT(IN) :: dest, tag
14882 CLASS(mp_comm_type), INTENT(IN) :: comm
14883
14884 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_dm2'
14885
14886 INTEGER :: handle
14887#if defined(__parallel)
14888 INTEGER :: ierr, msglen
14889#endif
14890
14891 CALL mp_timeset(routinen, handle)
14892
14893#if defined(__parallel)
14894 msglen = SIZE(msg)
14895 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
14896 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
14897 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
14898#else
14899 mark_used(msg)
14900 mark_used(dest)
14901 mark_used(tag)
14902 mark_used(comm)
14903 ! only defined in parallel
14904 cpabort("not in parallel mode")
14905#endif
14906 CALL mp_timestop(handle)
14907 END SUBROUTINE mp_send_dm2
14908
14909! **************************************************************************************************
14910!> \brief Send rank-3 data to another process
14911!> \param[in] msg Rank-3 data to send
14912!> \param dest ...
14913!> \param tag ...
14914!> \param comm ...
14915!> \note see mp_send_d
14916! **************************************************************************************************
14917 SUBROUTINE mp_send_dm3(msg, dest, tag, comm)
14918 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
14919 INTEGER, INTENT(IN) :: dest, tag
14920 CLASS(mp_comm_type), INTENT(IN) :: comm
14921
14922 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
14923
14924 INTEGER :: handle
14925#if defined(__parallel)
14926 INTEGER :: ierr, msglen
14927#endif
14928
14929 CALL mp_timeset(routinen, handle)
14930
14931#if defined(__parallel)
14932 msglen = SIZE(msg)
14933 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
14934 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
14935 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
14936#else
14937 mark_used(msg)
14938 mark_used(dest)
14939 mark_used(tag)
14940 mark_used(comm)
14941 ! only defined in parallel
14942 cpabort("not in parallel mode")
14943#endif
14944 CALL mp_timestop(handle)
14945 END SUBROUTINE mp_send_dm3
14946
14947! **************************************************************************************************
14948!> \brief Receive one datum from another process
14949!> \param[in,out] msg Place received data into this variable
14950!> \param[in,out] source Process to receive from
14951!> \param[in,out] tag Transfer identifier
14952!> \param[in] comm Message passing environment identifier
14953!> \par MPI mapping
14954!> mpi_send
14955! **************************************************************************************************
14956 SUBROUTINE mp_recv_d (msg, source, tag, comm)
14957 REAL(kind=real_8), INTENT(INOUT) :: msg
14958 INTEGER, INTENT(INOUT) :: source, tag
14959 CLASS(mp_comm_type), INTENT(IN) :: comm
14960
14961 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_d'
14962
14963 INTEGER :: handle
14964#if defined(__parallel)
14965 INTEGER :: ierr, msglen
14966 mpi_status_type :: status
14967#endif
14968
14969 CALL mp_timeset(routinen, handle)
14970
14971#if defined(__parallel)
14972 msglen = 1
14973 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
14974 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
14975 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
14976 ELSE
14977 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
14978 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
14979 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
14980 source = status mpi_status_extract(mpi_source)
14981 tag = status mpi_status_extract(mpi_tag)
14982 END IF
14983#else
14984 mark_used(msg)
14985 mark_used(source)
14986 mark_used(tag)
14987 mark_used(comm)
14988 ! only defined in parallel
14989 cpabort("not in parallel mode")
14990#endif
14991 CALL mp_timestop(handle)
14992 END SUBROUTINE mp_recv_d
14993
14994! **************************************************************************************************
14995!> \brief Receive rank-1 data from another process
14996!> \param[in,out] msg Place received data into this rank-1 array
14997!> \param source ...
14998!> \param tag ...
14999!> \param comm ...
15000!> \note see mp_recv_d
15001! **************************************************************************************************
15002 SUBROUTINE mp_recv_dv(msg, source, tag, comm)
15003 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15004 INTEGER, INTENT(INOUT) :: source, tag
15005 CLASS(mp_comm_type), INTENT(IN) :: comm
15006
15007 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dv'
15008
15009 INTEGER :: handle
15010#if defined(__parallel)
15011 INTEGER :: ierr, msglen
15012 mpi_status_type :: status
15013#endif
15014
15015 CALL mp_timeset(routinen, handle)
15016
15017#if defined(__parallel)
15018 msglen = SIZE(msg)
15019 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15020 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15021 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15022 ELSE
15023 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15024 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15025 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15026 source = status mpi_status_extract(mpi_source)
15027 tag = status mpi_status_extract(mpi_tag)
15028 END IF
15029#else
15030 mark_used(msg)
15031 mark_used(source)
15032 mark_used(tag)
15033 mark_used(comm)
15034 ! only defined in parallel
15035 cpabort("not in parallel mode")
15036#endif
15037 CALL mp_timestop(handle)
15038 END SUBROUTINE mp_recv_dv
15039
15040! **************************************************************************************************
15041!> \brief Receive rank-2 data from another process
15042!> \param[in,out] msg Place received data into this rank-2 array
15043!> \param source ...
15044!> \param tag ...
15045!> \param comm ...
15046!> \note see mp_recv_d
15047! **************************************************************************************************
15048 SUBROUTINE mp_recv_dm2(msg, source, tag, comm)
15049 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15050 INTEGER, INTENT(INOUT) :: source, tag
15051 CLASS(mp_comm_type), INTENT(IN) :: comm
15052
15053 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dm2'
15054
15055 INTEGER :: handle
15056#if defined(__parallel)
15057 INTEGER :: ierr, msglen
15058 mpi_status_type :: status
15059#endif
15060
15061 CALL mp_timeset(routinen, handle)
15062
15063#if defined(__parallel)
15064 msglen = SIZE(msg)
15065 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15066 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15067 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15068 ELSE
15069 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15070 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15071 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15072 source = status mpi_status_extract(mpi_source)
15073 tag = status mpi_status_extract(mpi_tag)
15074 END IF
15075#else
15076 mark_used(msg)
15077 mark_used(source)
15078 mark_used(tag)
15079 mark_used(comm)
15080 ! only defined in parallel
15081 cpabort("not in parallel mode")
15082#endif
15083 CALL mp_timestop(handle)
15084 END SUBROUTINE mp_recv_dm2
15085
15086! **************************************************************************************************
15087!> \brief Receive rank-3 data from another process
15088!> \param[in,out] msg Place received data into this rank-3 array
15089!> \param source ...
15090!> \param tag ...
15091!> \param comm ...
15092!> \note see mp_recv_d
15093! **************************************************************************************************
15094 SUBROUTINE mp_recv_dm3(msg, source, tag, comm)
15095 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
15096 INTEGER, INTENT(INOUT) :: source, tag
15097 CLASS(mp_comm_type), INTENT(IN) :: comm
15098
15099 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dm3'
15100
15101 INTEGER :: handle
15102#if defined(__parallel)
15103 INTEGER :: ierr, msglen
15104 mpi_status_type :: status
15105#endif
15106
15107 CALL mp_timeset(routinen, handle)
15108
15109#if defined(__parallel)
15110 msglen = SIZE(msg)
15111 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15112 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15113 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15114 ELSE
15115 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15116 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15117 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15118 source = status mpi_status_extract(mpi_source)
15119 tag = status mpi_status_extract(mpi_tag)
15120 END IF
15121#else
15122 mark_used(msg)
15123 mark_used(source)
15124 mark_used(tag)
15125 mark_used(comm)
15126 ! only defined in parallel
15127 cpabort("not in parallel mode")
15128#endif
15129 CALL mp_timestop(handle)
15130 END SUBROUTINE mp_recv_dm3
15131
15132! **************************************************************************************************
15133!> \brief Broadcasts a datum to all processes.
15134!> \param[in] msg Datum to broadcast
15135!> \param[in] source Processes which broadcasts
15136!> \param[in] comm Message passing environment identifier
15137!> \par MPI mapping
15138!> mpi_bcast
15139! **************************************************************************************************
15140 SUBROUTINE mp_bcast_d (msg, source, comm)
15141 REAL(kind=real_8), INTENT(INOUT) :: msg
15142 INTEGER, INTENT(IN) :: source
15143 CLASS(mp_comm_type), INTENT(IN) :: comm
15144
15145 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d'
15146
15147 INTEGER :: handle
15148#if defined(__parallel)
15149 INTEGER :: ierr, msglen
15150#endif
15151
15152 CALL mp_timeset(routinen, handle)
15153
15154#if defined(__parallel)
15155 msglen = 1
15156 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15157 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15158 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15159#else
15160 mark_used(msg)
15161 mark_used(source)
15162 mark_used(comm)
15163#endif
15164 CALL mp_timestop(handle)
15165 END SUBROUTINE mp_bcast_d
15166
15167! **************************************************************************************************
15168!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
15169!> \param[in] msg Datum to broadcast
15170!> \param[in] comm Message passing environment identifier
15171!> \par MPI mapping
15172!> mpi_bcast
15173! **************************************************************************************************
15174 SUBROUTINE mp_bcast_d_src(msg, comm)
15175 REAL(kind=real_8), INTENT(INOUT) :: msg
15176 CLASS(mp_comm_type), INTENT(IN) :: comm
15177
15178 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d_src'
15179
15180 INTEGER :: handle
15181#if defined(__parallel)
15182 INTEGER :: ierr, msglen
15183#endif
15184
15185 CALL mp_timeset(routinen, handle)
15186
15187#if defined(__parallel)
15188 msglen = 1
15189 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15190 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15191 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15192#else
15193 mark_used(msg)
15194 mark_used(comm)
15195#endif
15196 CALL mp_timestop(handle)
15197 END SUBROUTINE mp_bcast_d_src
15198
15199! **************************************************************************************************
15200!> \brief Broadcasts a datum to all processes.
15201!> \param[in] msg Datum to broadcast
15202!> \param[in] source Processes which broadcasts
15203!> \param[in] comm Message passing environment identifier
15204!> \par MPI mapping
15205!> mpi_bcast
15206! **************************************************************************************************
15207 SUBROUTINE mp_ibcast_d (msg, source, comm, request)
15208 REAL(kind=real_8), INTENT(INOUT) :: msg
15209 INTEGER, INTENT(IN) :: source
15210 CLASS(mp_comm_type), INTENT(IN) :: comm
15211 TYPE(mp_request_type), INTENT(OUT) :: request
15212
15213 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_d'
15214
15215 INTEGER :: handle
15216#if defined(__parallel)
15217 INTEGER :: ierr, msglen
15218#endif
15219
15220 CALL mp_timeset(routinen, handle)
15221
15222#if defined(__parallel)
15223 msglen = 1
15224 CALL mpi_ibcast(msg, msglen, mpi_double_precision, source, comm%handle, request%handle, ierr)
15225 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
15226 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_8_size)
15227#else
15228 mark_used(msg)
15229 mark_used(source)
15230 mark_used(comm)
15231 request = mp_request_null
15232#endif
15233 CALL mp_timestop(handle)
15234 END SUBROUTINE mp_ibcast_d
15235
15236! **************************************************************************************************
15237!> \brief Broadcasts rank-1 data to all processes
15238!> \param[in] msg Data to broadcast
15239!> \param source ...
15240!> \param comm ...
15241!> \note see mp_bcast_d1
15242! **************************************************************************************************
15243 SUBROUTINE mp_bcast_dv(msg, source, comm)
15244 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15245 INTEGER, INTENT(IN) :: source
15246 CLASS(mp_comm_type), INTENT(IN) :: comm
15247
15248 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dv'
15249
15250 INTEGER :: handle
15251#if defined(__parallel)
15252 INTEGER :: ierr, msglen
15253#endif
15254
15255 CALL mp_timeset(routinen, handle)
15256
15257#if defined(__parallel)
15258 msglen = SIZE(msg)
15259 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15260 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15261 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15262#else
15263 mark_used(msg)
15264 mark_used(source)
15265 mark_used(comm)
15266#endif
15267 CALL mp_timestop(handle)
15268 END SUBROUTINE mp_bcast_dv
15269
15270! **************************************************************************************************
15271!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
15272!> \param[in] msg Data to broadcast
15273!> \param comm ...
15274!> \note see mp_bcast_d1
15275! **************************************************************************************************
15276 SUBROUTINE mp_bcast_dv_src(msg, comm)
15277 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15278 CLASS(mp_comm_type), INTENT(IN) :: comm
15279
15280 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dv_src'
15281
15282 INTEGER :: handle
15283#if defined(__parallel)
15284 INTEGER :: ierr, msglen
15285#endif
15286
15287 CALL mp_timeset(routinen, handle)
15288
15289#if defined(__parallel)
15290 msglen = SIZE(msg)
15291 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15292 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15293 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15294#else
15295 mark_used(msg)
15296 mark_used(comm)
15297#endif
15298 CALL mp_timestop(handle)
15299 END SUBROUTINE mp_bcast_dv_src
15300
15301! **************************************************************************************************
15302!> \brief Broadcasts rank-1 data to all processes
15303!> \param[in] msg Data to broadcast
15304!> \param source ...
15305!> \param comm ...
15306!> \note see mp_bcast_d1
15307! **************************************************************************************************
15308 SUBROUTINE mp_ibcast_dv(msg, source, comm, request)
15309 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
15310 INTEGER, INTENT(IN) :: source
15311 CLASS(mp_comm_type), INTENT(IN) :: comm
15312 TYPE(mp_request_type) :: request
15313
15314 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_dv'
15315
15316 INTEGER :: handle
15317#if defined(__parallel)
15318 INTEGER :: ierr, msglen
15319#endif
15320
15321 CALL mp_timeset(routinen, handle)
15322
15323#if defined(__parallel)
15324#if !defined(__GNUC__) || __GNUC__ >= 9
15325 cpassert(is_contiguous(msg))
15326#endif
15327 msglen = SIZE(msg)
15328 CALL mpi_ibcast(msg, msglen, mpi_double_precision, source, comm%handle, request%handle, ierr)
15329 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
15330 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_8_size)
15331#else
15332 mark_used(msg)
15333 mark_used(source)
15334 mark_used(comm)
15335 request = mp_request_null
15336#endif
15337 CALL mp_timestop(handle)
15338 END SUBROUTINE mp_ibcast_dv
15339
15340! **************************************************************************************************
15341!> \brief Broadcasts rank-2 data to all processes
15342!> \param[in] msg Data to broadcast
15343!> \param source ...
15344!> \param comm ...
15345!> \note see mp_bcast_d1
15346! **************************************************************************************************
15347 SUBROUTINE mp_bcast_dm(msg, source, comm)
15348 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15349 INTEGER, INTENT(IN) :: source
15350 CLASS(mp_comm_type), INTENT(IN) :: comm
15351
15352 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dm'
15353
15354 INTEGER :: handle
15355#if defined(__parallel)
15356 INTEGER :: ierr, msglen
15357#endif
15358
15359 CALL mp_timeset(routinen, handle)
15360
15361#if defined(__parallel)
15362 msglen = SIZE(msg)
15363 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15364 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15365 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15366#else
15367 mark_used(msg)
15368 mark_used(source)
15369 mark_used(comm)
15370#endif
15371 CALL mp_timestop(handle)
15372 END SUBROUTINE mp_bcast_dm
15373
15374! **************************************************************************************************
15375!> \brief Broadcasts rank-2 data to all processes
15376!> \param[in] msg Data to broadcast
15377!> \param source ...
15378!> \param comm ...
15379!> \note see mp_bcast_d1
15380! **************************************************************************************************
15381 SUBROUTINE mp_bcast_dm_src(msg, comm)
15382 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15383 CLASS(mp_comm_type), INTENT(IN) :: comm
15384
15385 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dm_src'
15386
15387 INTEGER :: handle
15388#if defined(__parallel)
15389 INTEGER :: ierr, msglen
15390#endif
15391
15392 CALL mp_timeset(routinen, handle)
15393
15394#if defined(__parallel)
15395 msglen = SIZE(msg)
15396 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15397 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15398 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15399#else
15400 mark_used(msg)
15401 mark_used(comm)
15402#endif
15403 CALL mp_timestop(handle)
15404 END SUBROUTINE mp_bcast_dm_src
15405
15406! **************************************************************************************************
15407!> \brief Broadcasts rank-3 data to all processes
15408!> \param[in] msg Data to broadcast
15409!> \param source ...
15410!> \param comm ...
15411!> \note see mp_bcast_d1
15412! **************************************************************************************************
15413 SUBROUTINE mp_bcast_d3(msg, source, comm)
15414 REAL(kind=real_8), CONTIGUOUS :: msg(:, :, :)
15415 INTEGER, INTENT(IN) :: source
15416 CLASS(mp_comm_type), INTENT(IN) :: comm
15417
15418 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d3'
15419
15420 INTEGER :: handle
15421#if defined(__parallel)
15422 INTEGER :: ierr, msglen
15423#endif
15424
15425 CALL mp_timeset(routinen, handle)
15426
15427#if defined(__parallel)
15428 msglen = SIZE(msg)
15429 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15430 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15431 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15432#else
15433 mark_used(msg)
15434 mark_used(source)
15435 mark_used(comm)
15436#endif
15437 CALL mp_timestop(handle)
15438 END SUBROUTINE mp_bcast_d3
15439
15440! **************************************************************************************************
15441!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
15442!> \param[in] msg Data to broadcast
15443!> \param source ...
15444!> \param comm ...
15445!> \note see mp_bcast_d1
15446! **************************************************************************************************
15447 SUBROUTINE mp_bcast_d3_src(msg, comm)
15448 REAL(kind=real_8), CONTIGUOUS :: msg(:, :, :)
15449 CLASS(mp_comm_type), INTENT(IN) :: comm
15450
15451 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d3_src'
15452
15453 INTEGER :: handle
15454#if defined(__parallel)
15455 INTEGER :: ierr, msglen
15456#endif
15457
15458 CALL mp_timeset(routinen, handle)
15459
15460#if defined(__parallel)
15461 msglen = SIZE(msg)
15462 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15463 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15464 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15465#else
15466 mark_used(msg)
15467 mark_used(comm)
15468#endif
15469 CALL mp_timestop(handle)
15470 END SUBROUTINE mp_bcast_d3_src
15471
15472! **************************************************************************************************
15473!> \brief Sums a datum from all processes with result left on all processes.
15474!> \param[in,out] msg Datum to sum (input) and result (output)
15475!> \param[in] comm Message passing environment identifier
15476!> \par MPI mapping
15477!> mpi_allreduce
15478! **************************************************************************************************
15479 SUBROUTINE mp_sum_d (msg, comm)
15480 REAL(kind=real_8), INTENT(INOUT) :: msg
15481 CLASS(mp_comm_type), INTENT(IN) :: comm
15482
15483 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_d'
15484
15485 INTEGER :: handle
15486#if defined(__parallel)
15487 INTEGER :: ierr, msglen
15488#endif
15489
15490 CALL mp_timeset(routinen, handle)
15491
15492#if defined(__parallel)
15493 msglen = 1
15494 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15495 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15496 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15497#else
15498 mark_used(msg)
15499 mark_used(comm)
15500#endif
15501 CALL mp_timestop(handle)
15502 END SUBROUTINE mp_sum_d
15503
15504! **************************************************************************************************
15505!> \brief Element-wise sum of a rank-1 array on all processes.
15506!> \param[in,out] msg Vector to sum and result
15507!> \param comm ...
15508!> \note see mp_sum_d
15509! **************************************************************************************************
15510 SUBROUTINE mp_sum_dv(msg, comm)
15511 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15512 CLASS(mp_comm_type), INTENT(IN) :: comm
15513
15514 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dv'
15515
15516 INTEGER :: handle
15517#if defined(__parallel)
15518 INTEGER :: ierr, msglen
15519#endif
15520
15521 CALL mp_timeset(routinen, handle)
15522
15523#if defined(__parallel)
15524 msglen = SIZE(msg)
15525 IF (msglen > 0) THEN
15526 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15527 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15528 END IF
15529 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15530#else
15531 mark_used(msg)
15532 mark_used(comm)
15533#endif
15534 CALL mp_timestop(handle)
15535 END SUBROUTINE mp_sum_dv
15536
15537! **************************************************************************************************
15538!> \brief Element-wise sum of a rank-1 array on all processes.
15539!> \param[in,out] msg Vector to sum and result
15540!> \param comm ...
15541!> \note see mp_sum_d
15542! **************************************************************************************************
15543 SUBROUTINE mp_isum_dv(msg, comm, request)
15544 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
15545 CLASS(mp_comm_type), INTENT(IN) :: comm
15546 TYPE(mp_request_type), INTENT(OUT) :: request
15547
15548 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_dv'
15549
15550 INTEGER :: handle
15551#if defined(__parallel)
15552 INTEGER :: ierr, msglen
15553#endif
15554
15555 CALL mp_timeset(routinen, handle)
15556
15557#if defined(__parallel)
15558#if !defined(__GNUC__) || __GNUC__ >= 9
15559 cpassert(is_contiguous(msg))
15560#endif
15561 msglen = SIZE(msg)
15562 IF (msglen > 0) THEN
15563 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, request%handle, ierr)
15564 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
15565 ELSE
15566 request = mp_request_null
15567 END IF
15568 CALL add_perf(perf_id=23, count=1, msg_size=msglen*real_8_size)
15569#else
15570 mark_used(msg)
15571 mark_used(comm)
15572 request = mp_request_null
15573#endif
15574 CALL mp_timestop(handle)
15575 END SUBROUTINE mp_isum_dv
15576
15577! **************************************************************************************************
15578!> \brief Element-wise sum of a rank-2 array on all processes.
15579!> \param[in] msg Matrix to sum and result
15580!> \param comm ...
15581!> \note see mp_sum_d
15582! **************************************************************************************************
15583 SUBROUTINE mp_sum_dm(msg, comm)
15584 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15585 CLASS(mp_comm_type), INTENT(IN) :: comm
15586
15587 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm'
15588
15589 INTEGER :: handle
15590#if defined(__parallel)
15591 INTEGER, PARAMETER :: max_msg = 2**25
15592 INTEGER :: ierr, m1, msglen, step, msglensum
15593#endif
15594
15595 CALL mp_timeset(routinen, handle)
15596
15597#if defined(__parallel)
15598 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
15599 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
15600 msglensum = 0
15601 DO m1 = lbound(msg, 2), ubound(msg, 2), step
15602 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
15603 msglensum = msglensum + msglen
15604 IF (msglen > 0) THEN
15605 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15606 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15607 END IF
15608 END DO
15609 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_8_size)
15610#else
15611 mark_used(msg)
15612 mark_used(comm)
15613#endif
15614 CALL mp_timestop(handle)
15615 END SUBROUTINE mp_sum_dm
15616
15617! **************************************************************************************************
15618!> \brief Element-wise sum of a rank-3 array on all processes.
15619!> \param[in] msg Array to sum and result
15620!> \param comm ...
15621!> \note see mp_sum_d
15622! **************************************************************************************************
15623 SUBROUTINE mp_sum_dm3(msg, comm)
15624 REAL(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
15625 CLASS(mp_comm_type), INTENT(IN) :: comm
15626
15627 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm3'
15628
15629 INTEGER :: handle
15630#if defined(__parallel)
15631 INTEGER :: ierr, msglen
15632#endif
15633
15634 CALL mp_timeset(routinen, handle)
15635
15636#if defined(__parallel)
15637 msglen = SIZE(msg)
15638 IF (msglen > 0) THEN
15639 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15640 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15641 END IF
15642 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15643#else
15644 mark_used(msg)
15645 mark_used(comm)
15646#endif
15647 CALL mp_timestop(handle)
15648 END SUBROUTINE mp_sum_dm3
15649
15650! **************************************************************************************************
15651!> \brief Element-wise sum of a rank-4 array on all processes.
15652!> \param[in] msg Array to sum and result
15653!> \param comm ...
15654!> \note see mp_sum_d
15655! **************************************************************************************************
15656 SUBROUTINE mp_sum_dm4(msg, comm)
15657 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
15658 CLASS(mp_comm_type), INTENT(IN) :: comm
15659
15660 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm4'
15661
15662 INTEGER :: handle
15663#if defined(__parallel)
15664 INTEGER :: ierr, msglen
15665#endif
15666
15667 CALL mp_timeset(routinen, handle)
15668
15669#if defined(__parallel)
15670 msglen = SIZE(msg)
15671 IF (msglen > 0) THEN
15672 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15673 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15674 END IF
15675 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15676#else
15677 mark_used(msg)
15678 mark_used(comm)
15679#endif
15680 CALL mp_timestop(handle)
15681 END SUBROUTINE mp_sum_dm4
15682
15683! **************************************************************************************************
15684!> \brief Element-wise sum of data from all processes with result left only on
15685!> one.
15686!> \param[in,out] msg Vector to sum (input) and (only on process root)
15687!> result (output)
15688!> \param root ...
15689!> \param[in] comm Message passing environment identifier
15690!> \par MPI mapping
15691!> mpi_reduce
15692! **************************************************************************************************
15693 SUBROUTINE mp_sum_root_dv(msg, root, comm)
15694 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15695 INTEGER, INTENT(IN) :: root
15696 CLASS(mp_comm_type), INTENT(IN) :: comm
15697
15698 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_dv'
15699
15700 INTEGER :: handle
15701#if defined(__parallel)
15702 INTEGER :: ierr, m1, msglen, taskid
15703 REAL(kind=real_8), ALLOCATABLE :: res(:)
15704#endif
15705
15706 CALL mp_timeset(routinen, handle)
15707
15708#if defined(__parallel)
15709 msglen = SIZE(msg)
15710 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15711 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
15712 IF (msglen > 0) THEN
15713 m1 = SIZE(msg, 1)
15714 ALLOCATE (res(m1))
15715 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_sum, &
15716 root, comm%handle, ierr)
15717 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
15718 IF (taskid == root) THEN
15719 msg = res
15720 END IF
15721 DEALLOCATE (res)
15722 END IF
15723 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15724#else
15725 mark_used(msg)
15726 mark_used(root)
15727 mark_used(comm)
15728#endif
15729 CALL mp_timestop(handle)
15730 END SUBROUTINE mp_sum_root_dv
15731
15732! **************************************************************************************************
15733!> \brief Element-wise sum of data from all processes with result left only on
15734!> one.
15735!> \param[in,out] msg Matrix to sum (input) and (only on process root)
15736!> result (output)
15737!> \param root ...
15738!> \param comm ...
15739!> \note see mp_sum_root_dv
15740! **************************************************************************************************
15741 SUBROUTINE mp_sum_root_dm(msg, root, comm)
15742 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15743 INTEGER, INTENT(IN) :: root
15744 CLASS(mp_comm_type), INTENT(IN) :: comm
15745
15746 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
15747
15748 INTEGER :: handle
15749#if defined(__parallel)
15750 INTEGER :: ierr, m1, m2, msglen, taskid
15751 REAL(kind=real_8), ALLOCATABLE :: res(:, :)
15752#endif
15753
15754 CALL mp_timeset(routinen, handle)
15755
15756#if defined(__parallel)
15757 msglen = SIZE(msg)
15758 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15759 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
15760 IF (msglen > 0) THEN
15761 m1 = SIZE(msg, 1)
15762 m2 = SIZE(msg, 2)
15763 ALLOCATE (res(m1, m2))
15764 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_sum, root, comm%handle, ierr)
15765 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
15766 IF (taskid == root) THEN
15767 msg = res
15768 END IF
15769 DEALLOCATE (res)
15770 END IF
15771 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15772#else
15773 mark_used(root)
15774 mark_used(msg)
15775 mark_used(comm)
15776#endif
15777 CALL mp_timestop(handle)
15778 END SUBROUTINE mp_sum_root_dm
15779
15780! **************************************************************************************************
15781!> \brief Partial sum of data from all processes with result on each process.
15782!> \param[in] msg Matrix to sum (input)
15783!> \param[out] res Matrix containing result (output)
15784!> \param[in] comm Message passing environment identifier
15785! **************************************************************************************************
15786 SUBROUTINE mp_sum_partial_dm(msg, res, comm)
15787 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
15788 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
15789 CLASS(mp_comm_type), INTENT(IN) :: comm
15790
15791 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_dm'
15792
15793 INTEGER :: handle
15794#if defined(__parallel)
15795 INTEGER :: ierr, msglen, taskid
15796#endif
15797
15798 CALL mp_timeset(routinen, handle)
15799
15800#if defined(__parallel)
15801 msglen = SIZE(msg)
15802 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15803 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
15804 IF (msglen > 0) THEN
15805 CALL mpi_scan(msg, res, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15806 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
15807 END IF
15808 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15809 ! perf_id is same as for other summation routines
15810#else
15811 res = msg
15812 mark_used(comm)
15813#endif
15814 CALL mp_timestop(handle)
15815 END SUBROUTINE mp_sum_partial_dm
15816
15817! **************************************************************************************************
15818!> \brief Finds the maximum of a datum with the result left on all processes.
15819!> \param[in,out] msg Find maximum among these data (input) and
15820!> maximum (output)
15821!> \param[in] comm Message passing environment identifier
15822!> \par MPI mapping
15823!> mpi_allreduce
15824! **************************************************************************************************
15825 SUBROUTINE mp_max_d (msg, comm)
15826 REAL(kind=real_8), INTENT(INOUT) :: msg
15827 CLASS(mp_comm_type), INTENT(IN) :: comm
15828
15829 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_d'
15830
15831 INTEGER :: handle
15832#if defined(__parallel)
15833 INTEGER :: ierr, msglen
15834#endif
15835
15836 CALL mp_timeset(routinen, handle)
15837
15838#if defined(__parallel)
15839 msglen = 1
15840 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
15841 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15842 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15843#else
15844 mark_used(msg)
15845 mark_used(comm)
15846#endif
15847 CALL mp_timestop(handle)
15848 END SUBROUTINE mp_max_d
15849
15850! **************************************************************************************************
15851!> \brief Finds the maximum of a datum with the result left on all processes.
15852!> \param[in,out] msg Find maximum among these data (input) and
15853!> maximum (output)
15854!> \param[in] comm Message passing environment identifier
15855!> \par MPI mapping
15856!> mpi_allreduce
15857! **************************************************************************************************
15858 SUBROUTINE mp_max_root_d (msg, root, comm)
15859 REAL(kind=real_8), INTENT(INOUT) :: msg
15860 INTEGER, INTENT(IN) :: root
15861 CLASS(mp_comm_type), INTENT(IN) :: comm
15862
15863 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_d'
15864
15865 INTEGER :: handle
15866#if defined(__parallel)
15867 INTEGER :: ierr, msglen
15868 REAL(kind=real_8) :: res
15869#endif
15870
15871 CALL mp_timeset(routinen, handle)
15872
15873#if defined(__parallel)
15874 msglen = 1
15875 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_max, root, comm%handle, ierr)
15876 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
15877 IF (root == comm%mepos) msg = res
15878 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15879#else
15880 mark_used(msg)
15881 mark_used(comm)
15882 mark_used(root)
15883#endif
15884 CALL mp_timestop(handle)
15885 END SUBROUTINE mp_max_root_d
15886
15887! **************************************************************************************************
15888!> \brief Finds the element-wise maximum of a vector with the result left on
15889!> all processes.
15890!> \param[in,out] msg Find maximum among these data (input) and
15891!> maximum (output)
15892!> \param comm ...
15893!> \note see mp_max_d
15894! **************************************************************************************************
15895 SUBROUTINE mp_max_dv(msg, comm)
15896 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15897 CLASS(mp_comm_type), INTENT(IN) :: comm
15898
15899 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_dv'
15900
15901 INTEGER :: handle
15902#if defined(__parallel)
15903 INTEGER :: ierr, msglen
15904#endif
15905
15906 CALL mp_timeset(routinen, handle)
15907
15908#if defined(__parallel)
15909 msglen = SIZE(msg)
15910 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
15911 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15912 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15913#else
15914 mark_used(msg)
15915 mark_used(comm)
15916#endif
15917 CALL mp_timestop(handle)
15918 END SUBROUTINE mp_max_dv
15919
15920! **************************************************************************************************
15921!> \brief Finds the element-wise maximum of a vector with the result left on
15922!> all processes.
15923!> \param[in,out] msg Find maximum among these data (input) and
15924!> maximum (output)
15925!> \param comm ...
15926!> \note see mp_max_d
15927! **************************************************************************************************
15928 SUBROUTINE mp_max_root_dm(msg, root, comm)
15929 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15930 INTEGER :: root
15931 CLASS(mp_comm_type), INTENT(IN) :: comm
15932
15933 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_dm'
15934
15935 INTEGER :: handle
15936#if defined(__parallel)
15937 INTEGER :: ierr, msglen
15938 REAL(kind=real_8) :: res(SIZE(msg, 1), SIZE(msg, 2))
15939#endif
15940
15941 CALL mp_timeset(routinen, handle)
15942
15943#if defined(__parallel)
15944 msglen = SIZE(msg)
15945 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_max, root, comm%handle, ierr)
15946 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15947 IF (root == comm%mepos) msg = res
15948 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15949#else
15950 mark_used(msg)
15951 mark_used(comm)
15952 mark_used(root)
15953#endif
15954 CALL mp_timestop(handle)
15955 END SUBROUTINE mp_max_root_dm
15956
15957! **************************************************************************************************
15958!> \brief Finds the minimum of a datum with the result left on all processes.
15959!> \param[in,out] msg Find minimum among these data (input) and
15960!> maximum (output)
15961!> \param[in] comm Message passing environment identifier
15962!> \par MPI mapping
15963!> mpi_allreduce
15964! **************************************************************************************************
15965 SUBROUTINE mp_min_d (msg, comm)
15966 REAL(kind=real_8), INTENT(INOUT) :: msg
15967 CLASS(mp_comm_type), INTENT(IN) :: comm
15968
15969 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_d'
15970
15971 INTEGER :: handle
15972#if defined(__parallel)
15973 INTEGER :: ierr, msglen
15974#endif
15975
15976 CALL mp_timeset(routinen, handle)
15977
15978#if defined(__parallel)
15979 msglen = 1
15980 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
15981 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15982 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15983#else
15984 mark_used(msg)
15985 mark_used(comm)
15986#endif
15987 CALL mp_timestop(handle)
15988 END SUBROUTINE mp_min_d
15989
15990! **************************************************************************************************
15991!> \brief Finds the element-wise minimum of vector with the result left on
15992!> all processes.
15993!> \param[in,out] msg Find minimum among these data (input) and
15994!> maximum (output)
15995!> \param comm ...
15996!> \par MPI mapping
15997!> mpi_allreduce
15998!> \note see mp_min_d
15999! **************************************************************************************************
16000 SUBROUTINE mp_min_dv(msg, comm)
16001 REAL(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
16002 CLASS(mp_comm_type), INTENT(IN) :: comm
16003
16004 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_dv'
16005
16006 INTEGER :: handle
16007#if defined(__parallel)
16008 INTEGER :: ierr, msglen
16009#endif
16010
16011 CALL mp_timeset(routinen, handle)
16012
16013#if defined(__parallel)
16014 msglen = SIZE(msg)
16015 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
16016 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16017 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16018#else
16019 mark_used(msg)
16020 mark_used(comm)
16021#endif
16022 CALL mp_timestop(handle)
16023 END SUBROUTINE mp_min_dv
16024
16025! **************************************************************************************************
16026!> \brief Multiplies a set of numbers scattered across a number of processes,
16027!> then replicates the result.
16028!> \param[in,out] msg a number to multiply (input) and result (output)
16029!> \param[in] comm message passing environment identifier
16030!> \par MPI mapping
16031!> mpi_allreduce
16032! **************************************************************************************************
16033 SUBROUTINE mp_prod_d (msg, comm)
16034 REAL(kind=real_8), INTENT(INOUT) :: msg
16035 CLASS(mp_comm_type), INTENT(IN) :: comm
16036
16037 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_d'
16038
16039 INTEGER :: handle
16040#if defined(__parallel)
16041 INTEGER :: ierr, msglen
16042#endif
16043
16044 CALL mp_timeset(routinen, handle)
16045
16046#if defined(__parallel)
16047 msglen = 1
16048 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_prod, comm%handle, ierr)
16049 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16050 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16051#else
16052 mark_used(msg)
16053 mark_used(comm)
16054#endif
16055 CALL mp_timestop(handle)
16056 END SUBROUTINE mp_prod_d
16057
16058! **************************************************************************************************
16059!> \brief Scatters data from one processes to all others
16060!> \param[in] msg_scatter Data to scatter (for root process)
16061!> \param[out] msg Received data
16062!> \param[in] root Process which scatters data
16063!> \param[in] comm Message passing environment identifier
16064!> \par MPI mapping
16065!> mpi_scatter
16066! **************************************************************************************************
16067 SUBROUTINE mp_scatter_dv(msg_scatter, msg, root, comm)
16068 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
16069 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
16070 INTEGER, INTENT(IN) :: root
16071 CLASS(mp_comm_type), INTENT(IN) :: comm
16072
16073 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_dv'
16074
16075 INTEGER :: handle
16076#if defined(__parallel)
16077 INTEGER :: ierr, msglen
16078#endif
16079
16080 CALL mp_timeset(routinen, handle)
16081
16082#if defined(__parallel)
16083 msglen = SIZE(msg)
16084 CALL mpi_scatter(msg_scatter, msglen, mpi_double_precision, msg, &
16085 msglen, mpi_double_precision, root, comm%handle, ierr)
16086 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
16087 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16088#else
16089 mark_used(root)
16090 mark_used(comm)
16091 msg = msg_scatter
16092#endif
16093 CALL mp_timestop(handle)
16094 END SUBROUTINE mp_scatter_dv
16095
16096! **************************************************************************************************
16097!> \brief Scatters data from one processes to all others
16098!> \param[in] msg_scatter Data to scatter (for root process)
16099!> \param[in] root Process which scatters data
16100!> \param[in] comm Message passing environment identifier
16101!> \par MPI mapping
16102!> mpi_scatter
16103! **************************************************************************************************
16104 SUBROUTINE mp_iscatter_d (msg_scatter, msg, root, comm, request)
16105 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:)
16106 REAL(kind=real_8), INTENT(INOUT) :: msg
16107 INTEGER, INTENT(IN) :: root
16108 CLASS(mp_comm_type), INTENT(IN) :: comm
16109 TYPE(mp_request_type), INTENT(OUT) :: request
16110
16111 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_d'
16112
16113 INTEGER :: handle
16114#if defined(__parallel)
16115 INTEGER :: ierr, msglen
16116#endif
16117
16118 CALL mp_timeset(routinen, handle)
16119
16120#if defined(__parallel)
16121#if !defined(__GNUC__) || __GNUC__ >= 9
16122 cpassert(is_contiguous(msg_scatter))
16123#endif
16124 msglen = 1
16125 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_precision, msg, &
16126 msglen, mpi_double_precision, root, comm%handle, request%handle, ierr)
16127 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
16128 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16129#else
16130 mark_used(root)
16131 mark_used(comm)
16132 msg = msg_scatter(1)
16133 request = mp_request_null
16134#endif
16135 CALL mp_timestop(handle)
16136 END SUBROUTINE mp_iscatter_d
16137
16138! **************************************************************************************************
16139!> \brief Scatters data from one processes to all others
16140!> \param[in] msg_scatter Data to scatter (for root process)
16141!> \param[in] root Process which scatters data
16142!> \param[in] comm Message passing environment identifier
16143!> \par MPI mapping
16144!> mpi_scatter
16145! **************************************************************************************************
16146 SUBROUTINE mp_iscatter_dv2(msg_scatter, msg, root, comm, request)
16147 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:, :)
16148 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
16149 INTEGER, INTENT(IN) :: root
16150 CLASS(mp_comm_type), INTENT(IN) :: comm
16151 TYPE(mp_request_type), INTENT(OUT) :: request
16152
16153 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_dv2'
16154
16155 INTEGER :: handle
16156#if defined(__parallel)
16157 INTEGER :: ierr, msglen
16158#endif
16159
16160 CALL mp_timeset(routinen, handle)
16161
16162#if defined(__parallel)
16163#if !defined(__GNUC__) || __GNUC__ >= 9
16164 cpassert(is_contiguous(msg_scatter))
16165#endif
16166 msglen = SIZE(msg)
16167 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_precision, msg, &
16168 msglen, mpi_double_precision, root, comm%handle, request%handle, ierr)
16169 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
16170 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16171#else
16172 mark_used(root)
16173 mark_used(comm)
16174 msg(:) = msg_scatter(:, 1)
16175 request = mp_request_null
16176#endif
16177 CALL mp_timestop(handle)
16178 END SUBROUTINE mp_iscatter_dv2
16179
16180! **************************************************************************************************
16181!> \brief Scatters data from one processes to all others
16182!> \param[in] msg_scatter Data to scatter (for root process)
16183!> \param[in] root Process which scatters data
16184!> \param[in] comm Message passing environment identifier
16185!> \par MPI mapping
16186!> mpi_scatter
16187! **************************************************************************************************
16188 SUBROUTINE mp_iscatterv_dv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
16189 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:)
16190 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
16191 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
16192 INTEGER, INTENT(IN) :: recvcount, root
16193 CLASS(mp_comm_type), INTENT(IN) :: comm
16194 TYPE(mp_request_type), INTENT(OUT) :: request
16195
16196 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_dv'
16197
16198 INTEGER :: handle
16199#if defined(__parallel)
16200 INTEGER :: ierr
16201#endif
16202
16203 CALL mp_timeset(routinen, handle)
16204
16205#if defined(__parallel)
16206#if !defined(__GNUC__) || __GNUC__ >= 9
16207 cpassert(is_contiguous(msg_scatter))
16208 cpassert(is_contiguous(msg))
16209 cpassert(is_contiguous(sendcounts))
16210 cpassert(is_contiguous(displs))
16211#endif
16212 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_double_precision, msg, &
16213 recvcount, mpi_double_precision, root, comm%handle, request%handle, ierr)
16214 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
16215 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16216#else
16217 mark_used(sendcounts)
16218 mark_used(displs)
16219 mark_used(recvcount)
16220 mark_used(root)
16221 mark_used(comm)
16222 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
16223 request = mp_request_null
16224#endif
16225 CALL mp_timestop(handle)
16226 END SUBROUTINE mp_iscatterv_dv
16227
16228! **************************************************************************************************
16229!> \brief Gathers a datum from all processes to one
16230!> \param[in] msg Datum to send to root
16231!> \param[out] msg_gather Received data (on root)
16232!> \param[in] root Process which gathers the data
16233!> \param[in] comm Message passing environment identifier
16234!> \par MPI mapping
16235!> mpi_gather
16236! **************************************************************************************************
16237 SUBROUTINE mp_gather_d (msg, msg_gather, root, comm)
16238 REAL(kind=real_8), INTENT(IN) :: msg
16239 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16240 INTEGER, INTENT(IN) :: root
16241 CLASS(mp_comm_type), INTENT(IN) :: comm
16242
16243 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_d'
16244
16245 INTEGER :: handle
16246#if defined(__parallel)
16247 INTEGER :: ierr, msglen
16248#endif
16249
16250 CALL mp_timeset(routinen, handle)
16251
16252#if defined(__parallel)
16253 msglen = 1
16254 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16255 msglen, mpi_double_precision, root, comm%handle, ierr)
16256 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16257 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16258#else
16259 mark_used(root)
16260 mark_used(comm)
16261 msg_gather(1) = msg
16262#endif
16263 CALL mp_timestop(handle)
16264 END SUBROUTINE mp_gather_d
16265
16266! **************************************************************************************************
16267!> \brief Gathers a datum from all processes to one, uses the source process of comm
16268!> \param[in] msg Datum to send to root
16269!> \param[out] msg_gather Received data (on root)
16270!> \param[in] comm Message passing environment identifier
16271!> \par MPI mapping
16272!> mpi_gather
16273! **************************************************************************************************
16274 SUBROUTINE mp_gather_d_src(msg, msg_gather, comm)
16275 REAL(kind=real_8), INTENT(IN) :: msg
16276 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16277 CLASS(mp_comm_type), INTENT(IN) :: comm
16278
16279 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_d_src'
16280
16281 INTEGER :: handle
16282#if defined(__parallel)
16283 INTEGER :: ierr, msglen
16284#endif
16285
16286 CALL mp_timeset(routinen, handle)
16287
16288#if defined(__parallel)
16289 msglen = 1
16290 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16291 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16292 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16293 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16294#else
16295 mark_used(comm)
16296 msg_gather(1) = msg
16297#endif
16298 CALL mp_timestop(handle)
16299 END SUBROUTINE mp_gather_d_src
16300
16301! **************************************************************************************************
16302!> \brief Gathers data from all processes to one
16303!> \param[in] msg Datum to send to root
16304!> \param msg_gather ...
16305!> \param root ...
16306!> \param comm ...
16307!> \par Data length
16308!> All data (msg) is equal-sized
16309!> \par MPI mapping
16310!> mpi_gather
16311!> \note see mp_gather_d
16312! **************************************************************************************************
16313 SUBROUTINE mp_gather_dv(msg, msg_gather, root, comm)
16314 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
16315 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16316 INTEGER, INTENT(IN) :: root
16317 CLASS(mp_comm_type), INTENT(IN) :: comm
16318
16319 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dv'
16320
16321 INTEGER :: handle
16322#if defined(__parallel)
16323 INTEGER :: ierr, msglen
16324#endif
16325
16326 CALL mp_timeset(routinen, handle)
16327
16328#if defined(__parallel)
16329 msglen = SIZE(msg)
16330 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16331 msglen, mpi_double_precision, root, comm%handle, ierr)
16332 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16333 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16334#else
16335 mark_used(root)
16336 mark_used(comm)
16337 msg_gather = msg
16338#endif
16339 CALL mp_timestop(handle)
16340 END SUBROUTINE mp_gather_dv
16341
16342! **************************************************************************************************
16343!> \brief Gathers data from all processes to one. Gathers from comm%source
16344!> \param[in] msg Datum to send to root
16345!> \param msg_gather ...
16346!> \param comm ...
16347!> \par Data length
16348!> All data (msg) is equal-sized
16349!> \par MPI mapping
16350!> mpi_gather
16351!> \note see mp_gather_d
16352! **************************************************************************************************
16353 SUBROUTINE mp_gather_dv_src(msg, msg_gather, comm)
16354 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
16355 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16356 CLASS(mp_comm_type), INTENT(IN) :: comm
16357
16358 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dv_src'
16359
16360 INTEGER :: handle
16361#if defined(__parallel)
16362 INTEGER :: ierr, msglen
16363#endif
16364
16365 CALL mp_timeset(routinen, handle)
16366
16367#if defined(__parallel)
16368 msglen = SIZE(msg)
16369 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16370 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16371 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16372 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16373#else
16374 mark_used(comm)
16375 msg_gather = msg
16376#endif
16377 CALL mp_timestop(handle)
16378 END SUBROUTINE mp_gather_dv_src
16379
16380! **************************************************************************************************
16381!> \brief Gathers data from all processes to one
16382!> \param[in] msg Datum to send to root
16383!> \param msg_gather ...
16384!> \param root ...
16385!> \param comm ...
16386!> \par Data length
16387!> All data (msg) is equal-sized
16388!> \par MPI mapping
16389!> mpi_gather
16390!> \note see mp_gather_d
16391! **************************************************************************************************
16392 SUBROUTINE mp_gather_dm(msg, msg_gather, root, comm)
16393 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16394 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
16395 INTEGER, INTENT(IN) :: root
16396 CLASS(mp_comm_type), INTENT(IN) :: comm
16397
16398 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dm'
16399
16400 INTEGER :: handle
16401#if defined(__parallel)
16402 INTEGER :: ierr, msglen
16403#endif
16404
16405 CALL mp_timeset(routinen, handle)
16406
16407#if defined(__parallel)
16408 msglen = SIZE(msg)
16409 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16410 msglen, mpi_double_precision, root, comm%handle, ierr)
16411 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16412 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16413#else
16414 mark_used(root)
16415 mark_used(comm)
16416 msg_gather = msg
16417#endif
16418 CALL mp_timestop(handle)
16419 END SUBROUTINE mp_gather_dm
16420
16421! **************************************************************************************************
16422!> \brief Gathers data from all processes to one. Gathers from comm%source
16423!> \param[in] msg Datum to send to root
16424!> \param msg_gather ...
16425!> \param comm ...
16426!> \par Data length
16427!> All data (msg) is equal-sized
16428!> \par MPI mapping
16429!> mpi_gather
16430!> \note see mp_gather_d
16431! **************************************************************************************************
16432 SUBROUTINE mp_gather_dm_src(msg, msg_gather, comm)
16433 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16434 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
16435 CLASS(mp_comm_type), INTENT(IN) :: comm
16436
16437 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dm_src'
16438
16439 INTEGER :: handle
16440#if defined(__parallel)
16441 INTEGER :: ierr, msglen
16442#endif
16443
16444 CALL mp_timeset(routinen, handle)
16445
16446#if defined(__parallel)
16447 msglen = SIZE(msg)
16448 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16449 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16450 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16451 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16452#else
16453 mark_used(comm)
16454 msg_gather = msg
16455#endif
16456 CALL mp_timestop(handle)
16457 END SUBROUTINE mp_gather_dm_src
16458
16459! **************************************************************************************************
16460!> \brief Gathers data from all processes to one.
16461!> \param[in] sendbuf Data to send to root
16462!> \param[out] recvbuf Received data (on root)
16463!> \param[in] recvcounts Sizes of data received from processes
16464!> \param[in] displs Offsets of data received from processes
16465!> \param[in] root Process which gathers the data
16466!> \param[in] comm Message passing environment identifier
16467!> \par Data length
16468!> Data can have different lengths
16469!> \par Offsets
16470!> Offsets start at 0
16471!> \par MPI mapping
16472!> mpi_gather
16473! **************************************************************************************************
16474 SUBROUTINE mp_gatherv_dv(sendbuf, recvbuf, recvcounts, displs, root, comm)
16475
16476 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
16477 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
16478 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16479 INTEGER, INTENT(IN) :: root
16480 CLASS(mp_comm_type), INTENT(IN) :: comm
16481
16482 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dv'
16483
16484 INTEGER :: handle
16485#if defined(__parallel)
16486 INTEGER :: ierr, sendcount
16487#endif
16488
16489 CALL mp_timeset(routinen, handle)
16490
16491#if defined(__parallel)
16492 sendcount = SIZE(sendbuf)
16493 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16494 recvbuf, recvcounts, displs, mpi_double_precision, &
16495 root, comm%handle, ierr)
16496 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16497 CALL add_perf(perf_id=4, &
16498 count=1, &
16499 msg_size=sendcount*real_8_size)
16500#else
16501 mark_used(recvcounts)
16502 mark_used(root)
16503 mark_used(comm)
16504 recvbuf(1 + displs(1):) = sendbuf
16505#endif
16506 CALL mp_timestop(handle)
16507 END SUBROUTINE mp_gatherv_dv
16508
16509! **************************************************************************************************
16510!> \brief Gathers data from all processes to one. Gathers from comm%source
16511!> \param[in] sendbuf Data to send to root
16512!> \param[out] recvbuf Received data (on root)
16513!> \param[in] recvcounts Sizes of data received from processes
16514!> \param[in] displs Offsets of data received from processes
16515!> \param[in] comm Message passing environment identifier
16516!> \par Data length
16517!> Data can have different lengths
16518!> \par Offsets
16519!> Offsets start at 0
16520!> \par MPI mapping
16521!> mpi_gather
16522! **************************************************************************************************
16523 SUBROUTINE mp_gatherv_dv_src(sendbuf, recvbuf, recvcounts, displs, comm)
16524
16525 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
16526 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
16527 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16528 CLASS(mp_comm_type), INTENT(IN) :: comm
16529
16530 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dv_src'
16531
16532 INTEGER :: handle
16533#if defined(__parallel)
16534 INTEGER :: ierr, sendcount
16535#endif
16536
16537 CALL mp_timeset(routinen, handle)
16538
16539#if defined(__parallel)
16540 sendcount = SIZE(sendbuf)
16541 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16542 recvbuf, recvcounts, displs, mpi_double_precision, &
16543 comm%source, comm%handle, ierr)
16544 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16545 CALL add_perf(perf_id=4, &
16546 count=1, &
16547 msg_size=sendcount*real_8_size)
16548#else
16549 mark_used(recvcounts)
16550 mark_used(comm)
16551 recvbuf(1 + displs(1):) = sendbuf
16552#endif
16553 CALL mp_timestop(handle)
16554 END SUBROUTINE mp_gatherv_dv_src
16555
16556! **************************************************************************************************
16557!> \brief Gathers data from all processes to one.
16558!> \param[in] sendbuf Data to send to root
16559!> \param[out] recvbuf Received data (on root)
16560!> \param[in] recvcounts Sizes of data received from processes
16561!> \param[in] displs Offsets of data received from processes
16562!> \param[in] root Process which gathers the data
16563!> \param[in] comm Message passing environment identifier
16564!> \par Data length
16565!> Data can have different lengths
16566!> \par Offsets
16567!> Offsets start at 0
16568!> \par MPI mapping
16569!> mpi_gather
16570! **************************************************************************************************
16571 SUBROUTINE mp_gatherv_dm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
16572
16573 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
16574 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
16575 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16576 INTEGER, INTENT(IN) :: root
16577 CLASS(mp_comm_type), INTENT(IN) :: comm
16578
16579 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dm2'
16580
16581 INTEGER :: handle
16582#if defined(__parallel)
16583 INTEGER :: ierr, sendcount
16584#endif
16585
16586 CALL mp_timeset(routinen, handle)
16587
16588#if defined(__parallel)
16589 sendcount = SIZE(sendbuf)
16590 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16591 recvbuf, recvcounts, displs, mpi_double_precision, &
16592 root, comm%handle, ierr)
16593 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16594 CALL add_perf(perf_id=4, &
16595 count=1, &
16596 msg_size=sendcount*real_8_size)
16597#else
16598 mark_used(recvcounts)
16599 mark_used(root)
16600 mark_used(comm)
16601 recvbuf(:, 1 + displs(1):) = sendbuf
16602#endif
16603 CALL mp_timestop(handle)
16604 END SUBROUTINE mp_gatherv_dm2
16605
16606! **************************************************************************************************
16607!> \brief Gathers data from all processes to one.
16608!> \param[in] sendbuf Data to send to root
16609!> \param[out] recvbuf Received data (on root)
16610!> \param[in] recvcounts Sizes of data received from processes
16611!> \param[in] displs Offsets of data received from processes
16612!> \param[in] comm Message passing environment identifier
16613!> \par Data length
16614!> Data can have different lengths
16615!> \par Offsets
16616!> Offsets start at 0
16617!> \par MPI mapping
16618!> mpi_gather
16619! **************************************************************************************************
16620 SUBROUTINE mp_gatherv_dm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
16621
16622 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
16623 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
16624 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16625 CLASS(mp_comm_type), INTENT(IN) :: comm
16626
16627 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dm2_src'
16628
16629 INTEGER :: handle
16630#if defined(__parallel)
16631 INTEGER :: ierr, sendcount
16632#endif
16633
16634 CALL mp_timeset(routinen, handle)
16635
16636#if defined(__parallel)
16637 sendcount = SIZE(sendbuf)
16638 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16639 recvbuf, recvcounts, displs, mpi_double_precision, &
16640 comm%source, comm%handle, ierr)
16641 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16642 CALL add_perf(perf_id=4, &
16643 count=1, &
16644 msg_size=sendcount*real_8_size)
16645#else
16646 mark_used(recvcounts)
16647 mark_used(comm)
16648 recvbuf(:, 1 + displs(1):) = sendbuf
16649#endif
16650 CALL mp_timestop(handle)
16651 END SUBROUTINE mp_gatherv_dm2_src
16652
16653! **************************************************************************************************
16654!> \brief Gathers data from all processes to one.
16655!> \param[in] sendbuf Data to send to root
16656!> \param[out] recvbuf Received data (on root)
16657!> \param[in] recvcounts Sizes of data received from processes
16658!> \param[in] displs Offsets of data received from processes
16659!> \param[in] root Process which gathers the data
16660!> \param[in] comm Message passing environment identifier
16661!> \par Data length
16662!> Data can have different lengths
16663!> \par Offsets
16664!> Offsets start at 0
16665!> \par MPI mapping
16666!> mpi_gather
16667! **************************************************************************************************
16668 SUBROUTINE mp_igatherv_dv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
16669 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: sendbuf
16670 REAL(kind=real_8), DIMENSION(:), INTENT(OUT) :: recvbuf
16671 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16672 INTEGER, INTENT(IN) :: sendcount, root
16673 CLASS(mp_comm_type), INTENT(IN) :: comm
16674 TYPE(mp_request_type), INTENT(OUT) :: request
16675
16676 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_dv'
16677
16678 INTEGER :: handle
16679#if defined(__parallel)
16680 INTEGER :: ierr
16681#endif
16682
16683 CALL mp_timeset(routinen, handle)
16684
16685#if defined(__parallel)
16686#if !defined(__GNUC__) || __GNUC__ >= 9
16687 cpassert(is_contiguous(sendbuf))
16688 cpassert(is_contiguous(recvbuf))
16689 cpassert(is_contiguous(recvcounts))
16690 cpassert(is_contiguous(displs))
16691#endif
16692 CALL mpi_igatherv(sendbuf, sendcount, mpi_double_precision, &
16693 recvbuf, recvcounts, displs, mpi_double_precision, &
16694 root, comm%handle, request%handle, ierr)
16695 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16696 CALL add_perf(perf_id=24, &
16697 count=1, &
16698 msg_size=sendcount*real_8_size)
16699#else
16700 mark_used(sendcount)
16701 mark_used(recvcounts)
16702 mark_used(root)
16703 mark_used(comm)
16704 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
16705 request = mp_request_null
16706#endif
16707 CALL mp_timestop(handle)
16708 END SUBROUTINE mp_igatherv_dv
16709
16710! **************************************************************************************************
16711!> \brief Gathers a datum from all processes and all processes receive the
16712!> same data
16713!> \param[in] msgout Datum to send
16714!> \param[out] msgin Received data
16715!> \param[in] comm Message passing environment identifier
16716!> \par Data size
16717!> All processes send equal-sized data
16718!> \par MPI mapping
16719!> mpi_allgather
16720! **************************************************************************************************
16721 SUBROUTINE mp_allgather_d (msgout, msgin, comm)
16722 REAL(kind=real_8), INTENT(IN) :: msgout
16723 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
16724 CLASS(mp_comm_type), INTENT(IN) :: comm
16725
16726 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d'
16727
16728 INTEGER :: handle
16729#if defined(__parallel)
16730 INTEGER :: ierr, rcount, scount
16731#endif
16732
16733 CALL mp_timeset(routinen, handle)
16734
16735#if defined(__parallel)
16736 scount = 1
16737 rcount = 1
16738 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16739 msgin, rcount, mpi_double_precision, &
16740 comm%handle, ierr)
16741 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16742#else
16743 mark_used(comm)
16744 msgin = msgout
16745#endif
16746 CALL mp_timestop(handle)
16747 END SUBROUTINE mp_allgather_d
16748
16749! **************************************************************************************************
16750!> \brief Gathers a datum from all processes and all processes receive the
16751!> same data
16752!> \param[in] msgout Datum to send
16753!> \param[out] msgin Received data
16754!> \param[in] comm Message passing environment identifier
16755!> \par Data size
16756!> All processes send equal-sized data
16757!> \par MPI mapping
16758!> mpi_allgather
16759! **************************************************************************************************
16760 SUBROUTINE mp_allgather_d2(msgout, msgin, comm)
16761 REAL(kind=real_8), INTENT(IN) :: msgout
16762 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
16763 CLASS(mp_comm_type), INTENT(IN) :: comm
16764
16765 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d2'
16766
16767 INTEGER :: handle
16768#if defined(__parallel)
16769 INTEGER :: ierr, rcount, scount
16770#endif
16771
16772 CALL mp_timeset(routinen, handle)
16773
16774#if defined(__parallel)
16775 scount = 1
16776 rcount = 1
16777 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16778 msgin, rcount, mpi_double_precision, &
16779 comm%handle, ierr)
16780 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16781#else
16782 mark_used(comm)
16783 msgin = msgout
16784#endif
16785 CALL mp_timestop(handle)
16786 END SUBROUTINE mp_allgather_d2
16787
16788! **************************************************************************************************
16789!> \brief Gathers a datum from all processes and all processes receive the
16790!> same data
16791!> \param[in] msgout Datum to send
16792!> \param[out] msgin Received data
16793!> \param[in] comm Message passing environment identifier
16794!> \par Data size
16795!> All processes send equal-sized data
16796!> \par MPI mapping
16797!> mpi_allgather
16798! **************************************************************************************************
16799 SUBROUTINE mp_iallgather_d (msgout, msgin, comm, request)
16800 REAL(kind=real_8), INTENT(IN) :: msgout
16801 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
16802 CLASS(mp_comm_type), INTENT(IN) :: comm
16803 TYPE(mp_request_type), INTENT(OUT) :: request
16804
16805 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d'
16806
16807 INTEGER :: handle
16808#if defined(__parallel)
16809 INTEGER :: ierr, rcount, scount
16810#endif
16811
16812 CALL mp_timeset(routinen, handle)
16813
16814#if defined(__parallel)
16815#if !defined(__GNUC__) || __GNUC__ >= 9
16816 cpassert(is_contiguous(msgin))
16817#endif
16818 scount = 1
16819 rcount = 1
16820 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
16821 msgin, rcount, mpi_double_precision, &
16822 comm%handle, request%handle, ierr)
16823 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16824#else
16825 mark_used(comm)
16826 msgin = msgout
16827 request = mp_request_null
16828#endif
16829 CALL mp_timestop(handle)
16830 END SUBROUTINE mp_iallgather_d
16831
16832! **************************************************************************************************
16833!> \brief Gathers vector data from all processes and all processes receive the
16834!> same data
16835!> \param[in] msgout Rank-1 data to send
16836!> \param[out] msgin Received data
16837!> \param[in] comm Message passing environment identifier
16838!> \par Data size
16839!> All processes send equal-sized data
16840!> \par Ranks
16841!> The last rank counts the processes
16842!> \par MPI mapping
16843!> mpi_allgather
16844! **************************************************************************************************
16845 SUBROUTINE mp_allgather_d12(msgout, msgin, comm)
16846 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:)
16847 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
16848 CLASS(mp_comm_type), INTENT(IN) :: comm
16849
16850 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d12'
16851
16852 INTEGER :: handle
16853#if defined(__parallel)
16854 INTEGER :: ierr, rcount, scount
16855#endif
16856
16857 CALL mp_timeset(routinen, handle)
16858
16859#if defined(__parallel)
16860 scount = SIZE(msgout(:))
16861 rcount = scount
16862 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16863 msgin, rcount, mpi_double_precision, &
16864 comm%handle, ierr)
16865 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16866#else
16867 mark_used(comm)
16868 msgin(:, 1) = msgout(:)
16869#endif
16870 CALL mp_timestop(handle)
16871 END SUBROUTINE mp_allgather_d12
16872
16873! **************************************************************************************************
16874!> \brief Gathers matrix data from all processes and all processes receive the
16875!> same data
16876!> \param[in] msgout Rank-2 data to send
16877!> \param msgin ...
16878!> \param comm ...
16879!> \note see mp_allgather_d12
16880! **************************************************************************************************
16881 SUBROUTINE mp_allgather_d23(msgout, msgin, comm)
16882 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
16883 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
16884 CLASS(mp_comm_type), INTENT(IN) :: comm
16885
16886 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d23'
16887
16888 INTEGER :: handle
16889#if defined(__parallel)
16890 INTEGER :: ierr, rcount, scount
16891#endif
16892
16893 CALL mp_timeset(routinen, handle)
16894
16895#if defined(__parallel)
16896 scount = SIZE(msgout(:, :))
16897 rcount = scount
16898 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16899 msgin, rcount, mpi_double_precision, &
16900 comm%handle, ierr)
16901 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16902#else
16903 mark_used(comm)
16904 msgin(:, :, 1) = msgout(:, :)
16905#endif
16906 CALL mp_timestop(handle)
16907 END SUBROUTINE mp_allgather_d23
16908
16909! **************************************************************************************************
16910!> \brief Gathers rank-3 data from all processes and all processes receive the
16911!> same data
16912!> \param[in] msgout Rank-3 data to send
16913!> \param msgin ...
16914!> \param comm ...
16915!> \note see mp_allgather_d12
16916! **************************************************************************************************
16917 SUBROUTINE mp_allgather_d34(msgout, msgin, comm)
16918 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
16919 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
16920 CLASS(mp_comm_type), INTENT(IN) :: comm
16921
16922 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d34'
16923
16924 INTEGER :: handle
16925#if defined(__parallel)
16926 INTEGER :: ierr, rcount, scount
16927#endif
16928
16929 CALL mp_timeset(routinen, handle)
16930
16931#if defined(__parallel)
16932 scount = SIZE(msgout(:, :, :))
16933 rcount = scount
16934 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16935 msgin, rcount, mpi_double_precision, &
16936 comm%handle, ierr)
16937 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16938#else
16939 mark_used(comm)
16940 msgin(:, :, :, 1) = msgout(:, :, :)
16941#endif
16942 CALL mp_timestop(handle)
16943 END SUBROUTINE mp_allgather_d34
16944
16945! **************************************************************************************************
16946!> \brief Gathers rank-2 data from all processes and all processes receive the
16947!> same data
16948!> \param[in] msgout Rank-2 data to send
16949!> \param msgin ...
16950!> \param comm ...
16951!> \note see mp_allgather_d12
16952! **************************************************************************************************
16953 SUBROUTINE mp_allgather_d22(msgout, msgin, comm)
16954 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
16955 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
16956 CLASS(mp_comm_type), INTENT(IN) :: comm
16957
16958 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d22'
16959
16960 INTEGER :: handle
16961#if defined(__parallel)
16962 INTEGER :: ierr, rcount, scount
16963#endif
16964
16965 CALL mp_timeset(routinen, handle)
16966
16967#if defined(__parallel)
16968 scount = SIZE(msgout(:, :))
16969 rcount = scount
16970 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16971 msgin, rcount, mpi_double_precision, &
16972 comm%handle, ierr)
16973 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16974#else
16975 mark_used(comm)
16976 msgin(:, :) = msgout(:, :)
16977#endif
16978 CALL mp_timestop(handle)
16979 END SUBROUTINE mp_allgather_d22
16980
16981! **************************************************************************************************
16982!> \brief Gathers rank-1 data from all processes and all processes receive the
16983!> same data
16984!> \param[in] msgout Rank-1 data to send
16985!> \param msgin ...
16986!> \param comm ...
16987!> \param request ...
16988!> \note see mp_allgather_d11
16989! **************************************************************************************************
16990 SUBROUTINE mp_iallgather_d11(msgout, msgin, comm, request)
16991 REAL(kind=real_8), INTENT(IN) :: msgout(:)
16992 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
16993 CLASS(mp_comm_type), INTENT(IN) :: comm
16994 TYPE(mp_request_type), INTENT(OUT) :: request
16995
16996 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d11'
16997
16998 INTEGER :: handle
16999#if defined(__parallel)
17000 INTEGER :: ierr, rcount, scount
17001#endif
17002
17003 CALL mp_timeset(routinen, handle)
17004
17005#if defined(__parallel)
17006#if !defined(__GNUC__) || __GNUC__ >= 9
17007 cpassert(is_contiguous(msgout))
17008 cpassert(is_contiguous(msgin))
17009#endif
17010 scount = SIZE(msgout(:))
17011 rcount = scount
17012 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17013 msgin, rcount, mpi_double_precision, &
17014 comm%handle, request%handle, ierr)
17015 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17016#else
17017 mark_used(comm)
17018 msgin = msgout
17019 request = mp_request_null
17020#endif
17021 CALL mp_timestop(handle)
17022 END SUBROUTINE mp_iallgather_d11
17023
17024! **************************************************************************************************
17025!> \brief Gathers rank-2 data from all processes and all processes receive the
17026!> same data
17027!> \param[in] msgout Rank-2 data to send
17028!> \param msgin ...
17029!> \param comm ...
17030!> \param request ...
17031!> \note see mp_allgather_d12
17032! **************************************************************************************************
17033 SUBROUTINE mp_iallgather_d13(msgout, msgin, comm, request)
17034 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17035 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
17036 CLASS(mp_comm_type), INTENT(IN) :: comm
17037 TYPE(mp_request_type), INTENT(OUT) :: request
17038
17039 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d13'
17040
17041 INTEGER :: handle
17042#if defined(__parallel)
17043 INTEGER :: ierr, rcount, scount
17044#endif
17045
17046 CALL mp_timeset(routinen, handle)
17047
17048#if defined(__parallel)
17049#if !defined(__GNUC__) || __GNUC__ >= 9
17050 cpassert(is_contiguous(msgout))
17051 cpassert(is_contiguous(msgin))
17052#endif
17053
17054 scount = SIZE(msgout(:))
17055 rcount = scount
17056 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17057 msgin, rcount, mpi_double_precision, &
17058 comm%handle, request%handle, ierr)
17059 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17060#else
17061 mark_used(comm)
17062 msgin(:, 1, 1) = msgout(:)
17063 request = mp_request_null
17064#endif
17065 CALL mp_timestop(handle)
17066 END SUBROUTINE mp_iallgather_d13
17067
17068! **************************************************************************************************
17069!> \brief Gathers rank-2 data from all processes and all processes receive the
17070!> same data
17071!> \param[in] msgout Rank-2 data to send
17072!> \param msgin ...
17073!> \param comm ...
17074!> \param request ...
17075!> \note see mp_allgather_d12
17076! **************************************************************************************************
17077 SUBROUTINE mp_iallgather_d22(msgout, msgin, comm, request)
17078 REAL(kind=real_8), INTENT(IN) :: msgout(:, :)
17079 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :)
17080 CLASS(mp_comm_type), INTENT(IN) :: comm
17081 TYPE(mp_request_type), INTENT(OUT) :: request
17082
17083 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d22'
17084
17085 INTEGER :: handle
17086#if defined(__parallel)
17087 INTEGER :: ierr, rcount, scount
17088#endif
17089
17090 CALL mp_timeset(routinen, handle)
17091
17092#if defined(__parallel)
17093#if !defined(__GNUC__) || __GNUC__ >= 9
17094 cpassert(is_contiguous(msgout))
17095 cpassert(is_contiguous(msgin))
17096#endif
17097
17098 scount = SIZE(msgout(:, :))
17099 rcount = scount
17100 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17101 msgin, rcount, mpi_double_precision, &
17102 comm%handle, request%handle, ierr)
17103 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17104#else
17105 mark_used(comm)
17106 msgin(:, :) = msgout(:, :)
17107 request = mp_request_null
17108#endif
17109 CALL mp_timestop(handle)
17110 END SUBROUTINE mp_iallgather_d22
17111
17112! **************************************************************************************************
17113!> \brief Gathers rank-2 data from all processes and all processes receive the
17114!> same data
17115!> \param[in] msgout Rank-2 data to send
17116!> \param msgin ...
17117!> \param comm ...
17118!> \param request ...
17119!> \note see mp_allgather_d12
17120! **************************************************************************************************
17121 SUBROUTINE mp_iallgather_d24(msgout, msgin, comm, request)
17122 REAL(kind=real_8), INTENT(IN) :: msgout(:, :)
17123 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :, :)
17124 CLASS(mp_comm_type), INTENT(IN) :: comm
17125 TYPE(mp_request_type), INTENT(OUT) :: request
17126
17127 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d24'
17128
17129 INTEGER :: handle
17130#if defined(__parallel)
17131 INTEGER :: ierr, rcount, scount
17132#endif
17133
17134 CALL mp_timeset(routinen, handle)
17135
17136#if defined(__parallel)
17137#if !defined(__GNUC__) || __GNUC__ >= 9
17138 cpassert(is_contiguous(msgout))
17139 cpassert(is_contiguous(msgin))
17140#endif
17141
17142 scount = SIZE(msgout(:, :))
17143 rcount = scount
17144 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17145 msgin, rcount, mpi_double_precision, &
17146 comm%handle, request%handle, ierr)
17147 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17148#else
17149 mark_used(comm)
17150 msgin(:, :, 1, 1) = msgout(:, :)
17151 request = mp_request_null
17152#endif
17153 CALL mp_timestop(handle)
17154 END SUBROUTINE mp_iallgather_d24
17155
17156! **************************************************************************************************
17157!> \brief Gathers rank-3 data from all processes and all processes receive the
17158!> same data
17159!> \param[in] msgout Rank-3 data to send
17160!> \param msgin ...
17161!> \param comm ...
17162!> \param request ...
17163!> \note see mp_allgather_d12
17164! **************************************************************************************************
17165 SUBROUTINE mp_iallgather_d33(msgout, msgin, comm, request)
17166 REAL(kind=real_8), INTENT(IN) :: msgout(:, :, :)
17167 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
17168 CLASS(mp_comm_type), INTENT(IN) :: comm
17169 TYPE(mp_request_type), INTENT(OUT) :: request
17170
17171 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d33'
17172
17173 INTEGER :: handle
17174#if defined(__parallel)
17175 INTEGER :: ierr, rcount, scount
17176#endif
17177
17178 CALL mp_timeset(routinen, handle)
17179
17180#if defined(__parallel)
17181#if !defined(__GNUC__) || __GNUC__ >= 9
17182 cpassert(is_contiguous(msgout))
17183 cpassert(is_contiguous(msgin))
17184#endif
17185
17186 scount = SIZE(msgout(:, :, :))
17187 rcount = scount
17188 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17189 msgin, rcount, mpi_double_precision, &
17190 comm%handle, request%handle, ierr)
17191 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17192#else
17193 mark_used(comm)
17194 msgin(:, :, :) = msgout(:, :, :)
17195 request = mp_request_null
17196#endif
17197 CALL mp_timestop(handle)
17198 END SUBROUTINE mp_iallgather_d33
17199
17200! **************************************************************************************************
17201!> \brief Gathers vector data from all processes and all processes receive the
17202!> same data
17203!> \param[in] msgout Rank-1 data to send
17204!> \param[out] msgin Received data
17205!> \param[in] rcount Size of sent data for every process
17206!> \param[in] rdispl Offset of sent data for every process
17207!> \param[in] comm Message passing environment identifier
17208!> \par Data size
17209!> Processes can send different-sized data
17210!> \par Ranks
17211!> The last rank counts the processes
17212!> \par Offsets
17213!> Offsets are from 0
17214!> \par MPI mapping
17215!> mpi_allgather
17216! **************************************************************************************************
17217 SUBROUTINE mp_allgatherv_dv(msgout, msgin, rcount, rdispl, comm)
17218 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
17219 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17220 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17221 CLASS(mp_comm_type), INTENT(IN) :: comm
17222
17223 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_dv'
17224
17225 INTEGER :: handle
17226#if defined(__parallel)
17227 INTEGER :: ierr, scount
17228#endif
17229
17230 CALL mp_timeset(routinen, handle)
17231
17232#if defined(__parallel)
17233 scount = SIZE(msgout)
17234 CALL mpi_allgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17235 rdispl, mpi_double_precision, comm%handle, ierr)
17236 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
17237#else
17238 mark_used(rcount)
17239 mark_used(rdispl)
17240 mark_used(comm)
17241 msgin = msgout
17242#endif
17243 CALL mp_timestop(handle)
17244 END SUBROUTINE mp_allgatherv_dv
17245
17246! **************************************************************************************************
17247!> \brief Gathers vector data from all processes and all processes receive the
17248!> same data
17249!> \param[in] msgout Rank-1 data to send
17250!> \param[out] msgin Received data
17251!> \param[in] rcount Size of sent data for every process
17252!> \param[in] rdispl Offset of sent data for every process
17253!> \param[in] comm Message passing environment identifier
17254!> \par Data size
17255!> Processes can send different-sized data
17256!> \par Ranks
17257!> The last rank counts the processes
17258!> \par Offsets
17259!> Offsets are from 0
17260!> \par MPI mapping
17261!> mpi_allgather
17262! **************************************************************************************************
17263 SUBROUTINE mp_allgatherv_dm2(msgout, msgin, rcount, rdispl, comm)
17264 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
17265 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
17266 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17267 CLASS(mp_comm_type), INTENT(IN) :: comm
17268
17269 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_dv'
17270
17271 INTEGER :: handle
17272#if defined(__parallel)
17273 INTEGER :: ierr, scount
17274#endif
17275
17276 CALL mp_timeset(routinen, handle)
17277
17278#if defined(__parallel)
17279 scount = SIZE(msgout)
17280 CALL mpi_allgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17281 rdispl, mpi_double_precision, comm%handle, ierr)
17282 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
17283#else
17284 mark_used(rcount)
17285 mark_used(rdispl)
17286 mark_used(comm)
17287 msgin = msgout
17288#endif
17289 CALL mp_timestop(handle)
17290 END SUBROUTINE mp_allgatherv_dm2
17291
17292! **************************************************************************************************
17293!> \brief Gathers vector data from all processes and all processes receive the
17294!> same data
17295!> \param[in] msgout Rank-1 data to send
17296!> \param[out] msgin Received data
17297!> \param[in] rcount Size of sent data for every process
17298!> \param[in] rdispl Offset of sent data for every process
17299!> \param[in] comm Message passing environment identifier
17300!> \par Data size
17301!> Processes can send different-sized data
17302!> \par Ranks
17303!> The last rank counts the processes
17304!> \par Offsets
17305!> Offsets are from 0
17306!> \par MPI mapping
17307!> mpi_allgather
17308! **************************************************************************************************
17309 SUBROUTINE mp_iallgatherv_dv(msgout, msgin, rcount, rdispl, comm, request)
17310 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17311 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17312 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17313 CLASS(mp_comm_type), INTENT(IN) :: comm
17314 TYPE(mp_request_type), INTENT(OUT) :: request
17315
17316 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_dv'
17317
17318 INTEGER :: handle
17319#if defined(__parallel)
17320 INTEGER :: ierr, scount, rsize
17321#endif
17322
17323 CALL mp_timeset(routinen, handle)
17324
17325#if defined(__parallel)
17326#if !defined(__GNUC__) || __GNUC__ >= 9
17327 cpassert(is_contiguous(msgout))
17328 cpassert(is_contiguous(msgin))
17329 cpassert(is_contiguous(rcount))
17330 cpassert(is_contiguous(rdispl))
17331#endif
17332
17333 scount = SIZE(msgout)
17334 rsize = SIZE(rcount)
17335 CALL mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, &
17336 rdispl, comm, request, ierr)
17337 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
17338#else
17339 mark_used(rcount)
17340 mark_used(rdispl)
17341 mark_used(comm)
17342 msgin = msgout
17343 request = mp_request_null
17344#endif
17345 CALL mp_timestop(handle)
17346 END SUBROUTINE mp_iallgatherv_dv
17347
17348! **************************************************************************************************
17349!> \brief Gathers vector data from all processes and all processes receive the
17350!> same data
17351!> \param[in] msgout Rank-1 data to send
17352!> \param[out] msgin Received data
17353!> \param[in] rcount Size of sent data for every process
17354!> \param[in] rdispl Offset of sent data for every process
17355!> \param[in] comm Message passing environment identifier
17356!> \par Data size
17357!> Processes can send different-sized data
17358!> \par Ranks
17359!> The last rank counts the processes
17360!> \par Offsets
17361!> Offsets are from 0
17362!> \par MPI mapping
17363!> mpi_allgather
17364! **************************************************************************************************
17365 SUBROUTINE mp_iallgatherv_dv2(msgout, msgin, rcount, rdispl, comm, request)
17366 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17367 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17368 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
17369 CLASS(mp_comm_type), INTENT(IN) :: comm
17370 TYPE(mp_request_type), INTENT(OUT) :: request
17371
17372 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_dv2'
17373
17374 INTEGER :: handle
17375#if defined(__parallel)
17376 INTEGER :: ierr, scount, rsize
17377#endif
17378
17379 CALL mp_timeset(routinen, handle)
17380
17381#if defined(__parallel)
17382#if !defined(__GNUC__) || __GNUC__ >= 9
17383 cpassert(is_contiguous(msgout))
17384 cpassert(is_contiguous(msgin))
17385 cpassert(is_contiguous(rcount))
17386 cpassert(is_contiguous(rdispl))
17387#endif
17388
17389 scount = SIZE(msgout)
17390 rsize = SIZE(rcount)
17391 CALL mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, &
17392 rdispl, comm, request, ierr)
17393 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
17394#else
17395 mark_used(rcount)
17396 mark_used(rdispl)
17397 mark_used(comm)
17398 msgin = msgout
17399 request = mp_request_null
17400#endif
17401 CALL mp_timestop(handle)
17402 END SUBROUTINE mp_iallgatherv_dv2
17403
17404! **************************************************************************************************
17405!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
17406!> the issue is with the rank of rcount and rdispl
17407!> \param count ...
17408!> \param array_of_requests ...
17409!> \param array_of_statuses ...
17410!> \param ierr ...
17411!> \author Alfio Lazzaro
17412! **************************************************************************************************
17413#if defined(__parallel)
17414 SUBROUTINE mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
17415 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
17416 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17417 INTEGER, INTENT(IN) :: rsize
17418 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
17419 CLASS(mp_comm_type), INTENT(IN) :: comm
17420 TYPE(mp_request_type), INTENT(OUT) :: request
17421 INTEGER, INTENT(INOUT) :: ierr
17422
17423 CALL mpi_iallgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17424 rdispl, mpi_double_precision, comm%handle, request%handle, ierr)
17425
17426 END SUBROUTINE mp_iallgatherv_dv_internal
17427#endif
17428
17429! **************************************************************************************************
17430!> \brief Sums a vector and partitions the result among processes
17431!> \param[in] msgout Data to sum
17432!> \param[out] msgin Received portion of summed data
17433!> \param[in] rcount Partition sizes of the summed data for
17434!> every process
17435!> \param[in] comm Message passing environment identifier
17436! **************************************************************************************************
17437 SUBROUTINE mp_sum_scatter_dv(msgout, msgin, rcount, comm)
17438 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
17439 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17440 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
17441 CLASS(mp_comm_type), INTENT(IN) :: comm
17442
17443 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_dv'
17444
17445 INTEGER :: handle
17446#if defined(__parallel)
17447 INTEGER :: ierr
17448#endif
17449
17450 CALL mp_timeset(routinen, handle)
17451
17452#if defined(__parallel)
17453 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_double_precision, mpi_sum, &
17454 comm%handle, ierr)
17455 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
17456
17457 CALL add_perf(perf_id=3, count=1, &
17458 msg_size=rcount(1)*2*real_8_size)
17459#else
17460 mark_used(rcount)
17461 mark_used(comm)
17462 msgin = msgout(:, 1)
17463#endif
17464 CALL mp_timestop(handle)
17465 END SUBROUTINE mp_sum_scatter_dv
17466
17467! **************************************************************************************************
17468!> \brief Sends and receives vector data
17469!> \param[in] msgin Data to send
17470!> \param[in] dest Process to send data to
17471!> \param[out] msgout Received data
17472!> \param[in] source Process from which to receive
17473!> \param[in] comm Message passing environment identifier
17474!> \param[in] tag Send and recv tag (default: 0)
17475! **************************************************************************************************
17476 SUBROUTINE mp_sendrecv_d (msgin, dest, msgout, source, comm, tag)
17477 REAL(kind=real_8), INTENT(IN) :: msgin
17478 INTEGER, INTENT(IN) :: dest
17479 REAL(kind=real_8), INTENT(OUT) :: msgout
17480 INTEGER, INTENT(IN) :: source
17481 CLASS(mp_comm_type), INTENT(IN) :: comm
17482 INTEGER, INTENT(IN), OPTIONAL :: tag
17483
17484 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_d'
17485
17486 INTEGER :: handle
17487#if defined(__parallel)
17488 INTEGER :: ierr, msglen_in, msglen_out, &
17489 recv_tag, send_tag
17490#endif
17491
17492 CALL mp_timeset(routinen, handle)
17493
17494#if defined(__parallel)
17495 msglen_in = 1
17496 msglen_out = 1
17497 send_tag = 0 ! cannot think of something better here, this might be dangerous
17498 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17499 IF (PRESENT(tag)) THEN
17500 send_tag = tag
17501 recv_tag = tag
17502 END IF
17503 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17504 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17505 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17506 CALL add_perf(perf_id=7, count=1, &
17507 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17508#else
17509 mark_used(dest)
17510 mark_used(source)
17511 mark_used(comm)
17512 mark_used(tag)
17513 msgout = msgin
17514#endif
17515 CALL mp_timestop(handle)
17516 END SUBROUTINE mp_sendrecv_d
17517
17518! **************************************************************************************************
17519!> \brief Sends and receives vector data
17520!> \param[in] msgin Data to send
17521!> \param[in] dest Process to send data to
17522!> \param[out] msgout Received data
17523!> \param[in] source Process from which to receive
17524!> \param[in] comm Message passing environment identifier
17525!> \param[in] tag Send and recv tag (default: 0)
17526! **************************************************************************************************
17527 SUBROUTINE mp_sendrecv_dv(msgin, dest, msgout, source, comm, tag)
17528 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
17529 INTEGER, INTENT(IN) :: dest
17530 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
17531 INTEGER, INTENT(IN) :: source
17532 CLASS(mp_comm_type), INTENT(IN) :: comm
17533 INTEGER, INTENT(IN), OPTIONAL :: tag
17534
17535 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dv'
17536
17537 INTEGER :: handle
17538#if defined(__parallel)
17539 INTEGER :: ierr, msglen_in, msglen_out, &
17540 recv_tag, send_tag
17541#endif
17542
17543 CALL mp_timeset(routinen, handle)
17544
17545#if defined(__parallel)
17546 msglen_in = SIZE(msgin)
17547 msglen_out = SIZE(msgout)
17548 send_tag = 0 ! cannot think of something better here, this might be dangerous
17549 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17550 IF (PRESENT(tag)) THEN
17551 send_tag = tag
17552 recv_tag = tag
17553 END IF
17554 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17555 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17556 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17557 CALL add_perf(perf_id=7, count=1, &
17558 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17559#else
17560 mark_used(dest)
17561 mark_used(source)
17562 mark_used(comm)
17563 mark_used(tag)
17564 msgout = msgin
17565#endif
17566 CALL mp_timestop(handle)
17567 END SUBROUTINE mp_sendrecv_dv
17568
17569! **************************************************************************************************
17570!> \brief Sends and receives matrix data
17571!> \param msgin ...
17572!> \param dest ...
17573!> \param msgout ...
17574!> \param source ...
17575!> \param comm ...
17576!> \param tag ...
17577!> \note see mp_sendrecv_dv
17578! **************************************************************************************************
17579 SUBROUTINE mp_sendrecv_dm2(msgin, dest, msgout, source, comm, tag)
17580 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
17581 INTEGER, INTENT(IN) :: dest
17582 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
17583 INTEGER, INTENT(IN) :: source
17584 CLASS(mp_comm_type), INTENT(IN) :: comm
17585 INTEGER, INTENT(IN), OPTIONAL :: tag
17586
17587 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm2'
17588
17589 INTEGER :: handle
17590#if defined(__parallel)
17591 INTEGER :: ierr, msglen_in, msglen_out, &
17592 recv_tag, send_tag
17593#endif
17594
17595 CALL mp_timeset(routinen, handle)
17596
17597#if defined(__parallel)
17598 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
17599 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
17600 send_tag = 0 ! cannot think of something better here, this might be dangerous
17601 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17602 IF (PRESENT(tag)) THEN
17603 send_tag = tag
17604 recv_tag = tag
17605 END IF
17606 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17607 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17608 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17609 CALL add_perf(perf_id=7, count=1, &
17610 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17611#else
17612 mark_used(dest)
17613 mark_used(source)
17614 mark_used(comm)
17615 mark_used(tag)
17616 msgout = msgin
17617#endif
17618 CALL mp_timestop(handle)
17619 END SUBROUTINE mp_sendrecv_dm2
17620
17621! **************************************************************************************************
17622!> \brief Sends and receives rank-3 data
17623!> \param msgin ...
17624!> \param dest ...
17625!> \param msgout ...
17626!> \param source ...
17627!> \param comm ...
17628!> \note see mp_sendrecv_dv
17629! **************************************************************************************************
17630 SUBROUTINE mp_sendrecv_dm3(msgin, dest, msgout, source, comm, tag)
17631 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
17632 INTEGER, INTENT(IN) :: dest
17633 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
17634 INTEGER, INTENT(IN) :: source
17635 CLASS(mp_comm_type), INTENT(IN) :: comm
17636 INTEGER, INTENT(IN), OPTIONAL :: tag
17637
17638 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm3'
17639
17640 INTEGER :: handle
17641#if defined(__parallel)
17642 INTEGER :: ierr, msglen_in, msglen_out, &
17643 recv_tag, send_tag
17644#endif
17645
17646 CALL mp_timeset(routinen, handle)
17647
17648#if defined(__parallel)
17649 msglen_in = SIZE(msgin)
17650 msglen_out = SIZE(msgout)
17651 send_tag = 0 ! cannot think of something better here, this might be dangerous
17652 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17653 IF (PRESENT(tag)) THEN
17654 send_tag = tag
17655 recv_tag = tag
17656 END IF
17657 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17658 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17659 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17660 CALL add_perf(perf_id=7, count=1, &
17661 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17662#else
17663 mark_used(dest)
17664 mark_used(source)
17665 mark_used(comm)
17666 mark_used(tag)
17667 msgout = msgin
17668#endif
17669 CALL mp_timestop(handle)
17670 END SUBROUTINE mp_sendrecv_dm3
17671
17672! **************************************************************************************************
17673!> \brief Sends and receives rank-4 data
17674!> \param msgin ...
17675!> \param dest ...
17676!> \param msgout ...
17677!> \param source ...
17678!> \param comm ...
17679!> \note see mp_sendrecv_dv
17680! **************************************************************************************************
17681 SUBROUTINE mp_sendrecv_dm4(msgin, dest, msgout, source, comm, tag)
17682 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
17683 INTEGER, INTENT(IN) :: dest
17684 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
17685 INTEGER, INTENT(IN) :: source
17686 CLASS(mp_comm_type), INTENT(IN) :: comm
17687 INTEGER, INTENT(IN), OPTIONAL :: tag
17688
17689 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm4'
17690
17691 INTEGER :: handle
17692#if defined(__parallel)
17693 INTEGER :: ierr, msglen_in, msglen_out, &
17694 recv_tag, send_tag
17695#endif
17696
17697 CALL mp_timeset(routinen, handle)
17698
17699#if defined(__parallel)
17700 msglen_in = SIZE(msgin)
17701 msglen_out = SIZE(msgout)
17702 send_tag = 0 ! cannot think of something better here, this might be dangerous
17703 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17704 IF (PRESENT(tag)) THEN
17705 send_tag = tag
17706 recv_tag = tag
17707 END IF
17708 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17709 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17710 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17711 CALL add_perf(perf_id=7, count=1, &
17712 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17713#else
17714 mark_used(dest)
17715 mark_used(source)
17716 mark_used(comm)
17717 mark_used(tag)
17718 msgout = msgin
17719#endif
17720 CALL mp_timestop(handle)
17721 END SUBROUTINE mp_sendrecv_dm4
17722
17723! **************************************************************************************************
17724!> \brief Non-blocking send and receive of a scalar
17725!> \param[in] msgin Scalar data to send
17726!> \param[in] dest Which process to send to
17727!> \param[out] msgout Receive data into this pointer
17728!> \param[in] source Process to receive from
17729!> \param[in] comm Message passing environment identifier
17730!> \param[out] send_request Request handle for the send
17731!> \param[out] recv_request Request handle for the receive
17732!> \param[in] tag (optional) tag to differentiate requests
17733!> \par Implementation
17734!> Calls mpi_isend and mpi_irecv.
17735!> \par History
17736!> 02.2005 created [Alfio Lazzaro]
17737! **************************************************************************************************
17738 SUBROUTINE mp_isendrecv_d (msgin, dest, msgout, source, comm, send_request, &
17739 recv_request, tag)
17740 REAL(kind=real_8), INTENT(IN) :: msgin
17741 INTEGER, INTENT(IN) :: dest
17742 REAL(kind=real_8), INTENT(INOUT) :: msgout
17743 INTEGER, INTENT(IN) :: source
17744 CLASS(mp_comm_type), INTENT(IN) :: comm
17745 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
17746 INTEGER, INTENT(in), OPTIONAL :: tag
17747
17748 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_d'
17749
17750 INTEGER :: handle
17751#if defined(__parallel)
17752 INTEGER :: ierr, my_tag
17753#endif
17754
17755 CALL mp_timeset(routinen, handle)
17756
17757#if defined(__parallel)
17758 my_tag = 0
17759 IF (PRESENT(tag)) my_tag = tag
17760
17761 CALL mpi_irecv(msgout, 1, mpi_double_precision, source, my_tag, &
17762 comm%handle, recv_request%handle, ierr)
17763 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
17764
17765 CALL mpi_isend(msgin, 1, mpi_double_precision, dest, my_tag, &
17766 comm%handle, send_request%handle, ierr)
17767 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
17768
17769 CALL add_perf(perf_id=8, count=1, msg_size=2*real_8_size)
17770#else
17771 mark_used(dest)
17772 mark_used(source)
17773 mark_used(comm)
17774 mark_used(tag)
17775 send_request = mp_request_null
17776 recv_request = mp_request_null
17777 msgout = msgin
17778#endif
17779 CALL mp_timestop(handle)
17780 END SUBROUTINE mp_isendrecv_d
17781
17782! **************************************************************************************************
17783!> \brief Non-blocking send and receive of a vector
17784!> \param[in] msgin Vector data to send
17785!> \param[in] dest Which process to send to
17786!> \param[out] msgout Receive data into this pointer
17787!> \param[in] source Process to receive from
17788!> \param[in] comm Message passing environment identifier
17789!> \param[out] send_request Request handle for the send
17790!> \param[out] recv_request Request handle for the receive
17791!> \param[in] tag (optional) tag to differentiate requests
17792!> \par Implementation
17793!> Calls mpi_isend and mpi_irecv.
17794!> \par History
17795!> 11.2004 created [Joost VandeVondele]
17796!> \note
17797!> arrays can be pointers or assumed shape, but they must be contiguous!
17798! **************************************************************************************************
17799 SUBROUTINE mp_isendrecv_dv(msgin, dest, msgout, source, comm, send_request, &
17800 recv_request, tag)
17801 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
17802 INTEGER, INTENT(IN) :: dest
17803 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
17804 INTEGER, INTENT(IN) :: source
17805 CLASS(mp_comm_type), INTENT(IN) :: comm
17806 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
17807 INTEGER, INTENT(in), OPTIONAL :: tag
17808
17809 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_dv'
17810
17811 INTEGER :: handle
17812#if defined(__parallel)
17813 INTEGER :: ierr, msglen, my_tag
17814 REAL(kind=real_8) :: foo
17815#endif
17816
17817 CALL mp_timeset(routinen, handle)
17818
17819#if defined(__parallel)
17820#if !defined(__GNUC__) || __GNUC__ >= 9
17821 cpassert(is_contiguous(msgout))
17822 cpassert(is_contiguous(msgin))
17823#endif
17824
17825 my_tag = 0
17826 IF (PRESENT(tag)) my_tag = tag
17827
17828 msglen = SIZE(msgout, 1)
17829 IF (msglen > 0) THEN
17830 CALL mpi_irecv(msgout(1), msglen, mpi_double_precision, source, my_tag, &
17831 comm%handle, recv_request%handle, ierr)
17832 ELSE
17833 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
17834 comm%handle, recv_request%handle, ierr)
17835 END IF
17836 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
17837
17838 msglen = SIZE(msgin, 1)
17839 IF (msglen > 0) THEN
17840 CALL mpi_isend(msgin(1), msglen, mpi_double_precision, dest, my_tag, &
17841 comm%handle, send_request%handle, ierr)
17842 ELSE
17843 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
17844 comm%handle, send_request%handle, ierr)
17845 END IF
17846 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
17847
17848 msglen = (msglen + SIZE(msgout, 1) + 1)/2
17849 CALL add_perf(perf_id=8, count=1, msg_size=msglen*real_8_size)
17850#else
17851 mark_used(dest)
17852 mark_used(source)
17853 mark_used(comm)
17854 mark_used(tag)
17855 send_request = mp_request_null
17856 recv_request = mp_request_null
17857 msgout = msgin
17858#endif
17859 CALL mp_timestop(handle)
17860 END SUBROUTINE mp_isendrecv_dv
17861
17862! **************************************************************************************************
17863!> \brief Non-blocking send of vector data
17864!> \param msgin ...
17865!> \param dest ...
17866!> \param comm ...
17867!> \param request ...
17868!> \param tag ...
17869!> \par History
17870!> 08.2003 created [f&j]
17871!> \note see mp_isendrecv_dv
17872!> \note
17873!> arrays can be pointers or assumed shape, but they must be contiguous!
17874! **************************************************************************************************
17875 SUBROUTINE mp_isend_dv(msgin, dest, comm, request, tag)
17876 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
17877 INTEGER, INTENT(IN) :: dest
17878 CLASS(mp_comm_type), INTENT(IN) :: comm
17879 TYPE(mp_request_type), INTENT(out) :: request
17880 INTEGER, INTENT(in), OPTIONAL :: tag
17881
17882 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dv'
17883
17884 INTEGER :: handle, ierr
17885#if defined(__parallel)
17886 INTEGER :: msglen, my_tag
17887 REAL(kind=real_8) :: foo(1)
17888#endif
17889
17890 CALL mp_timeset(routinen, handle)
17891
17892#if defined(__parallel)
17893#if !defined(__GNUC__) || __GNUC__ >= 9
17894 cpassert(is_contiguous(msgin))
17895#endif
17896 my_tag = 0
17897 IF (PRESENT(tag)) my_tag = tag
17898
17899 msglen = SIZE(msgin)
17900 IF (msglen > 0) THEN
17901 CALL mpi_isend(msgin(1), msglen, mpi_double_precision, dest, my_tag, &
17902 comm%handle, request%handle, ierr)
17903 ELSE
17904 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
17905 comm%handle, request%handle, ierr)
17906 END IF
17907 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
17908
17909 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
17910#else
17911 mark_used(msgin)
17912 mark_used(dest)
17913 mark_used(comm)
17914 mark_used(request)
17915 mark_used(tag)
17916 ierr = 1
17917 request = mp_request_null
17918 CALL mp_stop(ierr, "mp_isend called in non parallel case")
17919#endif
17920 CALL mp_timestop(handle)
17921 END SUBROUTINE mp_isend_dv
17922
17923! **************************************************************************************************
17924!> \brief Non-blocking send of matrix data
17925!> \param msgin ...
17926!> \param dest ...
17927!> \param comm ...
17928!> \param request ...
17929!> \param tag ...
17930!> \par History
17931!> 2009-11-25 [UB] Made type-generic for templates
17932!> \author fawzi
17933!> \note see mp_isendrecv_dv
17934!> \note see mp_isend_dv
17935!> \note
17936!> arrays can be pointers or assumed shape, but they must be contiguous!
17937! **************************************************************************************************
17938 SUBROUTINE mp_isend_dm2(msgin, dest, comm, request, tag)
17939 REAL(kind=real_8), DIMENSION(:, :), INTENT(IN) :: msgin
17940 INTEGER, INTENT(IN) :: dest
17941 CLASS(mp_comm_type), INTENT(IN) :: comm
17942 TYPE(mp_request_type), INTENT(out) :: request
17943 INTEGER, INTENT(in), OPTIONAL :: tag
17944
17945 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm2'
17946
17947 INTEGER :: handle, ierr
17948#if defined(__parallel)
17949 INTEGER :: msglen, my_tag
17950 REAL(kind=real_8) :: foo(1)
17951#endif
17952
17953 CALL mp_timeset(routinen, handle)
17954
17955#if defined(__parallel)
17956#if !defined(__GNUC__) || __GNUC__ >= 9
17957 cpassert(is_contiguous(msgin))
17958#endif
17959
17960 my_tag = 0
17961 IF (PRESENT(tag)) my_tag = tag
17962
17963 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
17964 IF (msglen > 0) THEN
17965 CALL mpi_isend(msgin(1, 1), msglen, mpi_double_precision, dest, my_tag, &
17966 comm%handle, request%handle, ierr)
17967 ELSE
17968 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
17969 comm%handle, request%handle, ierr)
17970 END IF
17971 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
17972
17973 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
17974#else
17975 mark_used(msgin)
17976 mark_used(dest)
17977 mark_used(comm)
17978 mark_used(request)
17979 mark_used(tag)
17980 ierr = 1
17981 request = mp_request_null
17982 CALL mp_stop(ierr, "mp_isend called in non parallel case")
17983#endif
17984 CALL mp_timestop(handle)
17985 END SUBROUTINE mp_isend_dm2
17986
17987! **************************************************************************************************
17988!> \brief Non-blocking send of rank-3 data
17989!> \param msgin ...
17990!> \param dest ...
17991!> \param comm ...
17992!> \param request ...
17993!> \param tag ...
17994!> \par History
17995!> 9.2008 added _rm3 subroutine [Iain Bethune]
17996!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
17997!> 2009-11-25 [UB] Made type-generic for templates
17998!> \author fawzi
17999!> \note see mp_isendrecv_dv
18000!> \note see mp_isend_dv
18001!> \note
18002!> arrays can be pointers or assumed shape, but they must be contiguous!
18003! **************************************************************************************************
18004 SUBROUTINE mp_isend_dm3(msgin, dest, comm, request, tag)
18005 REAL(kind=real_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
18006 INTEGER, INTENT(IN) :: dest
18007 CLASS(mp_comm_type), INTENT(IN) :: comm
18008 TYPE(mp_request_type), INTENT(out) :: request
18009 INTEGER, INTENT(in), OPTIONAL :: tag
18010
18011 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm3'
18012
18013 INTEGER :: handle, ierr
18014#if defined(__parallel)
18015 INTEGER :: msglen, my_tag
18016 REAL(kind=real_8) :: foo(1)
18017#endif
18018
18019 CALL mp_timeset(routinen, handle)
18020
18021#if defined(__parallel)
18022#if !defined(__GNUC__) || __GNUC__ >= 9
18023 cpassert(is_contiguous(msgin))
18024#endif
18025
18026 my_tag = 0
18027 IF (PRESENT(tag)) my_tag = tag
18028
18029 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
18030 IF (msglen > 0) THEN
18031 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_double_precision, dest, my_tag, &
18032 comm%handle, request%handle, ierr)
18033 ELSE
18034 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18035 comm%handle, request%handle, ierr)
18036 END IF
18037 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18038
18039 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18040#else
18041 mark_used(msgin)
18042 mark_used(dest)
18043 mark_used(comm)
18044 mark_used(request)
18045 mark_used(tag)
18046 ierr = 1
18047 request = mp_request_null
18048 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18049#endif
18050 CALL mp_timestop(handle)
18051 END SUBROUTINE mp_isend_dm3
18052
18053! **************************************************************************************************
18054!> \brief Non-blocking send of rank-4 data
18055!> \param msgin the input message
18056!> \param dest the destination processor
18057!> \param comm the communicator object
18058!> \param request the communication request id
18059!> \param tag the message tag
18060!> \par History
18061!> 2.2016 added _dm4 subroutine [Nico Holmberg]
18062!> \author fawzi
18063!> \note see mp_isend_dv
18064!> \note
18065!> arrays can be pointers or assumed shape, but they must be contiguous!
18066! **************************************************************************************************
18067 SUBROUTINE mp_isend_dm4(msgin, dest, comm, request, tag)
18068 REAL(kind=real_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
18069 INTEGER, INTENT(IN) :: dest
18070 CLASS(mp_comm_type), INTENT(IN) :: comm
18071 TYPE(mp_request_type), INTENT(out) :: request
18072 INTEGER, INTENT(in), OPTIONAL :: tag
18073
18074 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm4'
18075
18076 INTEGER :: handle, ierr
18077#if defined(__parallel)
18078 INTEGER :: msglen, my_tag
18079 REAL(kind=real_8) :: foo(1)
18080#endif
18081
18082 CALL mp_timeset(routinen, handle)
18083
18084#if defined(__parallel)
18085#if !defined(__GNUC__) || __GNUC__ >= 9
18086 cpassert(is_contiguous(msgin))
18087#endif
18088
18089 my_tag = 0
18090 IF (PRESENT(tag)) my_tag = tag
18091
18092 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
18093 IF (msglen > 0) THEN
18094 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_double_precision, dest, my_tag, &
18095 comm%handle, request%handle, ierr)
18096 ELSE
18097 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18098 comm%handle, request%handle, ierr)
18099 END IF
18100 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18101
18102 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18103#else
18104 mark_used(msgin)
18105 mark_used(dest)
18106 mark_used(comm)
18107 mark_used(request)
18108 mark_used(tag)
18109 ierr = 1
18110 request = mp_request_null
18111 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18112#endif
18113 CALL mp_timestop(handle)
18114 END SUBROUTINE mp_isend_dm4
18115
18116! **************************************************************************************************
18117!> \brief Non-blocking receive of vector data
18118!> \param msgout ...
18119!> \param source ...
18120!> \param comm ...
18121!> \param request ...
18122!> \param tag ...
18123!> \par History
18124!> 08.2003 created [f&j]
18125!> 2009-11-25 [UB] Made type-generic for templates
18126!> \note see mp_isendrecv_dv
18127!> \note
18128!> arrays can be pointers or assumed shape, but they must be contiguous!
18129! **************************************************************************************************
18130 SUBROUTINE mp_irecv_dv(msgout, source, comm, request, tag)
18131 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
18132 INTEGER, INTENT(IN) :: source
18133 CLASS(mp_comm_type), INTENT(IN) :: comm
18134 TYPE(mp_request_type), INTENT(out) :: request
18135 INTEGER, INTENT(in), OPTIONAL :: tag
18136
18137 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dv'
18138
18139 INTEGER :: handle
18140#if defined(__parallel)
18141 INTEGER :: ierr, msglen, my_tag
18142 REAL(kind=real_8) :: foo(1)
18143#endif
18144
18145 CALL mp_timeset(routinen, handle)
18146
18147#if defined(__parallel)
18148#if !defined(__GNUC__) || __GNUC__ >= 9
18149 cpassert(is_contiguous(msgout))
18150#endif
18151
18152 my_tag = 0
18153 IF (PRESENT(tag)) my_tag = tag
18154
18155 msglen = SIZE(msgout)
18156 IF (msglen > 0) THEN
18157 CALL mpi_irecv(msgout(1), msglen, mpi_double_precision, source, my_tag, &
18158 comm%handle, request%handle, ierr)
18159 ELSE
18160 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18161 comm%handle, request%handle, ierr)
18162 END IF
18163 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18164
18165 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18166#else
18167 cpabort("mp_irecv called in non parallel case")
18168 mark_used(msgout)
18169 mark_used(source)
18170 mark_used(comm)
18171 mark_used(tag)
18172 request = mp_request_null
18173#endif
18174 CALL mp_timestop(handle)
18175 END SUBROUTINE mp_irecv_dv
18176
18177! **************************************************************************************************
18178!> \brief Non-blocking receive of matrix data
18179!> \param msgout ...
18180!> \param source ...
18181!> \param comm ...
18182!> \param request ...
18183!> \param tag ...
18184!> \par History
18185!> 2009-11-25 [UB] Made type-generic for templates
18186!> \author fawzi
18187!> \note see mp_isendrecv_dv
18188!> \note see mp_irecv_dv
18189!> \note
18190!> arrays can be pointers or assumed shape, but they must be contiguous!
18191! **************************************************************************************************
18192 SUBROUTINE mp_irecv_dm2(msgout, source, comm, request, tag)
18193 REAL(kind=real_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
18194 INTEGER, INTENT(IN) :: source
18195 CLASS(mp_comm_type), INTENT(IN) :: comm
18196 TYPE(mp_request_type), INTENT(out) :: request
18197 INTEGER, INTENT(in), OPTIONAL :: tag
18198
18199 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm2'
18200
18201 INTEGER :: handle
18202#if defined(__parallel)
18203 INTEGER :: ierr, msglen, my_tag
18204 REAL(kind=real_8) :: foo(1)
18205#endif
18206
18207 CALL mp_timeset(routinen, handle)
18208
18209#if defined(__parallel)
18210#if !defined(__GNUC__) || __GNUC__ >= 9
18211 cpassert(is_contiguous(msgout))
18212#endif
18213
18214 my_tag = 0
18215 IF (PRESENT(tag)) my_tag = tag
18216
18217 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
18218 IF (msglen > 0) THEN
18219 CALL mpi_irecv(msgout(1, 1), msglen, mpi_double_precision, source, my_tag, &
18220 comm%handle, request%handle, ierr)
18221 ELSE
18222 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18223 comm%handle, request%handle, ierr)
18224 END IF
18225 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18226
18227 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18228#else
18229 mark_used(msgout)
18230 mark_used(source)
18231 mark_used(comm)
18232 mark_used(tag)
18233 request = mp_request_null
18234 cpabort("mp_irecv called in non parallel case")
18235#endif
18236 CALL mp_timestop(handle)
18237 END SUBROUTINE mp_irecv_dm2
18238
18239! **************************************************************************************************
18240!> \brief Non-blocking send of rank-3 data
18241!> \param msgout ...
18242!> \param source ...
18243!> \param comm ...
18244!> \param request ...
18245!> \param tag ...
18246!> \par History
18247!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
18248!> 2009-11-25 [UB] Made type-generic for templates
18249!> \author fawzi
18250!> \note see mp_isendrecv_dv
18251!> \note see mp_irecv_dv
18252!> \note
18253!> arrays can be pointers or assumed shape, but they must be contiguous!
18254! **************************************************************************************************
18255 SUBROUTINE mp_irecv_dm3(msgout, source, comm, request, tag)
18256 REAL(kind=real_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
18257 INTEGER, INTENT(IN) :: source
18258 CLASS(mp_comm_type), INTENT(IN) :: comm
18259 TYPE(mp_request_type), INTENT(out) :: request
18260 INTEGER, INTENT(in), OPTIONAL :: tag
18261
18262 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm3'
18263
18264 INTEGER :: handle
18265#if defined(__parallel)
18266 INTEGER :: ierr, msglen, my_tag
18267 REAL(kind=real_8) :: foo(1)
18268#endif
18269
18270 CALL mp_timeset(routinen, handle)
18271
18272#if defined(__parallel)
18273#if !defined(__GNUC__) || __GNUC__ >= 9
18274 cpassert(is_contiguous(msgout))
18275#endif
18276
18277 my_tag = 0
18278 IF (PRESENT(tag)) my_tag = tag
18279
18280 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
18281 IF (msglen > 0) THEN
18282 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_double_precision, source, my_tag, &
18283 comm%handle, request%handle, ierr)
18284 ELSE
18285 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18286 comm%handle, request%handle, ierr)
18287 END IF
18288 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
18289
18290 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18291#else
18292 mark_used(msgout)
18293 mark_used(source)
18294 mark_used(comm)
18295 mark_used(tag)
18296 request = mp_request_null
18297 cpabort("mp_irecv called in non parallel case")
18298#endif
18299 CALL mp_timestop(handle)
18300 END SUBROUTINE mp_irecv_dm3
18301
18302! **************************************************************************************************
18303!> \brief Non-blocking receive of rank-4 data
18304!> \param msgout the output message
18305!> \param source the source processor
18306!> \param comm the communicator object
18307!> \param request the communication request id
18308!> \param tag the message tag
18309!> \par History
18310!> 2.2016 added _dm4 subroutine [Nico Holmberg]
18311!> \author fawzi
18312!> \note see mp_irecv_dv
18313!> \note
18314!> arrays can be pointers or assumed shape, but they must be contiguous!
18315! **************************************************************************************************
18316 SUBROUTINE mp_irecv_dm4(msgout, source, comm, request, tag)
18317 REAL(kind=real_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
18318 INTEGER, INTENT(IN) :: source
18319 CLASS(mp_comm_type), INTENT(IN) :: comm
18320 TYPE(mp_request_type), INTENT(out) :: request
18321 INTEGER, INTENT(in), OPTIONAL :: tag
18322
18323 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm4'
18324
18325 INTEGER :: handle
18326#if defined(__parallel)
18327 INTEGER :: ierr, msglen, my_tag
18328 REAL(kind=real_8) :: foo(1)
18329#endif
18330
18331 CALL mp_timeset(routinen, handle)
18332
18333#if defined(__parallel)
18334#if !defined(__GNUC__) || __GNUC__ >= 9
18335 cpassert(is_contiguous(msgout))
18336#endif
18337
18338 my_tag = 0
18339 IF (PRESENT(tag)) my_tag = tag
18340
18341 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
18342 IF (msglen > 0) THEN
18343 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_double_precision, source, my_tag, &
18344 comm%handle, request%handle, ierr)
18345 ELSE
18346 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18347 comm%handle, request%handle, ierr)
18348 END IF
18349 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
18350
18351 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18352#else
18353 mark_used(msgout)
18354 mark_used(source)
18355 mark_used(comm)
18356 mark_used(tag)
18357 request = mp_request_null
18358 cpabort("mp_irecv called in non parallel case")
18359#endif
18360 CALL mp_timestop(handle)
18361 END SUBROUTINE mp_irecv_dm4
18362
18363! **************************************************************************************************
18364!> \brief Window initialization function for vector data
18365!> \param base ...
18366!> \param comm ...
18367!> \param win ...
18368!> \par History
18369!> 02.2015 created [Alfio Lazzaro]
18370!> \note
18371!> arrays can be pointers or assumed shape, but they must be contiguous!
18372! **************************************************************************************************
18373 SUBROUTINE mp_win_create_dv(base, comm, win)
18374 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
18375 TYPE(mp_comm_type), INTENT(IN) :: comm
18376 CLASS(mp_win_type), INTENT(INOUT) :: win
18377
18378 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_dv'
18379
18380 INTEGER :: handle
18381#if defined(__parallel)
18382 INTEGER :: ierr
18383 INTEGER(kind=mpi_address_kind) :: len
18384 REAL(kind=real_8) :: foo(1)
18385#endif
18386
18387 CALL mp_timeset(routinen, handle)
18388
18389#if defined(__parallel)
18390
18391 len = SIZE(base)*real_8_size
18392 IF (len > 0) THEN
18393 CALL mpi_win_create(base(1), len, real_8_size, mpi_info_null, comm%handle, win%handle, ierr)
18394 ELSE
18395 CALL mpi_win_create(foo, len, real_8_size, mpi_info_null, comm%handle, win%handle, ierr)
18396 END IF
18397 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
18398
18399 CALL add_perf(perf_id=20, count=1)
18400#else
18401 mark_used(base)
18402 mark_used(comm)
18403 win%handle = mp_win_null_handle
18404#endif
18405 CALL mp_timestop(handle)
18406 END SUBROUTINE mp_win_create_dv
18407
18408! **************************************************************************************************
18409!> \brief Single-sided get function for vector data
18410!> \param base ...
18411!> \param comm ...
18412!> \param win ...
18413!> \par History
18414!> 02.2015 created [Alfio Lazzaro]
18415!> \note
18416!> arrays can be pointers or assumed shape, but they must be contiguous!
18417! **************************************************************************************************
18418 SUBROUTINE mp_rget_dv(base, source, win, win_data, myproc, disp, request, &
18419 origin_datatype, target_datatype)
18420 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
18421 INTEGER, INTENT(IN) :: source
18422 CLASS(mp_win_type), INTENT(IN) :: win
18423 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: win_data
18424 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
18425 TYPE(mp_request_type), INTENT(OUT) :: request
18426 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
18427
18428 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_dv'
18429
18430 INTEGER :: handle
18431#if defined(__parallel)
18432 INTEGER :: ierr, len, &
18433 origin_len, target_len
18434 LOGICAL :: do_local_copy
18435 INTEGER(kind=mpi_address_kind) :: disp_aint
18436 mpi_data_type :: handle_origin_datatype, handle_target_datatype
18437#endif
18438
18439 CALL mp_timeset(routinen, handle)
18440
18441#if defined(__parallel)
18442 len = SIZE(base)
18443 disp_aint = 0
18444 IF (PRESENT(disp)) THEN
18445 disp_aint = int(disp, kind=mpi_address_kind)
18446 END IF
18447 handle_origin_datatype = mpi_double_precision
18448 origin_len = len
18449 IF (PRESENT(origin_datatype)) THEN
18450 handle_origin_datatype = origin_datatype%type_handle
18451 origin_len = 1
18452 END IF
18453 handle_target_datatype = mpi_double_precision
18454 target_len = len
18455 IF (PRESENT(target_datatype)) THEN
18456 handle_target_datatype = target_datatype%type_handle
18457 target_len = 1
18458 END IF
18459 IF (len > 0) THEN
18460 do_local_copy = .false.
18461 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
18462 IF (myproc .EQ. source) do_local_copy = .true.
18463 END IF
18464 IF (do_local_copy) THEN
18465 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
18466 base(:) = win_data(disp_aint + 1:disp_aint + len)
18467 !$OMP END PARALLEL WORKSHARE
18468 request = mp_request_null
18469 ierr = 0
18470 ELSE
18471 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
18472 target_len, handle_target_datatype, win%handle, request%handle, ierr)
18473 END IF
18474 ELSE
18475 request = mp_request_null
18476 ierr = 0
18477 END IF
18478 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
18479
18480 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*real_8_size)
18481#else
18482 mark_used(source)
18483 mark_used(win)
18484 mark_used(myproc)
18485 mark_used(origin_datatype)
18486 mark_used(target_datatype)
18487
18488 request = mp_request_null
18489 !
18490 IF (PRESENT(disp)) THEN
18491 base(:) = win_data(disp + 1:disp + SIZE(base))
18492 ELSE
18493 base(:) = win_data(:SIZE(base))
18494 END IF
18495
18496#endif
18497 CALL mp_timestop(handle)
18498 END SUBROUTINE mp_rget_dv
18499
18500! **************************************************************************************************
18501!> \brief ...
18502!> \param count ...
18503!> \param lengths ...
18504!> \param displs ...
18505!> \return ...
18506! ***************************************************************************
18507 FUNCTION mp_type_indexed_make_d (count, lengths, displs) &
18508 result(type_descriptor)
18509 INTEGER, INTENT(IN) :: count
18510 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
18511 TYPE(mp_type_descriptor_type) :: type_descriptor
18512
18513 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_d'
18514
18515 INTEGER :: handle
18516#if defined(__parallel)
18517 INTEGER :: ierr
18518#endif
18519
18520 CALL mp_timeset(routinen, handle)
18521
18522#if defined(__parallel)
18523 CALL mpi_type_indexed(count, lengths, displs, mpi_double_precision, &
18524 type_descriptor%type_handle, ierr)
18525 IF (ierr /= 0) &
18526 cpabort("MPI_Type_Indexed @ "//routinen)
18527 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
18528 IF (ierr /= 0) &
18529 cpabort("MPI_Type_commit @ "//routinen)
18530#else
18531 type_descriptor%type_handle = 3
18532#endif
18533 type_descriptor%length = count
18534 NULLIFY (type_descriptor%subtype)
18535 type_descriptor%vector_descriptor(1:2) = 1
18536 type_descriptor%has_indexing = .true.
18537 type_descriptor%index_descriptor%index => lengths
18538 type_descriptor%index_descriptor%chunks => displs
18539
18540 CALL mp_timestop(handle)
18541
18542 END FUNCTION mp_type_indexed_make_d
18543
18544! **************************************************************************************************
18545!> \brief Allocates special parallel memory
18546!> \param[in] DATA pointer to integer array to allocate
18547!> \param[in] len number of integers to allocate
18548!> \param[out] stat (optional) allocation status result
18549!> \author UB
18550! **************************************************************************************************
18551 SUBROUTINE mp_allocate_d (DATA, len, stat)
18552 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
18553 INTEGER, INTENT(IN) :: len
18554 INTEGER, INTENT(OUT), OPTIONAL :: stat
18555
18556 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_d'
18557
18558 INTEGER :: handle, ierr
18559
18560 CALL mp_timeset(routinen, handle)
18561
18562#if defined(__parallel)
18563 NULLIFY (data)
18564 CALL mp_alloc_mem(DATA, len, stat=ierr)
18565 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
18566 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
18567 CALL add_perf(perf_id=15, count=1)
18568#else
18569 ALLOCATE (DATA(len), stat=ierr)
18570 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
18571 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
18572#endif
18573 IF (PRESENT(stat)) stat = ierr
18574 CALL mp_timestop(handle)
18575 END SUBROUTINE mp_allocate_d
18576
18577! **************************************************************************************************
18578!> \brief Deallocates special parallel memory
18579!> \param[in] DATA pointer to special memory to deallocate
18580!> \param stat ...
18581!> \author UB
18582! **************************************************************************************************
18583 SUBROUTINE mp_deallocate_d (DATA, stat)
18584 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
18585 INTEGER, INTENT(OUT), OPTIONAL :: stat
18586
18587 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_d'
18588
18589 INTEGER :: handle
18590#if defined(__parallel)
18591 INTEGER :: ierr
18592#endif
18593
18594 CALL mp_timeset(routinen, handle)
18595
18596#if defined(__parallel)
18597 CALL mp_free_mem(DATA, ierr)
18598 IF (PRESENT(stat)) THEN
18599 stat = ierr
18600 ELSE
18601 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
18602 END IF
18603 NULLIFY (data)
18604 CALL add_perf(perf_id=15, count=1)
18605#else
18606 DEALLOCATE (data)
18607 IF (PRESENT(stat)) stat = 0
18608#endif
18609 CALL mp_timestop(handle)
18610 END SUBROUTINE mp_deallocate_d
18611
18612! **************************************************************************************************
18613!> \brief (parallel) Blocking individual file write using explicit offsets
18614!> (serial) Unformatted stream write
18615!> \param[in] fh file handle (file storage unit)
18616!> \param[in] offset file offset (position)
18617!> \param[in] msg data to be written to the file
18618!> \param msglen ...
18619!> \par MPI-I/O mapping mpi_file_write_at
18620!> \par STREAM-I/O mapping WRITE
18621!> \param[in](optional) msglen number of the elements of data
18622! **************************************************************************************************
18623 SUBROUTINE mp_file_write_at_dv(fh, offset, msg, msglen)
18624 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
18625 CLASS(mp_file_type), INTENT(IN) :: fh
18626 INTEGER, INTENT(IN), OPTIONAL :: msglen
18627 INTEGER(kind=file_offset), INTENT(IN) :: offset
18628
18629 INTEGER :: msg_len
18630#if defined(__parallel)
18631 INTEGER :: ierr
18632#endif
18633
18634 msg_len = SIZE(msg)
18635 IF (PRESENT(msglen)) msg_len = msglen
18636#if defined(__parallel)
18637 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18638 IF (ierr .NE. 0) &
18639 cpabort("mpi_file_write_at_dv @ mp_file_write_at_dv")
18640#else
18641 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18642#endif
18643 END SUBROUTINE mp_file_write_at_dv
18644
18645! **************************************************************************************************
18646!> \brief ...
18647!> \param fh ...
18648!> \param offset ...
18649!> \param msg ...
18650! **************************************************************************************************
18651 SUBROUTINE mp_file_write_at_d (fh, offset, msg)
18652 REAL(kind=real_8), INTENT(IN) :: msg
18653 CLASS(mp_file_type), INTENT(IN) :: fh
18654 INTEGER(kind=file_offset), INTENT(IN) :: offset
18655
18656#if defined(__parallel)
18657 INTEGER :: ierr
18658
18659 ierr = 0
18660 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18661 IF (ierr .NE. 0) &
18662 cpabort("mpi_file_write_at_d @ mp_file_write_at_d")
18663#else
18664 WRITE (unit=fh%handle, pos=offset + 1) msg
18665#endif
18666 END SUBROUTINE mp_file_write_at_d
18667
18668! **************************************************************************************************
18669!> \brief (parallel) Blocking collective file write using explicit offsets
18670!> (serial) Unformatted stream write
18671!> \param fh ...
18672!> \param offset ...
18673!> \param msg ...
18674!> \param msglen ...
18675!> \par MPI-I/O mapping mpi_file_write_at_all
18676!> \par STREAM-I/O mapping WRITE
18677! **************************************************************************************************
18678 SUBROUTINE mp_file_write_at_all_dv(fh, offset, msg, msglen)
18679 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
18680 CLASS(mp_file_type), INTENT(IN) :: fh
18681 INTEGER, INTENT(IN), OPTIONAL :: msglen
18682 INTEGER(kind=file_offset), INTENT(IN) :: offset
18683
18684 INTEGER :: msg_len
18685#if defined(__parallel)
18686 INTEGER :: ierr
18687#endif
18688
18689 msg_len = SIZE(msg)
18690 IF (PRESENT(msglen)) msg_len = msglen
18691#if defined(__parallel)
18692 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18693 IF (ierr .NE. 0) &
18694 cpabort("mpi_file_write_at_all_dv @ mp_file_write_at_all_dv")
18695#else
18696 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18697#endif
18698 END SUBROUTINE mp_file_write_at_all_dv
18699
18700! **************************************************************************************************
18701!> \brief ...
18702!> \param fh ...
18703!> \param offset ...
18704!> \param msg ...
18705! **************************************************************************************************
18706 SUBROUTINE mp_file_write_at_all_d (fh, offset, msg)
18707 REAL(kind=real_8), INTENT(IN) :: msg
18708 CLASS(mp_file_type), INTENT(IN) :: fh
18709 INTEGER(kind=file_offset), INTENT(IN) :: offset
18710
18711#if defined(__parallel)
18712 INTEGER :: ierr
18713
18714 ierr = 0
18715 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18716 IF (ierr .NE. 0) &
18717 cpabort("mpi_file_write_at_all_d @ mp_file_write_at_all_d")
18718#else
18719 WRITE (unit=fh%handle, pos=offset + 1) msg
18720#endif
18721 END SUBROUTINE mp_file_write_at_all_d
18722
18723! **************************************************************************************************
18724!> \brief (parallel) Blocking individual file read using explicit offsets
18725!> (serial) Unformatted stream read
18726!> \param[in] fh file handle (file storage unit)
18727!> \param[in] offset file offset (position)
18728!> \param[out] msg data to be read from the file
18729!> \param msglen ...
18730!> \par MPI-I/O mapping mpi_file_read_at
18731!> \par STREAM-I/O mapping READ
18732!> \param[in](optional) msglen number of elements of data
18733! **************************************************************************************************
18734 SUBROUTINE mp_file_read_at_dv(fh, offset, msg, msglen)
18735 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
18736 CLASS(mp_file_type), INTENT(IN) :: fh
18737 INTEGER, INTENT(IN), OPTIONAL :: msglen
18738 INTEGER(kind=file_offset), INTENT(IN) :: offset
18739
18740 INTEGER :: msg_len
18741#if defined(__parallel)
18742 INTEGER :: ierr
18743#endif
18744
18745 msg_len = SIZE(msg)
18746 IF (PRESENT(msglen)) msg_len = msglen
18747#if defined(__parallel)
18748 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18749 IF (ierr .NE. 0) &
18750 cpabort("mpi_file_read_at_dv @ mp_file_read_at_dv")
18751#else
18752 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18753#endif
18754 END SUBROUTINE mp_file_read_at_dv
18755
18756! **************************************************************************************************
18757!> \brief ...
18758!> \param fh ...
18759!> \param offset ...
18760!> \param msg ...
18761! **************************************************************************************************
18762 SUBROUTINE mp_file_read_at_d (fh, offset, msg)
18763 REAL(kind=real_8), INTENT(OUT) :: msg
18764 CLASS(mp_file_type), INTENT(IN) :: fh
18765 INTEGER(kind=file_offset), INTENT(IN) :: offset
18766
18767#if defined(__parallel)
18768 INTEGER :: ierr
18769
18770 ierr = 0
18771 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18772 IF (ierr .NE. 0) &
18773 cpabort("mpi_file_read_at_d @ mp_file_read_at_d")
18774#else
18775 READ (unit=fh%handle, pos=offset + 1) msg
18776#endif
18777 END SUBROUTINE mp_file_read_at_d
18778
18779! **************************************************************************************************
18780!> \brief (parallel) Blocking collective file read using explicit offsets
18781!> (serial) Unformatted stream read
18782!> \param fh ...
18783!> \param offset ...
18784!> \param msg ...
18785!> \param msglen ...
18786!> \par MPI-I/O mapping mpi_file_read_at_all
18787!> \par STREAM-I/O mapping READ
18788! **************************************************************************************************
18789 SUBROUTINE mp_file_read_at_all_dv(fh, offset, msg, msglen)
18790 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
18791 CLASS(mp_file_type), INTENT(IN) :: fh
18792 INTEGER, INTENT(IN), OPTIONAL :: msglen
18793 INTEGER(kind=file_offset), INTENT(IN) :: offset
18794
18795 INTEGER :: msg_len
18796#if defined(__parallel)
18797 INTEGER :: ierr
18798#endif
18799
18800 msg_len = SIZE(msg)
18801 IF (PRESENT(msglen)) msg_len = msglen
18802#if defined(__parallel)
18803 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18804 IF (ierr .NE. 0) &
18805 cpabort("mpi_file_read_at_all_dv @ mp_file_read_at_all_dv")
18806#else
18807 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18808#endif
18809 END SUBROUTINE mp_file_read_at_all_dv
18810
18811! **************************************************************************************************
18812!> \brief ...
18813!> \param fh ...
18814!> \param offset ...
18815!> \param msg ...
18816! **************************************************************************************************
18817 SUBROUTINE mp_file_read_at_all_d (fh, offset, msg)
18818 REAL(kind=real_8), INTENT(OUT) :: msg
18819 CLASS(mp_file_type), INTENT(IN) :: fh
18820 INTEGER(kind=file_offset), INTENT(IN) :: offset
18821
18822#if defined(__parallel)
18823 INTEGER :: ierr
18824
18825 ierr = 0
18826 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18827 IF (ierr .NE. 0) &
18828 cpabort("mpi_file_read_at_all_d @ mp_file_read_at_all_d")
18829#else
18830 READ (unit=fh%handle, pos=offset + 1) msg
18831#endif
18832 END SUBROUTINE mp_file_read_at_all_d
18833
18834! **************************************************************************************************
18835!> \brief ...
18836!> \param ptr ...
18837!> \param vector_descriptor ...
18838!> \param index_descriptor ...
18839!> \return ...
18840! **************************************************************************************************
18841 FUNCTION mp_type_make_d (ptr, &
18842 vector_descriptor, index_descriptor) &
18843 result(type_descriptor)
18844 REAL(kind=real_8), DIMENSION(:), TARGET, asynchronous :: ptr
18845 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
18846 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
18847 TYPE(mp_type_descriptor_type) :: type_descriptor
18848
18849 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_d'
18850
18851#if defined(__parallel)
18852 INTEGER :: ierr
18853#if defined(__MPI_F08)
18854 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
18855 EXTERNAL :: mpi_get_address
18856#endif
18857#endif
18858
18859 NULLIFY (type_descriptor%subtype)
18860 type_descriptor%length = SIZE(ptr)
18861#if defined(__parallel)
18862 type_descriptor%type_handle = mpi_double_precision
18863 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
18864 IF (ierr /= 0) &
18865 cpabort("MPI_Get_address @ "//routinen)
18866#else
18867 type_descriptor%type_handle = 3
18868#endif
18869 type_descriptor%vector_descriptor(1:2) = 1
18870 type_descriptor%has_indexing = .false.
18871 type_descriptor%data_d => ptr
18872 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
18873 cpabort(routinen//": Vectors and indices NYI")
18874 END IF
18875 END FUNCTION mp_type_make_d
18876
18877! **************************************************************************************************
18878!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
18879!> as the Fortran version returns an integer, which we take to be a C_PTR
18880!> \param DATA data array to allocate
18881!> \param[in] len length (in data elements) of data array allocation
18882!> \param[out] stat (optional) allocation status result
18883! **************************************************************************************************
18884 SUBROUTINE mp_alloc_mem_d (DATA, len, stat)
18885 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
18886 INTEGER, INTENT(IN) :: len
18887 INTEGER, INTENT(OUT), OPTIONAL :: stat
18888
18889#if defined(__parallel)
18890 INTEGER :: size, ierr, length, &
18891 mp_res
18892 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
18893 TYPE(c_ptr) :: mp_baseptr
18894 mpi_info_type :: mp_info
18895
18896 length = max(len, 1)
18897 CALL mpi_type_size(mpi_double_precision, size, ierr)
18898 mp_size = int(length, kind=mpi_address_kind)*size
18899 IF (mp_size .GT. mp_max_memory_size) THEN
18900 cpabort("MPI cannot allocate more than 2 GiByte")
18901 END IF
18902 mp_info = mpi_info_null
18903 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
18904 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
18905 IF (PRESENT(stat)) stat = mp_res
18906#else
18907 INTEGER :: length, mystat
18908 length = max(len, 1)
18909 IF (PRESENT(stat)) THEN
18910 ALLOCATE (DATA(length), stat=mystat)
18911 stat = mystat ! show to convention checker that stat is used
18912 ELSE
18913 ALLOCATE (DATA(length))
18914 END IF
18915#endif
18916 END SUBROUTINE mp_alloc_mem_d
18917
18918! **************************************************************************************************
18919!> \brief Deallocates am array, ... this is hackish
18920!> as the Fortran version takes an integer, which we hope to get by reference
18921!> \param DATA data array to allocate
18922!> \param[out] stat (optional) allocation status result
18923! **************************************************************************************************
18924 SUBROUTINE mp_free_mem_d (DATA, stat)
18925 REAL(kind=real_8), DIMENSION(:), &
18926 POINTER, asynchronous :: DATA
18927 INTEGER, INTENT(OUT), OPTIONAL :: stat
18928
18929#if defined(__parallel)
18930 INTEGER :: mp_res
18931 CALL mpi_free_mem(DATA, mp_res)
18932 IF (PRESENT(stat)) stat = mp_res
18933#else
18934 DEALLOCATE (data)
18935 IF (PRESENT(stat)) stat = 0
18936#endif
18937 END SUBROUTINE mp_free_mem_d
18938! **************************************************************************************************
18939!> \brief Shift around the data in msg
18940!> \param[in,out] msg Rank-2 data to shift
18941!> \param[in] comm message passing environment identifier
18942!> \param[in] displ_in displacements (?)
18943!> \par Example
18944!> msg will be moved from rank to rank+displ_in (in a circular way)
18945!> \par Limitations
18946!> * displ_in will be 1 by default (others not tested)
18947!> * the message array needs to be the same size on all processes
18948! **************************************************************************************************
18949 SUBROUTINE mp_shift_rm(msg, comm, displ_in)
18950
18951 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
18952 CLASS(mp_comm_type), INTENT(IN) :: comm
18953 INTEGER, INTENT(IN), OPTIONAL :: displ_in
18954
18955 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_rm'
18956
18957 INTEGER :: handle, ierror
18958#if defined(__parallel)
18959 INTEGER :: displ, left, &
18960 msglen, myrank, nprocs, &
18961 right, tag
18962#endif
18963
18964 ierror = 0
18965 CALL mp_timeset(routinen, handle)
18966
18967#if defined(__parallel)
18968 CALL mpi_comm_rank(comm%handle, myrank, ierror)
18969 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
18970 CALL mpi_comm_size(comm%handle, nprocs, ierror)
18971 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
18972 IF (PRESENT(displ_in)) THEN
18973 displ = displ_in
18974 ELSE
18975 displ = 1
18976 END IF
18977 right = modulo(myrank + displ, nprocs)
18978 left = modulo(myrank - displ, nprocs)
18979 tag = 17
18980 msglen = SIZE(msg)
18981 CALL mpi_sendrecv_replace(msg, msglen, mpi_real, right, tag, left, tag, &
18982 comm%handle, mpi_status_ignore, ierror)
18983 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
18984 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_4_size)
18985#else
18986 mark_used(msg)
18987 mark_used(comm)
18988 mark_used(displ_in)
18989#endif
18990 CALL mp_timestop(handle)
18991
18992 END SUBROUTINE mp_shift_rm
18993
18994! **************************************************************************************************
18995!> \brief Shift around the data in msg
18996!> \param[in,out] msg Data to shift
18997!> \param[in] comm message passing environment identifier
18998!> \param[in] displ_in displacements (?)
18999!> \par Example
19000!> msg will be moved from rank to rank+displ_in (in a circular way)
19001!> \par Limitations
19002!> * displ_in will be 1 by default (others not tested)
19003!> * the message array needs to be the same size on all processes
19004! **************************************************************************************************
19005 SUBROUTINE mp_shift_r (msg, comm, displ_in)
19006
19007 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19008 CLASS(mp_comm_type), INTENT(IN) :: comm
19009 INTEGER, INTENT(IN), OPTIONAL :: displ_in
19010
19011 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_r'
19012
19013 INTEGER :: handle, ierror
19014#if defined(__parallel)
19015 INTEGER :: displ, left, &
19016 msglen, myrank, nprocs, &
19017 right, tag
19018#endif
19019
19020 ierror = 0
19021 CALL mp_timeset(routinen, handle)
19022
19023#if defined(__parallel)
19024 CALL mpi_comm_rank(comm%handle, myrank, ierror)
19025 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
19026 CALL mpi_comm_size(comm%handle, nprocs, ierror)
19027 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
19028 IF (PRESENT(displ_in)) THEN
19029 displ = displ_in
19030 ELSE
19031 displ = 1
19032 END IF
19033 right = modulo(myrank + displ, nprocs)
19034 left = modulo(myrank - displ, nprocs)
19035 tag = 19
19036 msglen = SIZE(msg)
19037 CALL mpi_sendrecv_replace(msg, msglen, mpi_real, right, tag, left, &
19038 tag, comm%handle, mpi_status_ignore, ierror)
19039 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
19040 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_4_size)
19041#else
19042 mark_used(msg)
19043 mark_used(comm)
19044 mark_used(displ_in)
19045#endif
19046 CALL mp_timestop(handle)
19047
19048 END SUBROUTINE mp_shift_r
19049
19050! **************************************************************************************************
19051!> \brief All-to-all data exchange, rank-1 data of different sizes
19052!> \param[in] sb Data to send
19053!> \param[in] scount Data counts for data sent to other processes
19054!> \param[in] sdispl Respective data offsets for data sent to process
19055!> \param[in,out] rb Buffer into which to receive data
19056!> \param[in] rcount Data counts for data received from other
19057!> processes
19058!> \param[in] rdispl Respective data offsets for data received from
19059!> other processes
19060!> \param[in] comm Message passing environment identifier
19061!> \par MPI mapping
19062!> mpi_alltoallv
19063!> \par Array sizes
19064!> The scount, rcount, and the sdispl and rdispl arrays have a
19065!> size equal to the number of processes.
19066!> \par Offsets
19067!> Values in sdispl and rdispl start with 0.
19068! **************************************************************************************************
19069 SUBROUTINE mp_alltoall_r11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
19070
19071 REAL(kind=real_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
19072 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
19073 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
19074 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
19075 CLASS(mp_comm_type), INTENT(IN) :: comm
19076
19077 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r11v'
19078
19079 INTEGER :: handle
19080#if defined(__parallel)
19081 INTEGER :: ierr, msglen
19082#else
19083 INTEGER :: i
19084#endif
19085
19086 CALL mp_timeset(routinen, handle)
19087
19088#if defined(__parallel)
19089 CALL mpi_alltoallv(sb, scount, sdispl, mpi_real, &
19090 rb, rcount, rdispl, mpi_real, comm%handle, ierr)
19091 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
19092 msglen = sum(scount) + sum(rcount)
19093 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19094#else
19095 mark_used(comm)
19096 mark_used(scount)
19097 mark_used(sdispl)
19098 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
19099 DO i = 1, rcount(1)
19100 rb(rdispl(1) + i) = sb(sdispl(1) + i)
19101 END DO
19102#endif
19103 CALL mp_timestop(handle)
19104
19105 END SUBROUTINE mp_alltoall_r11v
19106
19107! **************************************************************************************************
19108!> \brief All-to-all data exchange, rank-2 data of different sizes
19109!> \param sb ...
19110!> \param scount ...
19111!> \param sdispl ...
19112!> \param rb ...
19113!> \param rcount ...
19114!> \param rdispl ...
19115!> \param comm ...
19116!> \par MPI mapping
19117!> mpi_alltoallv
19118!> \note see mp_alltoall_r11v
19119! **************************************************************************************************
19120 SUBROUTINE mp_alltoall_r22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
19121
19122 REAL(kind=real_4), DIMENSION(:, :), &
19123 INTENT(IN), CONTIGUOUS :: sb
19124 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
19125 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, &
19126 INTENT(INOUT) :: rb
19127 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
19128 CLASS(mp_comm_type), INTENT(IN) :: comm
19129
19130 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r22v'
19131
19132 INTEGER :: handle
19133#if defined(__parallel)
19134 INTEGER :: ierr, msglen
19135#endif
19136
19137 CALL mp_timeset(routinen, handle)
19138
19139#if defined(__parallel)
19140 CALL mpi_alltoallv(sb, scount, sdispl, mpi_real, &
19141 rb, rcount, rdispl, mpi_real, comm%handle, ierr)
19142 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
19143 msglen = sum(scount) + sum(rcount)
19144 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*real_4_size)
19145#else
19146 mark_used(comm)
19147 mark_used(scount)
19148 mark_used(sdispl)
19149 mark_used(rcount)
19150 mark_used(rdispl)
19151 rb = sb
19152#endif
19153 CALL mp_timestop(handle)
19154
19155 END SUBROUTINE mp_alltoall_r22v
19156
19157! **************************************************************************************************
19158!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
19159!> \param[in] sb array with data to send
19160!> \param[out] rb array into which data is received
19161!> \param[in] count number of elements to send/receive (product of the
19162!> extents of the first two dimensions)
19163!> \param[in] comm Message passing environment identifier
19164!> \par Index meaning
19165!> \par The first two indices specify the data while the last index counts
19166!> the processes
19167!> \par Sizes of ranks
19168!> All processes have the same data size.
19169!> \par MPI mapping
19170!> mpi_alltoall
19171! **************************************************************************************************
19172 SUBROUTINE mp_alltoall_r (sb, rb, count, comm)
19173
19174 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
19175 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
19176 INTEGER, INTENT(IN) :: count
19177 CLASS(mp_comm_type), INTENT(IN) :: comm
19178
19179 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r'
19180
19181 INTEGER :: handle
19182#if defined(__parallel)
19183 INTEGER :: ierr, msglen, np
19184#endif
19185
19186 CALL mp_timeset(routinen, handle)
19187
19188#if defined(__parallel)
19189 CALL mpi_alltoall(sb, count, mpi_real, &
19190 rb, count, mpi_real, comm%handle, ierr)
19191 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19192 CALL mpi_comm_size(comm%handle, np, ierr)
19193 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19194 msglen = 2*count*np
19195 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19196#else
19197 mark_used(count)
19198 mark_used(comm)
19199 rb = sb
19200#endif
19201 CALL mp_timestop(handle)
19202
19203 END SUBROUTINE mp_alltoall_r
19204
19205! **************************************************************************************************
19206!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
19207!> \param sb ...
19208!> \param rb ...
19209!> \param count ...
19210!> \param commp ...
19211!> \note see mp_alltoall_r
19212! **************************************************************************************************
19213 SUBROUTINE mp_alltoall_r22(sb, rb, count, comm)
19214
19215 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
19216 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
19217 INTEGER, INTENT(IN) :: count
19218 CLASS(mp_comm_type), INTENT(IN) :: comm
19219
19220 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r22'
19221
19222 INTEGER :: handle
19223#if defined(__parallel)
19224 INTEGER :: ierr, msglen, np
19225#endif
19226
19227 CALL mp_timeset(routinen, handle)
19228
19229#if defined(__parallel)
19230 CALL mpi_alltoall(sb, count, mpi_real, &
19231 rb, count, mpi_real, comm%handle, ierr)
19232 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19233 CALL mpi_comm_size(comm%handle, np, ierr)
19234 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19235 msglen = 2*SIZE(sb)*np
19236 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19237#else
19238 mark_used(count)
19239 mark_used(comm)
19240 rb = sb
19241#endif
19242 CALL mp_timestop(handle)
19243
19244 END SUBROUTINE mp_alltoall_r22
19245
19246! **************************************************************************************************
19247!> \brief All-to-all data exchange, rank-3 data with equal sizes
19248!> \param sb ...
19249!> \param rb ...
19250!> \param count ...
19251!> \param comm ...
19252!> \note see mp_alltoall_r
19253! **************************************************************************************************
19254 SUBROUTINE mp_alltoall_r33(sb, rb, count, comm)
19255
19256 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
19257 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
19258 INTEGER, INTENT(IN) :: count
19259 CLASS(mp_comm_type), INTENT(IN) :: comm
19260
19261 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r33'
19262
19263 INTEGER :: handle
19264#if defined(__parallel)
19265 INTEGER :: ierr, msglen, np
19266#endif
19267
19268 CALL mp_timeset(routinen, handle)
19269
19270#if defined(__parallel)
19271 CALL mpi_alltoall(sb, count, mpi_real, &
19272 rb, count, mpi_real, comm%handle, ierr)
19273 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19274 CALL mpi_comm_size(comm%handle, np, ierr)
19275 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19276 msglen = 2*count*np
19277 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19278#else
19279 mark_used(count)
19280 mark_used(comm)
19281 rb = sb
19282#endif
19283 CALL mp_timestop(handle)
19284
19285 END SUBROUTINE mp_alltoall_r33
19286
19287! **************************************************************************************************
19288!> \brief All-to-all data exchange, rank 4 data, equal sizes
19289!> \param sb ...
19290!> \param rb ...
19291!> \param count ...
19292!> \param comm ...
19293!> \note see mp_alltoall_r
19294! **************************************************************************************************
19295 SUBROUTINE mp_alltoall_r44(sb, rb, count, comm)
19296
19297 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19298 INTENT(IN) :: sb
19299 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19300 INTENT(OUT) :: rb
19301 INTEGER, INTENT(IN) :: count
19302 CLASS(mp_comm_type), INTENT(IN) :: comm
19303
19304 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r44'
19305
19306 INTEGER :: handle
19307#if defined(__parallel)
19308 INTEGER :: ierr, msglen, np
19309#endif
19310
19311 CALL mp_timeset(routinen, handle)
19312
19313#if defined(__parallel)
19314 CALL mpi_alltoall(sb, count, mpi_real, &
19315 rb, count, mpi_real, comm%handle, ierr)
19316 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19317 CALL mpi_comm_size(comm%handle, np, ierr)
19318 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19319 msglen = 2*count*np
19320 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19321#else
19322 mark_used(count)
19323 mark_used(comm)
19324 rb = sb
19325#endif
19326 CALL mp_timestop(handle)
19327
19328 END SUBROUTINE mp_alltoall_r44
19329
19330! **************************************************************************************************
19331!> \brief All-to-all data exchange, rank 5 data, equal sizes
19332!> \param sb ...
19333!> \param rb ...
19334!> \param count ...
19335!> \param comm ...
19336!> \note see mp_alltoall_r
19337! **************************************************************************************************
19338 SUBROUTINE mp_alltoall_r55(sb, rb, count, comm)
19339
19340 REAL(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
19341 INTENT(IN) :: sb
19342 REAL(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
19343 INTENT(OUT) :: rb
19344 INTEGER, INTENT(IN) :: count
19345 CLASS(mp_comm_type), INTENT(IN) :: comm
19346
19347 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r55'
19348
19349 INTEGER :: handle
19350#if defined(__parallel)
19351 INTEGER :: ierr, msglen, np
19352#endif
19353
19354 CALL mp_timeset(routinen, handle)
19355
19356#if defined(__parallel)
19357 CALL mpi_alltoall(sb, count, mpi_real, &
19358 rb, count, mpi_real, comm%handle, ierr)
19359 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19360 CALL mpi_comm_size(comm%handle, np, ierr)
19361 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19362 msglen = 2*count*np
19363 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19364#else
19365 mark_used(count)
19366 mark_used(comm)
19367 rb = sb
19368#endif
19369 CALL mp_timestop(handle)
19370
19371 END SUBROUTINE mp_alltoall_r55
19372
19373! **************************************************************************************************
19374!> \brief All-to-all data exchange, rank-4 data to rank-5 data
19375!> \param sb ...
19376!> \param rb ...
19377!> \param count ...
19378!> \param comm ...
19379!> \note see mp_alltoall_r
19380!> \note User must ensure size consistency.
19381! **************************************************************************************************
19382 SUBROUTINE mp_alltoall_r45(sb, rb, count, comm)
19383
19384 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19385 INTENT(IN) :: sb
19386 REAL(kind=real_4), &
19387 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
19388 INTEGER, INTENT(IN) :: count
19389 CLASS(mp_comm_type), INTENT(IN) :: comm
19390
19391 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r45'
19392
19393 INTEGER :: handle
19394#if defined(__parallel)
19395 INTEGER :: ierr, msglen, np
19396#endif
19397
19398 CALL mp_timeset(routinen, handle)
19399
19400#if defined(__parallel)
19401 CALL mpi_alltoall(sb, count, mpi_real, &
19402 rb, count, mpi_real, comm%handle, ierr)
19403 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19404 CALL mpi_comm_size(comm%handle, np, ierr)
19405 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19406 msglen = 2*count*np
19407 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19408#else
19409 mark_used(count)
19410 mark_used(comm)
19411 rb = reshape(sb, shape(rb))
19412#endif
19413 CALL mp_timestop(handle)
19414
19415 END SUBROUTINE mp_alltoall_r45
19416
19417! **************************************************************************************************
19418!> \brief All-to-all data exchange, rank-3 data to rank-4 data
19419!> \param sb ...
19420!> \param rb ...
19421!> \param count ...
19422!> \param comm ...
19423!> \note see mp_alltoall_r
19424!> \note User must ensure size consistency.
19425! **************************************************************************************************
19426 SUBROUTINE mp_alltoall_r34(sb, rb, count, comm)
19427
19428 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, &
19429 INTENT(IN) :: sb
19430 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19431 INTENT(OUT) :: rb
19432 INTEGER, INTENT(IN) :: count
19433 CLASS(mp_comm_type), INTENT(IN) :: comm
19434
19435 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r34'
19436
19437 INTEGER :: handle
19438#if defined(__parallel)
19439 INTEGER :: ierr, msglen, np
19440#endif
19441
19442 CALL mp_timeset(routinen, handle)
19443
19444#if defined(__parallel)
19445 CALL mpi_alltoall(sb, count, mpi_real, &
19446 rb, count, mpi_real, comm%handle, ierr)
19447 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19448 CALL mpi_comm_size(comm%handle, np, ierr)
19449 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19450 msglen = 2*count*np
19451 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19452#else
19453 mark_used(count)
19454 mark_used(comm)
19455 rb = reshape(sb, shape(rb))
19456#endif
19457 CALL mp_timestop(handle)
19458
19459 END SUBROUTINE mp_alltoall_r34
19460
19461! **************************************************************************************************
19462!> \brief All-to-all data exchange, rank-5 data to rank-4 data
19463!> \param sb ...
19464!> \param rb ...
19465!> \param count ...
19466!> \param comm ...
19467!> \note see mp_alltoall_r
19468!> \note User must ensure size consistency.
19469! **************************************************************************************************
19470 SUBROUTINE mp_alltoall_r54(sb, rb, count, comm)
19471
19472 REAL(kind=real_4), &
19473 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
19474 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19475 INTENT(OUT) :: rb
19476 INTEGER, INTENT(IN) :: count
19477 CLASS(mp_comm_type), INTENT(IN) :: comm
19478
19479 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r54'
19480
19481 INTEGER :: handle
19482#if defined(__parallel)
19483 INTEGER :: ierr, msglen, np
19484#endif
19485
19486 CALL mp_timeset(routinen, handle)
19487
19488#if defined(__parallel)
19489 CALL mpi_alltoall(sb, count, mpi_real, &
19490 rb, count, mpi_real, comm%handle, ierr)
19491 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19492 CALL mpi_comm_size(comm%handle, np, ierr)
19493 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19494 msglen = 2*count*np
19495 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19496#else
19497 mark_used(count)
19498 mark_used(comm)
19499 rb = reshape(sb, shape(rb))
19500#endif
19501 CALL mp_timestop(handle)
19502
19503 END SUBROUTINE mp_alltoall_r54
19504
19505! **************************************************************************************************
19506!> \brief Send one datum to another process
19507!> \param[in] msg Scalar to send
19508!> \param[in] dest Destination process
19509!> \param[in] tag Transfer identifier
19510!> \param[in] comm Message passing environment identifier
19511!> \par MPI mapping
19512!> mpi_send
19513! **************************************************************************************************
19514 SUBROUTINE mp_send_r (msg, dest, tag, comm)
19515 REAL(kind=real_4), INTENT(IN) :: msg
19516 INTEGER, INTENT(IN) :: dest, tag
19517 CLASS(mp_comm_type), INTENT(IN) :: comm
19518
19519 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_r'
19520
19521 INTEGER :: handle
19522#if defined(__parallel)
19523 INTEGER :: ierr, msglen
19524#endif
19525
19526 CALL mp_timeset(routinen, handle)
19527
19528#if defined(__parallel)
19529 msglen = 1
19530 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19531 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19532 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19533#else
19534 mark_used(msg)
19535 mark_used(dest)
19536 mark_used(tag)
19537 mark_used(comm)
19538 ! only defined in parallel
19539 cpabort("not in parallel mode")
19540#endif
19541 CALL mp_timestop(handle)
19542 END SUBROUTINE mp_send_r
19543
19544! **************************************************************************************************
19545!> \brief Send rank-1 data to another process
19546!> \param[in] msg Rank-1 data to send
19547!> \param dest ...
19548!> \param tag ...
19549!> \param comm ...
19550!> \note see mp_send_r
19551! **************************************************************************************************
19552 SUBROUTINE mp_send_rv(msg, dest, tag, comm)
19553 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
19554 INTEGER, INTENT(IN) :: dest, tag
19555 CLASS(mp_comm_type), INTENT(IN) :: comm
19556
19557 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_rv'
19558
19559 INTEGER :: handle
19560#if defined(__parallel)
19561 INTEGER :: ierr, msglen
19562#endif
19563
19564 CALL mp_timeset(routinen, handle)
19565
19566#if defined(__parallel)
19567 msglen = SIZE(msg)
19568 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19569 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19570 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19571#else
19572 mark_used(msg)
19573 mark_used(dest)
19574 mark_used(tag)
19575 mark_used(comm)
19576 ! only defined in parallel
19577 cpabort("not in parallel mode")
19578#endif
19579 CALL mp_timestop(handle)
19580 END SUBROUTINE mp_send_rv
19581
19582! **************************************************************************************************
19583!> \brief Send rank-2 data to another process
19584!> \param[in] msg Rank-2 data to send
19585!> \param dest ...
19586!> \param tag ...
19587!> \param comm ...
19588!> \note see mp_send_r
19589! **************************************************************************************************
19590 SUBROUTINE mp_send_rm2(msg, dest, tag, comm)
19591 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
19592 INTEGER, INTENT(IN) :: dest, tag
19593 CLASS(mp_comm_type), INTENT(IN) :: comm
19594
19595 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_rm2'
19596
19597 INTEGER :: handle
19598#if defined(__parallel)
19599 INTEGER :: ierr, msglen
19600#endif
19601
19602 CALL mp_timeset(routinen, handle)
19603
19604#if defined(__parallel)
19605 msglen = SIZE(msg)
19606 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19607 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19608 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19609#else
19610 mark_used(msg)
19611 mark_used(dest)
19612 mark_used(tag)
19613 mark_used(comm)
19614 ! only defined in parallel
19615 cpabort("not in parallel mode")
19616#endif
19617 CALL mp_timestop(handle)
19618 END SUBROUTINE mp_send_rm2
19619
19620! **************************************************************************************************
19621!> \brief Send rank-3 data to another process
19622!> \param[in] msg Rank-3 data to send
19623!> \param dest ...
19624!> \param tag ...
19625!> \param comm ...
19626!> \note see mp_send_r
19627! **************************************************************************************************
19628 SUBROUTINE mp_send_rm3(msg, dest, tag, comm)
19629 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
19630 INTEGER, INTENT(IN) :: dest, tag
19631 CLASS(mp_comm_type), INTENT(IN) :: comm
19632
19633 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
19634
19635 INTEGER :: handle
19636#if defined(__parallel)
19637 INTEGER :: ierr, msglen
19638#endif
19639
19640 CALL mp_timeset(routinen, handle)
19641
19642#if defined(__parallel)
19643 msglen = SIZE(msg)
19644 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19645 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19646 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19647#else
19648 mark_used(msg)
19649 mark_used(dest)
19650 mark_used(tag)
19651 mark_used(comm)
19652 ! only defined in parallel
19653 cpabort("not in parallel mode")
19654#endif
19655 CALL mp_timestop(handle)
19656 END SUBROUTINE mp_send_rm3
19657
19658! **************************************************************************************************
19659!> \brief Receive one datum from another process
19660!> \param[in,out] msg Place received data into this variable
19661!> \param[in,out] source Process to receive from
19662!> \param[in,out] tag Transfer identifier
19663!> \param[in] comm Message passing environment identifier
19664!> \par MPI mapping
19665!> mpi_send
19666! **************************************************************************************************
19667 SUBROUTINE mp_recv_r (msg, source, tag, comm)
19668 REAL(kind=real_4), INTENT(INOUT) :: msg
19669 INTEGER, INTENT(INOUT) :: source, tag
19670 CLASS(mp_comm_type), INTENT(IN) :: comm
19671
19672 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_r'
19673
19674 INTEGER :: handle
19675#if defined(__parallel)
19676 INTEGER :: ierr, msglen
19677 mpi_status_type :: status
19678#endif
19679
19680 CALL mp_timeset(routinen, handle)
19681
19682#if defined(__parallel)
19683 msglen = 1
19684 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19685 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19686 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19687 ELSE
19688 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19689 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19690 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19691 source = status mpi_status_extract(mpi_source)
19692 tag = status mpi_status_extract(mpi_tag)
19693 END IF
19694#else
19695 mark_used(msg)
19696 mark_used(source)
19697 mark_used(tag)
19698 mark_used(comm)
19699 ! only defined in parallel
19700 cpabort("not in parallel mode")
19701#endif
19702 CALL mp_timestop(handle)
19703 END SUBROUTINE mp_recv_r
19704
19705! **************************************************************************************************
19706!> \brief Receive rank-1 data from another process
19707!> \param[in,out] msg Place received data into this rank-1 array
19708!> \param source ...
19709!> \param tag ...
19710!> \param comm ...
19711!> \note see mp_recv_r
19712! **************************************************************************************************
19713 SUBROUTINE mp_recv_rv(msg, source, tag, comm)
19714 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19715 INTEGER, INTENT(INOUT) :: source, tag
19716 CLASS(mp_comm_type), INTENT(IN) :: comm
19717
19718 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rv'
19719
19720 INTEGER :: handle
19721#if defined(__parallel)
19722 INTEGER :: ierr, msglen
19723 mpi_status_type :: status
19724#endif
19725
19726 CALL mp_timeset(routinen, handle)
19727
19728#if defined(__parallel)
19729 msglen = SIZE(msg)
19730 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19731 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19732 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19733 ELSE
19734 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19735 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19736 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19737 source = status mpi_status_extract(mpi_source)
19738 tag = status mpi_status_extract(mpi_tag)
19739 END IF
19740#else
19741 mark_used(msg)
19742 mark_used(source)
19743 mark_used(tag)
19744 mark_used(comm)
19745 ! only defined in parallel
19746 cpabort("not in parallel mode")
19747#endif
19748 CALL mp_timestop(handle)
19749 END SUBROUTINE mp_recv_rv
19750
19751! **************************************************************************************************
19752!> \brief Receive rank-2 data from another process
19753!> \param[in,out] msg Place received data into this rank-2 array
19754!> \param source ...
19755!> \param tag ...
19756!> \param comm ...
19757!> \note see mp_recv_r
19758! **************************************************************************************************
19759 SUBROUTINE mp_recv_rm2(msg, source, tag, comm)
19760 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
19761 INTEGER, INTENT(INOUT) :: source, tag
19762 CLASS(mp_comm_type), INTENT(IN) :: comm
19763
19764 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rm2'
19765
19766 INTEGER :: handle
19767#if defined(__parallel)
19768 INTEGER :: ierr, msglen
19769 mpi_status_type :: status
19770#endif
19771
19772 CALL mp_timeset(routinen, handle)
19773
19774#if defined(__parallel)
19775 msglen = SIZE(msg)
19776 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19777 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19778 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19779 ELSE
19780 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19781 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19782 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19783 source = status mpi_status_extract(mpi_source)
19784 tag = status mpi_status_extract(mpi_tag)
19785 END IF
19786#else
19787 mark_used(msg)
19788 mark_used(source)
19789 mark_used(tag)
19790 mark_used(comm)
19791 ! only defined in parallel
19792 cpabort("not in parallel mode")
19793#endif
19794 CALL mp_timestop(handle)
19795 END SUBROUTINE mp_recv_rm2
19796
19797! **************************************************************************************************
19798!> \brief Receive rank-3 data from another process
19799!> \param[in,out] msg Place received data into this rank-3 array
19800!> \param source ...
19801!> \param tag ...
19802!> \param comm ...
19803!> \note see mp_recv_r
19804! **************************************************************************************************
19805 SUBROUTINE mp_recv_rm3(msg, source, tag, comm)
19806 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
19807 INTEGER, INTENT(INOUT) :: source, tag
19808 CLASS(mp_comm_type), INTENT(IN) :: comm
19809
19810 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rm3'
19811
19812 INTEGER :: handle
19813#if defined(__parallel)
19814 INTEGER :: ierr, msglen
19815 mpi_status_type :: status
19816#endif
19817
19818 CALL mp_timeset(routinen, handle)
19819
19820#if defined(__parallel)
19821 msglen = SIZE(msg)
19822 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19823 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19824 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19825 ELSE
19826 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19827 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19828 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19829 source = status mpi_status_extract(mpi_source)
19830 tag = status mpi_status_extract(mpi_tag)
19831 END IF
19832#else
19833 mark_used(msg)
19834 mark_used(source)
19835 mark_used(tag)
19836 mark_used(comm)
19837 ! only defined in parallel
19838 cpabort("not in parallel mode")
19839#endif
19840 CALL mp_timestop(handle)
19841 END SUBROUTINE mp_recv_rm3
19842
19843! **************************************************************************************************
19844!> \brief Broadcasts a datum to all processes.
19845!> \param[in] msg Datum to broadcast
19846!> \param[in] source Processes which broadcasts
19847!> \param[in] comm Message passing environment identifier
19848!> \par MPI mapping
19849!> mpi_bcast
19850! **************************************************************************************************
19851 SUBROUTINE mp_bcast_r (msg, source, comm)
19852 REAL(kind=real_4), INTENT(INOUT) :: msg
19853 INTEGER, INTENT(IN) :: source
19854 CLASS(mp_comm_type), INTENT(IN) :: comm
19855
19856 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r'
19857
19858 INTEGER :: handle
19859#if defined(__parallel)
19860 INTEGER :: ierr, msglen
19861#endif
19862
19863 CALL mp_timeset(routinen, handle)
19864
19865#if defined(__parallel)
19866 msglen = 1
19867 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
19868 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
19869 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
19870#else
19871 mark_used(msg)
19872 mark_used(source)
19873 mark_used(comm)
19874#endif
19875 CALL mp_timestop(handle)
19876 END SUBROUTINE mp_bcast_r
19877
19878! **************************************************************************************************
19879!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
19880!> \param[in] msg Datum to broadcast
19881!> \param[in] comm Message passing environment identifier
19882!> \par MPI mapping
19883!> mpi_bcast
19884! **************************************************************************************************
19885 SUBROUTINE mp_bcast_r_src(msg, comm)
19886 REAL(kind=real_4), INTENT(INOUT) :: msg
19887 CLASS(mp_comm_type), INTENT(IN) :: comm
19888
19889 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r_src'
19890
19891 INTEGER :: handle
19892#if defined(__parallel)
19893 INTEGER :: ierr, msglen
19894#endif
19895
19896 CALL mp_timeset(routinen, handle)
19897
19898#if defined(__parallel)
19899 msglen = 1
19900 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
19901 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
19902 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
19903#else
19904 mark_used(msg)
19905 mark_used(comm)
19906#endif
19907 CALL mp_timestop(handle)
19908 END SUBROUTINE mp_bcast_r_src
19909
19910! **************************************************************************************************
19911!> \brief Broadcasts a datum to all processes.
19912!> \param[in] msg Datum to broadcast
19913!> \param[in] source Processes which broadcasts
19914!> \param[in] comm Message passing environment identifier
19915!> \par MPI mapping
19916!> mpi_bcast
19917! **************************************************************************************************
19918 SUBROUTINE mp_ibcast_r (msg, source, comm, request)
19919 REAL(kind=real_4), INTENT(INOUT) :: msg
19920 INTEGER, INTENT(IN) :: source
19921 CLASS(mp_comm_type), INTENT(IN) :: comm
19922 TYPE(mp_request_type), INTENT(OUT) :: request
19923
19924 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_r'
19925
19926 INTEGER :: handle
19927#if defined(__parallel)
19928 INTEGER :: ierr, msglen
19929#endif
19930
19931 CALL mp_timeset(routinen, handle)
19932
19933#if defined(__parallel)
19934 msglen = 1
19935 CALL mpi_ibcast(msg, msglen, mpi_real, source, comm%handle, request%handle, ierr)
19936 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
19937 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_4_size)
19938#else
19939 mark_used(msg)
19940 mark_used(source)
19941 mark_used(comm)
19942 request = mp_request_null
19943#endif
19944 CALL mp_timestop(handle)
19945 END SUBROUTINE mp_ibcast_r
19946
19947! **************************************************************************************************
19948!> \brief Broadcasts rank-1 data to all processes
19949!> \param[in] msg Data to broadcast
19950!> \param source ...
19951!> \param comm ...
19952!> \note see mp_bcast_r1
19953! **************************************************************************************************
19954 SUBROUTINE mp_bcast_rv(msg, source, comm)
19955 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19956 INTEGER, INTENT(IN) :: source
19957 CLASS(mp_comm_type), INTENT(IN) :: comm
19958
19959 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rv'
19960
19961 INTEGER :: handle
19962#if defined(__parallel)
19963 INTEGER :: ierr, msglen
19964#endif
19965
19966 CALL mp_timeset(routinen, handle)
19967
19968#if defined(__parallel)
19969 msglen = SIZE(msg)
19970 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
19971 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
19972 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
19973#else
19974 mark_used(msg)
19975 mark_used(source)
19976 mark_used(comm)
19977#endif
19978 CALL mp_timestop(handle)
19979 END SUBROUTINE mp_bcast_rv
19980
19981! **************************************************************************************************
19982!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
19983!> \param[in] msg Data to broadcast
19984!> \param comm ...
19985!> \note see mp_bcast_r1
19986! **************************************************************************************************
19987 SUBROUTINE mp_bcast_rv_src(msg, comm)
19988 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19989 CLASS(mp_comm_type), INTENT(IN) :: comm
19990
19991 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rv_src'
19992
19993 INTEGER :: handle
19994#if defined(__parallel)
19995 INTEGER :: ierr, msglen
19996#endif
19997
19998 CALL mp_timeset(routinen, handle)
19999
20000#if defined(__parallel)
20001 msglen = SIZE(msg)
20002 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20003 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20004 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20005#else
20006 mark_used(msg)
20007 mark_used(comm)
20008#endif
20009 CALL mp_timestop(handle)
20010 END SUBROUTINE mp_bcast_rv_src
20011
20012! **************************************************************************************************
20013!> \brief Broadcasts rank-1 data to all processes
20014!> \param[in] msg Data to broadcast
20015!> \param source ...
20016!> \param comm ...
20017!> \note see mp_bcast_r1
20018! **************************************************************************************************
20019 SUBROUTINE mp_ibcast_rv(msg, source, comm, request)
20020 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20021 INTEGER, INTENT(IN) :: source
20022 CLASS(mp_comm_type), INTENT(IN) :: comm
20023 TYPE(mp_request_type) :: request
20024
20025 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_rv'
20026
20027 INTEGER :: handle
20028#if defined(__parallel)
20029 INTEGER :: ierr, msglen
20030#endif
20031
20032 CALL mp_timeset(routinen, handle)
20033
20034#if defined(__parallel)
20035#if !defined(__GNUC__) || __GNUC__ >= 9
20036 cpassert(is_contiguous(msg))
20037#endif
20038 msglen = SIZE(msg)
20039 CALL mpi_ibcast(msg, msglen, mpi_real, source, comm%handle, request%handle, ierr)
20040 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
20041 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_4_size)
20042#else
20043 mark_used(msg)
20044 mark_used(source)
20045 mark_used(comm)
20046 request = mp_request_null
20047#endif
20048 CALL mp_timestop(handle)
20049 END SUBROUTINE mp_ibcast_rv
20050
20051! **************************************************************************************************
20052!> \brief Broadcasts rank-2 data to all processes
20053!> \param[in] msg Data to broadcast
20054!> \param source ...
20055!> \param comm ...
20056!> \note see mp_bcast_r1
20057! **************************************************************************************************
20058 SUBROUTINE mp_bcast_rm(msg, source, comm)
20059 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20060 INTEGER, INTENT(IN) :: source
20061 CLASS(mp_comm_type), INTENT(IN) :: comm
20062
20063 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rm'
20064
20065 INTEGER :: handle
20066#if defined(__parallel)
20067 INTEGER :: ierr, msglen
20068#endif
20069
20070 CALL mp_timeset(routinen, handle)
20071
20072#if defined(__parallel)
20073 msglen = SIZE(msg)
20074 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20075 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20076 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20077#else
20078 mark_used(msg)
20079 mark_used(source)
20080 mark_used(comm)
20081#endif
20082 CALL mp_timestop(handle)
20083 END SUBROUTINE mp_bcast_rm
20084
20085! **************************************************************************************************
20086!> \brief Broadcasts rank-2 data to all processes
20087!> \param[in] msg Data to broadcast
20088!> \param source ...
20089!> \param comm ...
20090!> \note see mp_bcast_r1
20091! **************************************************************************************************
20092 SUBROUTINE mp_bcast_rm_src(msg, comm)
20093 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20094 CLASS(mp_comm_type), INTENT(IN) :: comm
20095
20096 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rm_src'
20097
20098 INTEGER :: handle
20099#if defined(__parallel)
20100 INTEGER :: ierr, msglen
20101#endif
20102
20103 CALL mp_timeset(routinen, handle)
20104
20105#if defined(__parallel)
20106 msglen = SIZE(msg)
20107 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20108 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20109 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20110#else
20111 mark_used(msg)
20112 mark_used(comm)
20113#endif
20114 CALL mp_timestop(handle)
20115 END SUBROUTINE mp_bcast_rm_src
20116
20117! **************************************************************************************************
20118!> \brief Broadcasts rank-3 data to all processes
20119!> \param[in] msg Data to broadcast
20120!> \param source ...
20121!> \param comm ...
20122!> \note see mp_bcast_r1
20123! **************************************************************************************************
20124 SUBROUTINE mp_bcast_r3(msg, source, comm)
20125 REAL(kind=real_4), CONTIGUOUS :: msg(:, :, :)
20126 INTEGER, INTENT(IN) :: source
20127 CLASS(mp_comm_type), INTENT(IN) :: comm
20128
20129 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r3'
20130
20131 INTEGER :: handle
20132#if defined(__parallel)
20133 INTEGER :: ierr, msglen
20134#endif
20135
20136 CALL mp_timeset(routinen, handle)
20137
20138#if defined(__parallel)
20139 msglen = SIZE(msg)
20140 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20141 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20142 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20143#else
20144 mark_used(msg)
20145 mark_used(source)
20146 mark_used(comm)
20147#endif
20148 CALL mp_timestop(handle)
20149 END SUBROUTINE mp_bcast_r3
20150
20151! **************************************************************************************************
20152!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
20153!> \param[in] msg Data to broadcast
20154!> \param source ...
20155!> \param comm ...
20156!> \note see mp_bcast_r1
20157! **************************************************************************************************
20158 SUBROUTINE mp_bcast_r3_src(msg, comm)
20159 REAL(kind=real_4), CONTIGUOUS :: msg(:, :, :)
20160 CLASS(mp_comm_type), INTENT(IN) :: comm
20161
20162 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r3_src'
20163
20164 INTEGER :: handle
20165#if defined(__parallel)
20166 INTEGER :: ierr, msglen
20167#endif
20168
20169 CALL mp_timeset(routinen, handle)
20170
20171#if defined(__parallel)
20172 msglen = SIZE(msg)
20173 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20174 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20175 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20176#else
20177 mark_used(msg)
20178 mark_used(comm)
20179#endif
20180 CALL mp_timestop(handle)
20181 END SUBROUTINE mp_bcast_r3_src
20182
20183! **************************************************************************************************
20184!> \brief Sums a datum from all processes with result left on all processes.
20185!> \param[in,out] msg Datum to sum (input) and result (output)
20186!> \param[in] comm Message passing environment identifier
20187!> \par MPI mapping
20188!> mpi_allreduce
20189! **************************************************************************************************
20190 SUBROUTINE mp_sum_r (msg, comm)
20191 REAL(kind=real_4), INTENT(INOUT) :: msg
20192 CLASS(mp_comm_type), INTENT(IN) :: comm
20193
20194 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_r'
20195
20196 INTEGER :: handle
20197#if defined(__parallel)
20198 INTEGER :: ierr, msglen
20199#endif
20200
20201 CALL mp_timeset(routinen, handle)
20202
20203#if defined(__parallel)
20204 msglen = 1
20205 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20206 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20207 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20208#else
20209 mark_used(msg)
20210 mark_used(comm)
20211#endif
20212 CALL mp_timestop(handle)
20213 END SUBROUTINE mp_sum_r
20214
20215! **************************************************************************************************
20216!> \brief Element-wise sum of a rank-1 array on all processes.
20217!> \param[in,out] msg Vector to sum and result
20218!> \param comm ...
20219!> \note see mp_sum_r
20220! **************************************************************************************************
20221 SUBROUTINE mp_sum_rv(msg, comm)
20222 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20223 CLASS(mp_comm_type), INTENT(IN) :: comm
20224
20225 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rv'
20226
20227 INTEGER :: handle
20228#if defined(__parallel)
20229 INTEGER :: ierr, msglen
20230#endif
20231
20232 CALL mp_timeset(routinen, handle)
20233
20234#if defined(__parallel)
20235 msglen = SIZE(msg)
20236 IF (msglen > 0) THEN
20237 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20238 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20239 END IF
20240 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20241#else
20242 mark_used(msg)
20243 mark_used(comm)
20244#endif
20245 CALL mp_timestop(handle)
20246 END SUBROUTINE mp_sum_rv
20247
20248! **************************************************************************************************
20249!> \brief Element-wise sum of a rank-1 array on all processes.
20250!> \param[in,out] msg Vector to sum and result
20251!> \param comm ...
20252!> \note see mp_sum_r
20253! **************************************************************************************************
20254 SUBROUTINE mp_isum_rv(msg, comm, request)
20255 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20256 CLASS(mp_comm_type), INTENT(IN) :: comm
20257 TYPE(mp_request_type), INTENT(OUT) :: request
20258
20259 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_rv'
20260
20261 INTEGER :: handle
20262#if defined(__parallel)
20263 INTEGER :: ierr, msglen
20264#endif
20265
20266 CALL mp_timeset(routinen, handle)
20267
20268#if defined(__parallel)
20269#if !defined(__GNUC__) || __GNUC__ >= 9
20270 cpassert(is_contiguous(msg))
20271#endif
20272 msglen = SIZE(msg)
20273 IF (msglen > 0) THEN
20274 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, request%handle, ierr)
20275 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
20276 ELSE
20277 request = mp_request_null
20278 END IF
20279 CALL add_perf(perf_id=23, count=1, msg_size=msglen*real_4_size)
20280#else
20281 mark_used(msg)
20282 mark_used(comm)
20283 request = mp_request_null
20284#endif
20285 CALL mp_timestop(handle)
20286 END SUBROUTINE mp_isum_rv
20287
20288! **************************************************************************************************
20289!> \brief Element-wise sum of a rank-2 array on all processes.
20290!> \param[in] msg Matrix to sum and result
20291!> \param comm ...
20292!> \note see mp_sum_r
20293! **************************************************************************************************
20294 SUBROUTINE mp_sum_rm(msg, comm)
20295 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20296 CLASS(mp_comm_type), INTENT(IN) :: comm
20297
20298 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm'
20299
20300 INTEGER :: handle
20301#if defined(__parallel)
20302 INTEGER, PARAMETER :: max_msg = 2**25
20303 INTEGER :: ierr, m1, msglen, step, msglensum
20304#endif
20305
20306 CALL mp_timeset(routinen, handle)
20307
20308#if defined(__parallel)
20309 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
20310 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
20311 msglensum = 0
20312 DO m1 = lbound(msg, 2), ubound(msg, 2), step
20313 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
20314 msglensum = msglensum + msglen
20315 IF (msglen > 0) THEN
20316 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_real, mpi_sum, comm%handle, ierr)
20317 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20318 END IF
20319 END DO
20320 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_4_size)
20321#else
20322 mark_used(msg)
20323 mark_used(comm)
20324#endif
20325 CALL mp_timestop(handle)
20326 END SUBROUTINE mp_sum_rm
20327
20328! **************************************************************************************************
20329!> \brief Element-wise sum of a rank-3 array on all processes.
20330!> \param[in] msg Array to sum and result
20331!> \param comm ...
20332!> \note see mp_sum_r
20333! **************************************************************************************************
20334 SUBROUTINE mp_sum_rm3(msg, comm)
20335 REAL(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
20336 CLASS(mp_comm_type), INTENT(IN) :: comm
20337
20338 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm3'
20339
20340 INTEGER :: handle
20341#if defined(__parallel)
20342 INTEGER :: ierr, msglen
20343#endif
20344
20345 CALL mp_timeset(routinen, handle)
20346
20347#if defined(__parallel)
20348 msglen = SIZE(msg)
20349 IF (msglen > 0) THEN
20350 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20351 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20352 END IF
20353 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20354#else
20355 mark_used(msg)
20356 mark_used(comm)
20357#endif
20358 CALL mp_timestop(handle)
20359 END SUBROUTINE mp_sum_rm3
20360
20361! **************************************************************************************************
20362!> \brief Element-wise sum of a rank-4 array on all processes.
20363!> \param[in] msg Array to sum and result
20364!> \param comm ...
20365!> \note see mp_sum_r
20366! **************************************************************************************************
20367 SUBROUTINE mp_sum_rm4(msg, comm)
20368 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
20369 CLASS(mp_comm_type), INTENT(IN) :: comm
20370
20371 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm4'
20372
20373 INTEGER :: handle
20374#if defined(__parallel)
20375 INTEGER :: ierr, msglen
20376#endif
20377
20378 CALL mp_timeset(routinen, handle)
20379
20380#if defined(__parallel)
20381 msglen = SIZE(msg)
20382 IF (msglen > 0) THEN
20383 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20384 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20385 END IF
20386 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20387#else
20388 mark_used(msg)
20389 mark_used(comm)
20390#endif
20391 CALL mp_timestop(handle)
20392 END SUBROUTINE mp_sum_rm4
20393
20394! **************************************************************************************************
20395!> \brief Element-wise sum of data from all processes with result left only on
20396!> one.
20397!> \param[in,out] msg Vector to sum (input) and (only on process root)
20398!> result (output)
20399!> \param root ...
20400!> \param[in] comm Message passing environment identifier
20401!> \par MPI mapping
20402!> mpi_reduce
20403! **************************************************************************************************
20404 SUBROUTINE mp_sum_root_rv(msg, root, comm)
20405 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20406 INTEGER, INTENT(IN) :: root
20407 CLASS(mp_comm_type), INTENT(IN) :: comm
20408
20409 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rv'
20410
20411 INTEGER :: handle
20412#if defined(__parallel)
20413 INTEGER :: ierr, m1, msglen, taskid
20414 REAL(kind=real_4), ALLOCATABLE :: res(:)
20415#endif
20416
20417 CALL mp_timeset(routinen, handle)
20418
20419#if defined(__parallel)
20420 msglen = SIZE(msg)
20421 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20422 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20423 IF (msglen > 0) THEN
20424 m1 = SIZE(msg, 1)
20425 ALLOCATE (res(m1))
20426 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_sum, &
20427 root, comm%handle, ierr)
20428 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20429 IF (taskid == root) THEN
20430 msg = res
20431 END IF
20432 DEALLOCATE (res)
20433 END IF
20434 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20435#else
20436 mark_used(msg)
20437 mark_used(root)
20438 mark_used(comm)
20439#endif
20440 CALL mp_timestop(handle)
20441 END SUBROUTINE mp_sum_root_rv
20442
20443! **************************************************************************************************
20444!> \brief Element-wise sum of data from all processes with result left only on
20445!> one.
20446!> \param[in,out] msg Matrix to sum (input) and (only on process root)
20447!> result (output)
20448!> \param root ...
20449!> \param comm ...
20450!> \note see mp_sum_root_rv
20451! **************************************************************************************************
20452 SUBROUTINE mp_sum_root_rm(msg, root, comm)
20453 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20454 INTEGER, INTENT(IN) :: root
20455 CLASS(mp_comm_type), INTENT(IN) :: comm
20456
20457 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
20458
20459 INTEGER :: handle
20460#if defined(__parallel)
20461 INTEGER :: ierr, m1, m2, msglen, taskid
20462 REAL(kind=real_4), ALLOCATABLE :: res(:, :)
20463#endif
20464
20465 CALL mp_timeset(routinen, handle)
20466
20467#if defined(__parallel)
20468 msglen = SIZE(msg)
20469 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20470 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20471 IF (msglen > 0) THEN
20472 m1 = SIZE(msg, 1)
20473 m2 = SIZE(msg, 2)
20474 ALLOCATE (res(m1, m2))
20475 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_sum, root, comm%handle, ierr)
20476 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20477 IF (taskid == root) THEN
20478 msg = res
20479 END IF
20480 DEALLOCATE (res)
20481 END IF
20482 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20483#else
20484 mark_used(root)
20485 mark_used(msg)
20486 mark_used(comm)
20487#endif
20488 CALL mp_timestop(handle)
20489 END SUBROUTINE mp_sum_root_rm
20490
20491! **************************************************************************************************
20492!> \brief Partial sum of data from all processes with result on each process.
20493!> \param[in] msg Matrix to sum (input)
20494!> \param[out] res Matrix containing result (output)
20495!> \param[in] comm Message passing environment identifier
20496! **************************************************************************************************
20497 SUBROUTINE mp_sum_partial_rm(msg, res, comm)
20498 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
20499 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
20500 CLASS(mp_comm_type), INTENT(IN) :: comm
20501
20502 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_rm'
20503
20504 INTEGER :: handle
20505#if defined(__parallel)
20506 INTEGER :: ierr, msglen, taskid
20507#endif
20508
20509 CALL mp_timeset(routinen, handle)
20510
20511#if defined(__parallel)
20512 msglen = SIZE(msg)
20513 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20514 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20515 IF (msglen > 0) THEN
20516 CALL mpi_scan(msg, res, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20517 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
20518 END IF
20519 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20520 ! perf_id is same as for other summation routines
20521#else
20522 res = msg
20523 mark_used(comm)
20524#endif
20525 CALL mp_timestop(handle)
20526 END SUBROUTINE mp_sum_partial_rm
20527
20528! **************************************************************************************************
20529!> \brief Finds the maximum of a datum with the result left on all processes.
20530!> \param[in,out] msg Find maximum among these data (input) and
20531!> maximum (output)
20532!> \param[in] comm Message passing environment identifier
20533!> \par MPI mapping
20534!> mpi_allreduce
20535! **************************************************************************************************
20536 SUBROUTINE mp_max_r (msg, comm)
20537 REAL(kind=real_4), INTENT(INOUT) :: msg
20538 CLASS(mp_comm_type), INTENT(IN) :: comm
20539
20540 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_r'
20541
20542 INTEGER :: handle
20543#if defined(__parallel)
20544 INTEGER :: ierr, msglen
20545#endif
20546
20547 CALL mp_timeset(routinen, handle)
20548
20549#if defined(__parallel)
20550 msglen = 1
20551 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_max, comm%handle, ierr)
20552 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20553 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20554#else
20555 mark_used(msg)
20556 mark_used(comm)
20557#endif
20558 CALL mp_timestop(handle)
20559 END SUBROUTINE mp_max_r
20560
20561! **************************************************************************************************
20562!> \brief Finds the maximum of a datum with the result left on all processes.
20563!> \param[in,out] msg Find maximum among these data (input) and
20564!> maximum (output)
20565!> \param[in] comm Message passing environment identifier
20566!> \par MPI mapping
20567!> mpi_allreduce
20568! **************************************************************************************************
20569 SUBROUTINE mp_max_root_r (msg, root, comm)
20570 REAL(kind=real_4), INTENT(INOUT) :: msg
20571 INTEGER, INTENT(IN) :: root
20572 CLASS(mp_comm_type), INTENT(IN) :: comm
20573
20574 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_r'
20575
20576 INTEGER :: handle
20577#if defined(__parallel)
20578 INTEGER :: ierr, msglen
20579 REAL(kind=real_4) :: res
20580#endif
20581
20582 CALL mp_timeset(routinen, handle)
20583
20584#if defined(__parallel)
20585 msglen = 1
20586 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_max, root, comm%handle, ierr)
20587 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20588 IF (root == comm%mepos) msg = res
20589 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20590#else
20591 mark_used(msg)
20592 mark_used(comm)
20593 mark_used(root)
20594#endif
20595 CALL mp_timestop(handle)
20596 END SUBROUTINE mp_max_root_r
20597
20598! **************************************************************************************************
20599!> \brief Finds the element-wise maximum of a vector with the result left on
20600!> all processes.
20601!> \param[in,out] msg Find maximum among these data (input) and
20602!> maximum (output)
20603!> \param comm ...
20604!> \note see mp_max_r
20605! **************************************************************************************************
20606 SUBROUTINE mp_max_rv(msg, comm)
20607 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20608 CLASS(mp_comm_type), INTENT(IN) :: comm
20609
20610 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_rv'
20611
20612 INTEGER :: handle
20613#if defined(__parallel)
20614 INTEGER :: ierr, msglen
20615#endif
20616
20617 CALL mp_timeset(routinen, handle)
20618
20619#if defined(__parallel)
20620 msglen = SIZE(msg)
20621 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_max, comm%handle, ierr)
20622 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20623 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20624#else
20625 mark_used(msg)
20626 mark_used(comm)
20627#endif
20628 CALL mp_timestop(handle)
20629 END SUBROUTINE mp_max_rv
20630
20631! **************************************************************************************************
20632!> \brief Finds the element-wise maximum of a vector with the result left on
20633!> all processes.
20634!> \param[in,out] msg Find maximum among these data (input) and
20635!> maximum (output)
20636!> \param comm ...
20637!> \note see mp_max_r
20638! **************************************************************************************************
20639 SUBROUTINE mp_max_root_rm(msg, root, comm)
20640 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20641 INTEGER :: root
20642 CLASS(mp_comm_type), INTENT(IN) :: comm
20643
20644 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_rm'
20645
20646 INTEGER :: handle
20647#if defined(__parallel)
20648 INTEGER :: ierr, msglen
20649 REAL(kind=real_4) :: res(SIZE(msg, 1), SIZE(msg, 2))
20650#endif
20651
20652 CALL mp_timeset(routinen, handle)
20653
20654#if defined(__parallel)
20655 msglen = SIZE(msg)
20656 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_max, root, comm%handle, ierr)
20657 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20658 IF (root == comm%mepos) msg = res
20659 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20660#else
20661 mark_used(msg)
20662 mark_used(comm)
20663 mark_used(root)
20664#endif
20665 CALL mp_timestop(handle)
20666 END SUBROUTINE mp_max_root_rm
20667
20668! **************************************************************************************************
20669!> \brief Finds the minimum of a datum with the result left on all processes.
20670!> \param[in,out] msg Find minimum among these data (input) and
20671!> maximum (output)
20672!> \param[in] comm Message passing environment identifier
20673!> \par MPI mapping
20674!> mpi_allreduce
20675! **************************************************************************************************
20676 SUBROUTINE mp_min_r (msg, comm)
20677 REAL(kind=real_4), INTENT(INOUT) :: msg
20678 CLASS(mp_comm_type), INTENT(IN) :: comm
20679
20680 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_r'
20681
20682 INTEGER :: handle
20683#if defined(__parallel)
20684 INTEGER :: ierr, msglen
20685#endif
20686
20687 CALL mp_timeset(routinen, handle)
20688
20689#if defined(__parallel)
20690 msglen = 1
20691 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_min, comm%handle, ierr)
20692 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20693 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20694#else
20695 mark_used(msg)
20696 mark_used(comm)
20697#endif
20698 CALL mp_timestop(handle)
20699 END SUBROUTINE mp_min_r
20700
20701! **************************************************************************************************
20702!> \brief Finds the element-wise minimum of vector with the result left on
20703!> all processes.
20704!> \param[in,out] msg Find minimum among these data (input) and
20705!> maximum (output)
20706!> \param comm ...
20707!> \par MPI mapping
20708!> mpi_allreduce
20709!> \note see mp_min_r
20710! **************************************************************************************************
20711 SUBROUTINE mp_min_rv(msg, comm)
20712 REAL(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
20713 CLASS(mp_comm_type), INTENT(IN) :: comm
20714
20715 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_rv'
20716
20717 INTEGER :: handle
20718#if defined(__parallel)
20719 INTEGER :: ierr, msglen
20720#endif
20721
20722 CALL mp_timeset(routinen, handle)
20723
20724#if defined(__parallel)
20725 msglen = SIZE(msg)
20726 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_min, comm%handle, ierr)
20727 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20728 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20729#else
20730 mark_used(msg)
20731 mark_used(comm)
20732#endif
20733 CALL mp_timestop(handle)
20734 END SUBROUTINE mp_min_rv
20735
20736! **************************************************************************************************
20737!> \brief Multiplies a set of numbers scattered across a number of processes,
20738!> then replicates the result.
20739!> \param[in,out] msg a number to multiply (input) and result (output)
20740!> \param[in] comm message passing environment identifier
20741!> \par MPI mapping
20742!> mpi_allreduce
20743! **************************************************************************************************
20744 SUBROUTINE mp_prod_r (msg, comm)
20745 REAL(kind=real_4), INTENT(INOUT) :: msg
20746 CLASS(mp_comm_type), INTENT(IN) :: comm
20747
20748 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_r'
20749
20750 INTEGER :: handle
20751#if defined(__parallel)
20752 INTEGER :: ierr, msglen
20753#endif
20754
20755 CALL mp_timeset(routinen, handle)
20756
20757#if defined(__parallel)
20758 msglen = 1
20759 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_prod, comm%handle, ierr)
20760 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20761 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20762#else
20763 mark_used(msg)
20764 mark_used(comm)
20765#endif
20766 CALL mp_timestop(handle)
20767 END SUBROUTINE mp_prod_r
20768
20769! **************************************************************************************************
20770!> \brief Scatters data from one processes to all others
20771!> \param[in] msg_scatter Data to scatter (for root process)
20772!> \param[out] msg Received data
20773!> \param[in] root Process which scatters data
20774!> \param[in] comm Message passing environment identifier
20775!> \par MPI mapping
20776!> mpi_scatter
20777! **************************************************************************************************
20778 SUBROUTINE mp_scatter_rv(msg_scatter, msg, root, comm)
20779 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
20780 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
20781 INTEGER, INTENT(IN) :: root
20782 CLASS(mp_comm_type), INTENT(IN) :: comm
20783
20784 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_rv'
20785
20786 INTEGER :: handle
20787#if defined(__parallel)
20788 INTEGER :: ierr, msglen
20789#endif
20790
20791 CALL mp_timeset(routinen, handle)
20792
20793#if defined(__parallel)
20794 msglen = SIZE(msg)
20795 CALL mpi_scatter(msg_scatter, msglen, mpi_real, msg, &
20796 msglen, mpi_real, root, comm%handle, ierr)
20797 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
20798 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
20799#else
20800 mark_used(root)
20801 mark_used(comm)
20802 msg = msg_scatter
20803#endif
20804 CALL mp_timestop(handle)
20805 END SUBROUTINE mp_scatter_rv
20806
20807! **************************************************************************************************
20808!> \brief Scatters data from one processes to all others
20809!> \param[in] msg_scatter Data to scatter (for root process)
20810!> \param[in] root Process which scatters data
20811!> \param[in] comm Message passing environment identifier
20812!> \par MPI mapping
20813!> mpi_scatter
20814! **************************************************************************************************
20815 SUBROUTINE mp_iscatter_r (msg_scatter, msg, root, comm, request)
20816 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:)
20817 REAL(kind=real_4), INTENT(INOUT) :: msg
20818 INTEGER, INTENT(IN) :: root
20819 CLASS(mp_comm_type), INTENT(IN) :: comm
20820 TYPE(mp_request_type), INTENT(OUT) :: request
20821
20822 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_r'
20823
20824 INTEGER :: handle
20825#if defined(__parallel)
20826 INTEGER :: ierr, msglen
20827#endif
20828
20829 CALL mp_timeset(routinen, handle)
20830
20831#if defined(__parallel)
20832#if !defined(__GNUC__) || __GNUC__ >= 9
20833 cpassert(is_contiguous(msg_scatter))
20834#endif
20835 msglen = 1
20836 CALL mpi_iscatter(msg_scatter, msglen, mpi_real, msg, &
20837 msglen, mpi_real, root, comm%handle, request%handle, ierr)
20838 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
20839 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
20840#else
20841 mark_used(root)
20842 mark_used(comm)
20843 msg = msg_scatter(1)
20844 request = mp_request_null
20845#endif
20846 CALL mp_timestop(handle)
20847 END SUBROUTINE mp_iscatter_r
20848
20849! **************************************************************************************************
20850!> \brief Scatters data from one processes to all others
20851!> \param[in] msg_scatter Data to scatter (for root process)
20852!> \param[in] root Process which scatters data
20853!> \param[in] comm Message passing environment identifier
20854!> \par MPI mapping
20855!> mpi_scatter
20856! **************************************************************************************************
20857 SUBROUTINE mp_iscatter_rv2(msg_scatter, msg, root, comm, request)
20858 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:, :)
20859 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20860 INTEGER, INTENT(IN) :: root
20861 CLASS(mp_comm_type), INTENT(IN) :: comm
20862 TYPE(mp_request_type), INTENT(OUT) :: request
20863
20864 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_rv2'
20865
20866 INTEGER :: handle
20867#if defined(__parallel)
20868 INTEGER :: ierr, msglen
20869#endif
20870
20871 CALL mp_timeset(routinen, handle)
20872
20873#if defined(__parallel)
20874#if !defined(__GNUC__) || __GNUC__ >= 9
20875 cpassert(is_contiguous(msg_scatter))
20876#endif
20877 msglen = SIZE(msg)
20878 CALL mpi_iscatter(msg_scatter, msglen, mpi_real, msg, &
20879 msglen, mpi_real, root, comm%handle, request%handle, ierr)
20880 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
20881 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
20882#else
20883 mark_used(root)
20884 mark_used(comm)
20885 msg(:) = msg_scatter(:, 1)
20886 request = mp_request_null
20887#endif
20888 CALL mp_timestop(handle)
20889 END SUBROUTINE mp_iscatter_rv2
20890
20891! **************************************************************************************************
20892!> \brief Scatters data from one processes to all others
20893!> \param[in] msg_scatter Data to scatter (for root process)
20894!> \param[in] root Process which scatters data
20895!> \param[in] comm Message passing environment identifier
20896!> \par MPI mapping
20897!> mpi_scatter
20898! **************************************************************************************************
20899 SUBROUTINE mp_iscatterv_rv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
20900 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:)
20901 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
20902 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20903 INTEGER, INTENT(IN) :: recvcount, root
20904 CLASS(mp_comm_type), INTENT(IN) :: comm
20905 TYPE(mp_request_type), INTENT(OUT) :: request
20906
20907 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_rv'
20908
20909 INTEGER :: handle
20910#if defined(__parallel)
20911 INTEGER :: ierr
20912#endif
20913
20914 CALL mp_timeset(routinen, handle)
20915
20916#if defined(__parallel)
20917#if !defined(__GNUC__) || __GNUC__ >= 9
20918 cpassert(is_contiguous(msg_scatter))
20919 cpassert(is_contiguous(msg))
20920 cpassert(is_contiguous(sendcounts))
20921 cpassert(is_contiguous(displs))
20922#endif
20923 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_real, msg, &
20924 recvcount, mpi_real, root, comm%handle, request%handle, ierr)
20925 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
20926 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
20927#else
20928 mark_used(sendcounts)
20929 mark_used(displs)
20930 mark_used(recvcount)
20931 mark_used(root)
20932 mark_used(comm)
20933 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
20934 request = mp_request_null
20935#endif
20936 CALL mp_timestop(handle)
20937 END SUBROUTINE mp_iscatterv_rv
20938
20939! **************************************************************************************************
20940!> \brief Gathers a datum from all processes to one
20941!> \param[in] msg Datum to send to root
20942!> \param[out] msg_gather Received data (on root)
20943!> \param[in] root Process which gathers the data
20944!> \param[in] comm Message passing environment identifier
20945!> \par MPI mapping
20946!> mpi_gather
20947! **************************************************************************************************
20948 SUBROUTINE mp_gather_r (msg, msg_gather, root, comm)
20949 REAL(kind=real_4), INTENT(IN) :: msg
20950 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
20951 INTEGER, INTENT(IN) :: root
20952 CLASS(mp_comm_type), INTENT(IN) :: comm
20953
20954 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_r'
20955
20956 INTEGER :: handle
20957#if defined(__parallel)
20958 INTEGER :: ierr, msglen
20959#endif
20960
20961 CALL mp_timeset(routinen, handle)
20962
20963#if defined(__parallel)
20964 msglen = 1
20965 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
20966 msglen, mpi_real, root, comm%handle, ierr)
20967 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
20968 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
20969#else
20970 mark_used(root)
20971 mark_used(comm)
20972 msg_gather(1) = msg
20973#endif
20974 CALL mp_timestop(handle)
20975 END SUBROUTINE mp_gather_r
20976
20977! **************************************************************************************************
20978!> \brief Gathers a datum from all processes to one, uses the source process of comm
20979!> \param[in] msg Datum to send to root
20980!> \param[out] msg_gather Received data (on root)
20981!> \param[in] comm Message passing environment identifier
20982!> \par MPI mapping
20983!> mpi_gather
20984! **************************************************************************************************
20985 SUBROUTINE mp_gather_r_src(msg, msg_gather, comm)
20986 REAL(kind=real_4), INTENT(IN) :: msg
20987 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
20988 CLASS(mp_comm_type), INTENT(IN) :: comm
20989
20990 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_r_src'
20991
20992 INTEGER :: handle
20993#if defined(__parallel)
20994 INTEGER :: ierr, msglen
20995#endif
20996
20997 CALL mp_timeset(routinen, handle)
20998
20999#if defined(__parallel)
21000 msglen = 1
21001 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21002 msglen, mpi_real, comm%source, comm%handle, ierr)
21003 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21004 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21005#else
21006 mark_used(comm)
21007 msg_gather(1) = msg
21008#endif
21009 CALL mp_timestop(handle)
21010 END SUBROUTINE mp_gather_r_src
21011
21012! **************************************************************************************************
21013!> \brief Gathers data from all processes to one
21014!> \param[in] msg Datum to send to root
21015!> \param msg_gather ...
21016!> \param root ...
21017!> \param comm ...
21018!> \par Data length
21019!> All data (msg) is equal-sized
21020!> \par MPI mapping
21021!> mpi_gather
21022!> \note see mp_gather_r
21023! **************************************************************************************************
21024 SUBROUTINE mp_gather_rv(msg, msg_gather, root, comm)
21025 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
21026 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21027 INTEGER, INTENT(IN) :: root
21028 CLASS(mp_comm_type), INTENT(IN) :: comm
21029
21030 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rv'
21031
21032 INTEGER :: handle
21033#if defined(__parallel)
21034 INTEGER :: ierr, msglen
21035#endif
21036
21037 CALL mp_timeset(routinen, handle)
21038
21039#if defined(__parallel)
21040 msglen = SIZE(msg)
21041 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21042 msglen, mpi_real, root, comm%handle, ierr)
21043 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21044 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21045#else
21046 mark_used(root)
21047 mark_used(comm)
21048 msg_gather = msg
21049#endif
21050 CALL mp_timestop(handle)
21051 END SUBROUTINE mp_gather_rv
21052
21053! **************************************************************************************************
21054!> \brief Gathers data from all processes to one. Gathers from comm%source
21055!> \param[in] msg Datum to send to root
21056!> \param msg_gather ...
21057!> \param comm ...
21058!> \par Data length
21059!> All data (msg) is equal-sized
21060!> \par MPI mapping
21061!> mpi_gather
21062!> \note see mp_gather_r
21063! **************************************************************************************************
21064 SUBROUTINE mp_gather_rv_src(msg, msg_gather, comm)
21065 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
21066 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21067 CLASS(mp_comm_type), INTENT(IN) :: comm
21068
21069 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rv_src'
21070
21071 INTEGER :: handle
21072#if defined(__parallel)
21073 INTEGER :: ierr, msglen
21074#endif
21075
21076 CALL mp_timeset(routinen, handle)
21077
21078#if defined(__parallel)
21079 msglen = SIZE(msg)
21080 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21081 msglen, mpi_real, comm%source, comm%handle, ierr)
21082 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21083 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21084#else
21085 mark_used(comm)
21086 msg_gather = msg
21087#endif
21088 CALL mp_timestop(handle)
21089 END SUBROUTINE mp_gather_rv_src
21090
21091! **************************************************************************************************
21092!> \brief Gathers data from all processes to one
21093!> \param[in] msg Datum to send to root
21094!> \param msg_gather ...
21095!> \param root ...
21096!> \param comm ...
21097!> \par Data length
21098!> All data (msg) is equal-sized
21099!> \par MPI mapping
21100!> mpi_gather
21101!> \note see mp_gather_r
21102! **************************************************************************************************
21103 SUBROUTINE mp_gather_rm(msg, msg_gather, root, comm)
21104 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
21105 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
21106 INTEGER, INTENT(IN) :: root
21107 CLASS(mp_comm_type), INTENT(IN) :: comm
21108
21109 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rm'
21110
21111 INTEGER :: handle
21112#if defined(__parallel)
21113 INTEGER :: ierr, msglen
21114#endif
21115
21116 CALL mp_timeset(routinen, handle)
21117
21118#if defined(__parallel)
21119 msglen = SIZE(msg)
21120 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21121 msglen, mpi_real, root, comm%handle, ierr)
21122 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21123 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21124#else
21125 mark_used(root)
21126 mark_used(comm)
21127 msg_gather = msg
21128#endif
21129 CALL mp_timestop(handle)
21130 END SUBROUTINE mp_gather_rm
21131
21132! **************************************************************************************************
21133!> \brief Gathers data from all processes to one. Gathers from comm%source
21134!> \param[in] msg Datum to send to root
21135!> \param msg_gather ...
21136!> \param comm ...
21137!> \par Data length
21138!> All data (msg) is equal-sized
21139!> \par MPI mapping
21140!> mpi_gather
21141!> \note see mp_gather_r
21142! **************************************************************************************************
21143 SUBROUTINE mp_gather_rm_src(msg, msg_gather, comm)
21144 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
21145 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
21146 CLASS(mp_comm_type), INTENT(IN) :: comm
21147
21148 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rm_src'
21149
21150 INTEGER :: handle
21151#if defined(__parallel)
21152 INTEGER :: ierr, msglen
21153#endif
21154
21155 CALL mp_timeset(routinen, handle)
21156
21157#if defined(__parallel)
21158 msglen = SIZE(msg)
21159 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21160 msglen, mpi_real, comm%source, comm%handle, ierr)
21161 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21162 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21163#else
21164 mark_used(comm)
21165 msg_gather = msg
21166#endif
21167 CALL mp_timestop(handle)
21168 END SUBROUTINE mp_gather_rm_src
21169
21170! **************************************************************************************************
21171!> \brief Gathers data from all processes to one.
21172!> \param[in] sendbuf Data to send to root
21173!> \param[out] recvbuf Received data (on root)
21174!> \param[in] recvcounts Sizes of data received from processes
21175!> \param[in] displs Offsets of data received from processes
21176!> \param[in] root Process which gathers the data
21177!> \param[in] comm Message passing environment identifier
21178!> \par Data length
21179!> Data can have different lengths
21180!> \par Offsets
21181!> Offsets start at 0
21182!> \par MPI mapping
21183!> mpi_gather
21184! **************************************************************************************************
21185 SUBROUTINE mp_gatherv_rv(sendbuf, recvbuf, recvcounts, displs, root, comm)
21186
21187 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
21188 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
21189 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21190 INTEGER, INTENT(IN) :: root
21191 CLASS(mp_comm_type), INTENT(IN) :: comm
21192
21193 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rv'
21194
21195 INTEGER :: handle
21196#if defined(__parallel)
21197 INTEGER :: ierr, sendcount
21198#endif
21199
21200 CALL mp_timeset(routinen, handle)
21201
21202#if defined(__parallel)
21203 sendcount = SIZE(sendbuf)
21204 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21205 recvbuf, recvcounts, displs, mpi_real, &
21206 root, comm%handle, ierr)
21207 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21208 CALL add_perf(perf_id=4, &
21209 count=1, &
21210 msg_size=sendcount*real_4_size)
21211#else
21212 mark_used(recvcounts)
21213 mark_used(root)
21214 mark_used(comm)
21215 recvbuf(1 + displs(1):) = sendbuf
21216#endif
21217 CALL mp_timestop(handle)
21218 END SUBROUTINE mp_gatherv_rv
21219
21220! **************************************************************************************************
21221!> \brief Gathers data from all processes to one. Gathers from comm%source
21222!> \param[in] sendbuf Data to send to root
21223!> \param[out] recvbuf Received data (on root)
21224!> \param[in] recvcounts Sizes of data received from processes
21225!> \param[in] displs Offsets of data received from processes
21226!> \param[in] comm Message passing environment identifier
21227!> \par Data length
21228!> Data can have different lengths
21229!> \par Offsets
21230!> Offsets start at 0
21231!> \par MPI mapping
21232!> mpi_gather
21233! **************************************************************************************************
21234 SUBROUTINE mp_gatherv_rv_src(sendbuf, recvbuf, recvcounts, displs, comm)
21235
21236 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
21237 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
21238 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21239 CLASS(mp_comm_type), INTENT(IN) :: comm
21240
21241 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rv_src'
21242
21243 INTEGER :: handle
21244#if defined(__parallel)
21245 INTEGER :: ierr, sendcount
21246#endif
21247
21248 CALL mp_timeset(routinen, handle)
21249
21250#if defined(__parallel)
21251 sendcount = SIZE(sendbuf)
21252 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21253 recvbuf, recvcounts, displs, mpi_real, &
21254 comm%source, comm%handle, ierr)
21255 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21256 CALL add_perf(perf_id=4, &
21257 count=1, &
21258 msg_size=sendcount*real_4_size)
21259#else
21260 mark_used(recvcounts)
21261 mark_used(comm)
21262 recvbuf(1 + displs(1):) = sendbuf
21263#endif
21264 CALL mp_timestop(handle)
21265 END SUBROUTINE mp_gatherv_rv_src
21266
21267! **************************************************************************************************
21268!> \brief Gathers data from all processes to one.
21269!> \param[in] sendbuf Data to send to root
21270!> \param[out] recvbuf Received data (on root)
21271!> \param[in] recvcounts Sizes of data received from processes
21272!> \param[in] displs Offsets of data received from processes
21273!> \param[in] root Process which gathers the data
21274!> \param[in] comm Message passing environment identifier
21275!> \par Data length
21276!> Data can have different lengths
21277!> \par Offsets
21278!> Offsets start at 0
21279!> \par MPI mapping
21280!> mpi_gather
21281! **************************************************************************************************
21282 SUBROUTINE mp_gatherv_rm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
21283
21284 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
21285 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
21286 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21287 INTEGER, INTENT(IN) :: root
21288 CLASS(mp_comm_type), INTENT(IN) :: comm
21289
21290 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rm2'
21291
21292 INTEGER :: handle
21293#if defined(__parallel)
21294 INTEGER :: ierr, sendcount
21295#endif
21296
21297 CALL mp_timeset(routinen, handle)
21298
21299#if defined(__parallel)
21300 sendcount = SIZE(sendbuf)
21301 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21302 recvbuf, recvcounts, displs, mpi_real, &
21303 root, comm%handle, ierr)
21304 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21305 CALL add_perf(perf_id=4, &
21306 count=1, &
21307 msg_size=sendcount*real_4_size)
21308#else
21309 mark_used(recvcounts)
21310 mark_used(root)
21311 mark_used(comm)
21312 recvbuf(:, 1 + displs(1):) = sendbuf
21313#endif
21314 CALL mp_timestop(handle)
21315 END SUBROUTINE mp_gatherv_rm2
21316
21317! **************************************************************************************************
21318!> \brief Gathers data from all processes to one.
21319!> \param[in] sendbuf Data to send to root
21320!> \param[out] recvbuf Received data (on root)
21321!> \param[in] recvcounts Sizes of data received from processes
21322!> \param[in] displs Offsets of data received from processes
21323!> \param[in] comm Message passing environment identifier
21324!> \par Data length
21325!> Data can have different lengths
21326!> \par Offsets
21327!> Offsets start at 0
21328!> \par MPI mapping
21329!> mpi_gather
21330! **************************************************************************************************
21331 SUBROUTINE mp_gatherv_rm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
21332
21333 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
21334 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
21335 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21336 CLASS(mp_comm_type), INTENT(IN) :: comm
21337
21338 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rm2_src'
21339
21340 INTEGER :: handle
21341#if defined(__parallel)
21342 INTEGER :: ierr, sendcount
21343#endif
21344
21345 CALL mp_timeset(routinen, handle)
21346
21347#if defined(__parallel)
21348 sendcount = SIZE(sendbuf)
21349 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21350 recvbuf, recvcounts, displs, mpi_real, &
21351 comm%source, comm%handle, ierr)
21352 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21353 CALL add_perf(perf_id=4, &
21354 count=1, &
21355 msg_size=sendcount*real_4_size)
21356#else
21357 mark_used(recvcounts)
21358 mark_used(comm)
21359 recvbuf(:, 1 + displs(1):) = sendbuf
21360#endif
21361 CALL mp_timestop(handle)
21362 END SUBROUTINE mp_gatherv_rm2_src
21363
21364! **************************************************************************************************
21365!> \brief Gathers data from all processes to one.
21366!> \param[in] sendbuf Data to send to root
21367!> \param[out] recvbuf Received data (on root)
21368!> \param[in] recvcounts Sizes of data received from processes
21369!> \param[in] displs Offsets of data received from processes
21370!> \param[in] root Process which gathers the data
21371!> \param[in] comm Message passing environment identifier
21372!> \par Data length
21373!> Data can have different lengths
21374!> \par Offsets
21375!> Offsets start at 0
21376!> \par MPI mapping
21377!> mpi_gather
21378! **************************************************************************************************
21379 SUBROUTINE mp_igatherv_rv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
21380 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: sendbuf
21381 REAL(kind=real_4), DIMENSION(:), INTENT(OUT) :: recvbuf
21382 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21383 INTEGER, INTENT(IN) :: sendcount, root
21384 CLASS(mp_comm_type), INTENT(IN) :: comm
21385 TYPE(mp_request_type), INTENT(OUT) :: request
21386
21387 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_rv'
21388
21389 INTEGER :: handle
21390#if defined(__parallel)
21391 INTEGER :: ierr
21392#endif
21393
21394 CALL mp_timeset(routinen, handle)
21395
21396#if defined(__parallel)
21397#if !defined(__GNUC__) || __GNUC__ >= 9
21398 cpassert(is_contiguous(sendbuf))
21399 cpassert(is_contiguous(recvbuf))
21400 cpassert(is_contiguous(recvcounts))
21401 cpassert(is_contiguous(displs))
21402#endif
21403 CALL mpi_igatherv(sendbuf, sendcount, mpi_real, &
21404 recvbuf, recvcounts, displs, mpi_real, &
21405 root, comm%handle, request%handle, ierr)
21406 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21407 CALL add_perf(perf_id=24, &
21408 count=1, &
21409 msg_size=sendcount*real_4_size)
21410#else
21411 mark_used(sendcount)
21412 mark_used(recvcounts)
21413 mark_used(root)
21414 mark_used(comm)
21415 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
21416 request = mp_request_null
21417#endif
21418 CALL mp_timestop(handle)
21419 END SUBROUTINE mp_igatherv_rv
21420
21421! **************************************************************************************************
21422!> \brief Gathers a datum from all processes and all processes receive the
21423!> same data
21424!> \param[in] msgout Datum to send
21425!> \param[out] msgin Received data
21426!> \param[in] comm Message passing environment identifier
21427!> \par Data size
21428!> All processes send equal-sized data
21429!> \par MPI mapping
21430!> mpi_allgather
21431! **************************************************************************************************
21432 SUBROUTINE mp_allgather_r (msgout, msgin, comm)
21433 REAL(kind=real_4), INTENT(IN) :: msgout
21434 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
21435 CLASS(mp_comm_type), INTENT(IN) :: comm
21436
21437 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r'
21438
21439 INTEGER :: handle
21440#if defined(__parallel)
21441 INTEGER :: ierr, rcount, scount
21442#endif
21443
21444 CALL mp_timeset(routinen, handle)
21445
21446#if defined(__parallel)
21447 scount = 1
21448 rcount = 1
21449 CALL mpi_allgather(msgout, scount, mpi_real, &
21450 msgin, rcount, mpi_real, &
21451 comm%handle, ierr)
21452 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21453#else
21454 mark_used(comm)
21455 msgin = msgout
21456#endif
21457 CALL mp_timestop(handle)
21458 END SUBROUTINE mp_allgather_r
21459
21460! **************************************************************************************************
21461!> \brief Gathers a datum from all processes and all processes receive the
21462!> same data
21463!> \param[in] msgout Datum to send
21464!> \param[out] msgin Received data
21465!> \param[in] comm Message passing environment identifier
21466!> \par Data size
21467!> All processes send equal-sized data
21468!> \par MPI mapping
21469!> mpi_allgather
21470! **************************************************************************************************
21471 SUBROUTINE mp_allgather_r2(msgout, msgin, comm)
21472 REAL(kind=real_4), INTENT(IN) :: msgout
21473 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
21474 CLASS(mp_comm_type), INTENT(IN) :: comm
21475
21476 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r2'
21477
21478 INTEGER :: handle
21479#if defined(__parallel)
21480 INTEGER :: ierr, rcount, scount
21481#endif
21482
21483 CALL mp_timeset(routinen, handle)
21484
21485#if defined(__parallel)
21486 scount = 1
21487 rcount = 1
21488 CALL mpi_allgather(msgout, scount, mpi_real, &
21489 msgin, rcount, mpi_real, &
21490 comm%handle, ierr)
21491 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21492#else
21493 mark_used(comm)
21494 msgin = msgout
21495#endif
21496 CALL mp_timestop(handle)
21497 END SUBROUTINE mp_allgather_r2
21498
21499! **************************************************************************************************
21500!> \brief Gathers a datum from all processes and all processes receive the
21501!> same data
21502!> \param[in] msgout Datum to send
21503!> \param[out] msgin Received data
21504!> \param[in] comm Message passing environment identifier
21505!> \par Data size
21506!> All processes send equal-sized data
21507!> \par MPI mapping
21508!> mpi_allgather
21509! **************************************************************************************************
21510 SUBROUTINE mp_iallgather_r (msgout, msgin, comm, request)
21511 REAL(kind=real_4), INTENT(IN) :: msgout
21512 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
21513 CLASS(mp_comm_type), INTENT(IN) :: comm
21514 TYPE(mp_request_type), INTENT(OUT) :: request
21515
21516 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r'
21517
21518 INTEGER :: handle
21519#if defined(__parallel)
21520 INTEGER :: ierr, rcount, scount
21521#endif
21522
21523 CALL mp_timeset(routinen, handle)
21524
21525#if defined(__parallel)
21526#if !defined(__GNUC__) || __GNUC__ >= 9
21527 cpassert(is_contiguous(msgin))
21528#endif
21529 scount = 1
21530 rcount = 1
21531 CALL mpi_iallgather(msgout, scount, mpi_real, &
21532 msgin, rcount, mpi_real, &
21533 comm%handle, request%handle, ierr)
21534 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21535#else
21536 mark_used(comm)
21537 msgin = msgout
21538 request = mp_request_null
21539#endif
21540 CALL mp_timestop(handle)
21541 END SUBROUTINE mp_iallgather_r
21542
21543! **************************************************************************************************
21544!> \brief Gathers vector data from all processes and all processes receive the
21545!> same data
21546!> \param[in] msgout Rank-1 data to send
21547!> \param[out] msgin Received data
21548!> \param[in] comm Message passing environment identifier
21549!> \par Data size
21550!> All processes send equal-sized data
21551!> \par Ranks
21552!> The last rank counts the processes
21553!> \par MPI mapping
21554!> mpi_allgather
21555! **************************************************************************************************
21556 SUBROUTINE mp_allgather_r12(msgout, msgin, comm)
21557 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:)
21558 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
21559 CLASS(mp_comm_type), INTENT(IN) :: comm
21560
21561 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r12'
21562
21563 INTEGER :: handle
21564#if defined(__parallel)
21565 INTEGER :: ierr, rcount, scount
21566#endif
21567
21568 CALL mp_timeset(routinen, handle)
21569
21570#if defined(__parallel)
21571 scount = SIZE(msgout(:))
21572 rcount = scount
21573 CALL mpi_allgather(msgout, scount, mpi_real, &
21574 msgin, rcount, mpi_real, &
21575 comm%handle, ierr)
21576 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21577#else
21578 mark_used(comm)
21579 msgin(:, 1) = msgout(:)
21580#endif
21581 CALL mp_timestop(handle)
21582 END SUBROUTINE mp_allgather_r12
21583
21584! **************************************************************************************************
21585!> \brief Gathers matrix data from all processes and all processes receive the
21586!> same data
21587!> \param[in] msgout Rank-2 data to send
21588!> \param msgin ...
21589!> \param comm ...
21590!> \note see mp_allgather_r12
21591! **************************************************************************************************
21592 SUBROUTINE mp_allgather_r23(msgout, msgin, comm)
21593 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
21594 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
21595 CLASS(mp_comm_type), INTENT(IN) :: comm
21596
21597 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r23'
21598
21599 INTEGER :: handle
21600#if defined(__parallel)
21601 INTEGER :: ierr, rcount, scount
21602#endif
21603
21604 CALL mp_timeset(routinen, handle)
21605
21606#if defined(__parallel)
21607 scount = SIZE(msgout(:, :))
21608 rcount = scount
21609 CALL mpi_allgather(msgout, scount, mpi_real, &
21610 msgin, rcount, mpi_real, &
21611 comm%handle, ierr)
21612 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21613#else
21614 mark_used(comm)
21615 msgin(:, :, 1) = msgout(:, :)
21616#endif
21617 CALL mp_timestop(handle)
21618 END SUBROUTINE mp_allgather_r23
21619
21620! **************************************************************************************************
21621!> \brief Gathers rank-3 data from all processes and all processes receive the
21622!> same data
21623!> \param[in] msgout Rank-3 data to send
21624!> \param msgin ...
21625!> \param comm ...
21626!> \note see mp_allgather_r12
21627! **************************************************************************************************
21628 SUBROUTINE mp_allgather_r34(msgout, msgin, comm)
21629 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
21630 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
21631 CLASS(mp_comm_type), INTENT(IN) :: comm
21632
21633 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r34'
21634
21635 INTEGER :: handle
21636#if defined(__parallel)
21637 INTEGER :: ierr, rcount, scount
21638#endif
21639
21640 CALL mp_timeset(routinen, handle)
21641
21642#if defined(__parallel)
21643 scount = SIZE(msgout(:, :, :))
21644 rcount = scount
21645 CALL mpi_allgather(msgout, scount, mpi_real, &
21646 msgin, rcount, mpi_real, &
21647 comm%handle, ierr)
21648 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21649#else
21650 mark_used(comm)
21651 msgin(:, :, :, 1) = msgout(:, :, :)
21652#endif
21653 CALL mp_timestop(handle)
21654 END SUBROUTINE mp_allgather_r34
21655
21656! **************************************************************************************************
21657!> \brief Gathers rank-2 data from all processes and all processes receive the
21658!> same data
21659!> \param[in] msgout Rank-2 data to send
21660!> \param msgin ...
21661!> \param comm ...
21662!> \note see mp_allgather_r12
21663! **************************************************************************************************
21664 SUBROUTINE mp_allgather_r22(msgout, msgin, comm)
21665 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
21666 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
21667 CLASS(mp_comm_type), INTENT(IN) :: comm
21668
21669 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r22'
21670
21671 INTEGER :: handle
21672#if defined(__parallel)
21673 INTEGER :: ierr, rcount, scount
21674#endif
21675
21676 CALL mp_timeset(routinen, handle)
21677
21678#if defined(__parallel)
21679 scount = SIZE(msgout(:, :))
21680 rcount = scount
21681 CALL mpi_allgather(msgout, scount, mpi_real, &
21682 msgin, rcount, mpi_real, &
21683 comm%handle, ierr)
21684 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21685#else
21686 mark_used(comm)
21687 msgin(:, :) = msgout(:, :)
21688#endif
21689 CALL mp_timestop(handle)
21690 END SUBROUTINE mp_allgather_r22
21691
21692! **************************************************************************************************
21693!> \brief Gathers rank-1 data from all processes and all processes receive the
21694!> same data
21695!> \param[in] msgout Rank-1 data to send
21696!> \param msgin ...
21697!> \param comm ...
21698!> \param request ...
21699!> \note see mp_allgather_r11
21700! **************************************************************************************************
21701 SUBROUTINE mp_iallgather_r11(msgout, msgin, comm, request)
21702 REAL(kind=real_4), INTENT(IN) :: msgout(:)
21703 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
21704 CLASS(mp_comm_type), INTENT(IN) :: comm
21705 TYPE(mp_request_type), INTENT(OUT) :: request
21706
21707 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r11'
21708
21709 INTEGER :: handle
21710#if defined(__parallel)
21711 INTEGER :: ierr, rcount, scount
21712#endif
21713
21714 CALL mp_timeset(routinen, handle)
21715
21716#if defined(__parallel)
21717#if !defined(__GNUC__) || __GNUC__ >= 9
21718 cpassert(is_contiguous(msgout))
21719 cpassert(is_contiguous(msgin))
21720#endif
21721 scount = SIZE(msgout(:))
21722 rcount = scount
21723 CALL mpi_iallgather(msgout, scount, mpi_real, &
21724 msgin, rcount, mpi_real, &
21725 comm%handle, request%handle, ierr)
21726 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21727#else
21728 mark_used(comm)
21729 msgin = msgout
21730 request = mp_request_null
21731#endif
21732 CALL mp_timestop(handle)
21733 END SUBROUTINE mp_iallgather_r11
21734
21735! **************************************************************************************************
21736!> \brief Gathers rank-2 data from all processes and all processes receive the
21737!> same data
21738!> \param[in] msgout Rank-2 data to send
21739!> \param msgin ...
21740!> \param comm ...
21741!> \param request ...
21742!> \note see mp_allgather_r12
21743! **************************************************************************************************
21744 SUBROUTINE mp_iallgather_r13(msgout, msgin, comm, request)
21745 REAL(kind=real_4), INTENT(IN) :: msgout(:)
21746 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
21747 CLASS(mp_comm_type), INTENT(IN) :: comm
21748 TYPE(mp_request_type), INTENT(OUT) :: request
21749
21750 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r13'
21751
21752 INTEGER :: handle
21753#if defined(__parallel)
21754 INTEGER :: ierr, rcount, scount
21755#endif
21756
21757 CALL mp_timeset(routinen, handle)
21758
21759#if defined(__parallel)
21760#if !defined(__GNUC__) || __GNUC__ >= 9
21761 cpassert(is_contiguous(msgout))
21762 cpassert(is_contiguous(msgin))
21763#endif
21764
21765 scount = SIZE(msgout(:))
21766 rcount = scount
21767 CALL mpi_iallgather(msgout, scount, mpi_real, &
21768 msgin, rcount, mpi_real, &
21769 comm%handle, request%handle, ierr)
21770 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21771#else
21772 mark_used(comm)
21773 msgin(:, 1, 1) = msgout(:)
21774 request = mp_request_null
21775#endif
21776 CALL mp_timestop(handle)
21777 END SUBROUTINE mp_iallgather_r13
21778
21779! **************************************************************************************************
21780!> \brief Gathers rank-2 data from all processes and all processes receive the
21781!> same data
21782!> \param[in] msgout Rank-2 data to send
21783!> \param msgin ...
21784!> \param comm ...
21785!> \param request ...
21786!> \note see mp_allgather_r12
21787! **************************************************************************************************
21788 SUBROUTINE mp_iallgather_r22(msgout, msgin, comm, request)
21789 REAL(kind=real_4), INTENT(IN) :: msgout(:, :)
21790 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :)
21791 CLASS(mp_comm_type), INTENT(IN) :: comm
21792 TYPE(mp_request_type), INTENT(OUT) :: request
21793
21794 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r22'
21795
21796 INTEGER :: handle
21797#if defined(__parallel)
21798 INTEGER :: ierr, rcount, scount
21799#endif
21800
21801 CALL mp_timeset(routinen, handle)
21802
21803#if defined(__parallel)
21804#if !defined(__GNUC__) || __GNUC__ >= 9
21805 cpassert(is_contiguous(msgout))
21806 cpassert(is_contiguous(msgin))
21807#endif
21808
21809 scount = SIZE(msgout(:, :))
21810 rcount = scount
21811 CALL mpi_iallgather(msgout, scount, mpi_real, &
21812 msgin, rcount, mpi_real, &
21813 comm%handle, request%handle, ierr)
21814 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21815#else
21816 mark_used(comm)
21817 msgin(:, :) = msgout(:, :)
21818 request = mp_request_null
21819#endif
21820 CALL mp_timestop(handle)
21821 END SUBROUTINE mp_iallgather_r22
21822
21823! **************************************************************************************************
21824!> \brief Gathers rank-2 data from all processes and all processes receive the
21825!> same data
21826!> \param[in] msgout Rank-2 data to send
21827!> \param msgin ...
21828!> \param comm ...
21829!> \param request ...
21830!> \note see mp_allgather_r12
21831! **************************************************************************************************
21832 SUBROUTINE mp_iallgather_r24(msgout, msgin, comm, request)
21833 REAL(kind=real_4), INTENT(IN) :: msgout(:, :)
21834 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :, :)
21835 CLASS(mp_comm_type), INTENT(IN) :: comm
21836 TYPE(mp_request_type), INTENT(OUT) :: request
21837
21838 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r24'
21839
21840 INTEGER :: handle
21841#if defined(__parallel)
21842 INTEGER :: ierr, rcount, scount
21843#endif
21844
21845 CALL mp_timeset(routinen, handle)
21846
21847#if defined(__parallel)
21848#if !defined(__GNUC__) || __GNUC__ >= 9
21849 cpassert(is_contiguous(msgout))
21850 cpassert(is_contiguous(msgin))
21851#endif
21852
21853 scount = SIZE(msgout(:, :))
21854 rcount = scount
21855 CALL mpi_iallgather(msgout, scount, mpi_real, &
21856 msgin, rcount, mpi_real, &
21857 comm%handle, request%handle, ierr)
21858 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21859#else
21860 mark_used(comm)
21861 msgin(:, :, 1, 1) = msgout(:, :)
21862 request = mp_request_null
21863#endif
21864 CALL mp_timestop(handle)
21865 END SUBROUTINE mp_iallgather_r24
21866
21867! **************************************************************************************************
21868!> \brief Gathers rank-3 data from all processes and all processes receive the
21869!> same data
21870!> \param[in] msgout Rank-3 data to send
21871!> \param msgin ...
21872!> \param comm ...
21873!> \param request ...
21874!> \note see mp_allgather_r12
21875! **************************************************************************************************
21876 SUBROUTINE mp_iallgather_r33(msgout, msgin, comm, request)
21877 REAL(kind=real_4), INTENT(IN) :: msgout(:, :, :)
21878 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
21879 CLASS(mp_comm_type), INTENT(IN) :: comm
21880 TYPE(mp_request_type), INTENT(OUT) :: request
21881
21882 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r33'
21883
21884 INTEGER :: handle
21885#if defined(__parallel)
21886 INTEGER :: ierr, rcount, scount
21887#endif
21888
21889 CALL mp_timeset(routinen, handle)
21890
21891#if defined(__parallel)
21892#if !defined(__GNUC__) || __GNUC__ >= 9
21893 cpassert(is_contiguous(msgout))
21894 cpassert(is_contiguous(msgin))
21895#endif
21896
21897 scount = SIZE(msgout(:, :, :))
21898 rcount = scount
21899 CALL mpi_iallgather(msgout, scount, mpi_real, &
21900 msgin, rcount, mpi_real, &
21901 comm%handle, request%handle, ierr)
21902 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21903#else
21904 mark_used(comm)
21905 msgin(:, :, :) = msgout(:, :, :)
21906 request = mp_request_null
21907#endif
21908 CALL mp_timestop(handle)
21909 END SUBROUTINE mp_iallgather_r33
21910
21911! **************************************************************************************************
21912!> \brief Gathers vector data from all processes and all processes receive the
21913!> same data
21914!> \param[in] msgout Rank-1 data to send
21915!> \param[out] msgin Received data
21916!> \param[in] rcount Size of sent data for every process
21917!> \param[in] rdispl Offset of sent data for every process
21918!> \param[in] comm Message passing environment identifier
21919!> \par Data size
21920!> Processes can send different-sized data
21921!> \par Ranks
21922!> The last rank counts the processes
21923!> \par Offsets
21924!> Offsets are from 0
21925!> \par MPI mapping
21926!> mpi_allgather
21927! **************************************************************************************************
21928 SUBROUTINE mp_allgatherv_rv(msgout, msgin, rcount, rdispl, comm)
21929 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
21930 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
21931 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
21932 CLASS(mp_comm_type), INTENT(IN) :: comm
21933
21934 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_rv'
21935
21936 INTEGER :: handle
21937#if defined(__parallel)
21938 INTEGER :: ierr, scount
21939#endif
21940
21941 CALL mp_timeset(routinen, handle)
21942
21943#if defined(__parallel)
21944 scount = SIZE(msgout)
21945 CALL mpi_allgatherv(msgout, scount, mpi_real, msgin, rcount, &
21946 rdispl, mpi_real, comm%handle, ierr)
21947 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
21948#else
21949 mark_used(rcount)
21950 mark_used(rdispl)
21951 mark_used(comm)
21952 msgin = msgout
21953#endif
21954 CALL mp_timestop(handle)
21955 END SUBROUTINE mp_allgatherv_rv
21956
21957! **************************************************************************************************
21958!> \brief Gathers vector data from all processes and all processes receive the
21959!> same data
21960!> \param[in] msgout Rank-1 data to send
21961!> \param[out] msgin Received data
21962!> \param[in] rcount Size of sent data for every process
21963!> \param[in] rdispl Offset of sent data for every process
21964!> \param[in] comm Message passing environment identifier
21965!> \par Data size
21966!> Processes can send different-sized data
21967!> \par Ranks
21968!> The last rank counts the processes
21969!> \par Offsets
21970!> Offsets are from 0
21971!> \par MPI mapping
21972!> mpi_allgather
21973! **************************************************************************************************
21974 SUBROUTINE mp_allgatherv_rm2(msgout, msgin, rcount, rdispl, comm)
21975 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
21976 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
21977 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
21978 CLASS(mp_comm_type), INTENT(IN) :: comm
21979
21980 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_rv'
21981
21982 INTEGER :: handle
21983#if defined(__parallel)
21984 INTEGER :: ierr, scount
21985#endif
21986
21987 CALL mp_timeset(routinen, handle)
21988
21989#if defined(__parallel)
21990 scount = SIZE(msgout)
21991 CALL mpi_allgatherv(msgout, scount, mpi_real, msgin, rcount, &
21992 rdispl, mpi_real, comm%handle, ierr)
21993 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
21994#else
21995 mark_used(rcount)
21996 mark_used(rdispl)
21997 mark_used(comm)
21998 msgin = msgout
21999#endif
22000 CALL mp_timestop(handle)
22001 END SUBROUTINE mp_allgatherv_rm2
22002
22003! **************************************************************************************************
22004!> \brief Gathers vector data from all processes and all processes receive the
22005!> same data
22006!> \param[in] msgout Rank-1 data to send
22007!> \param[out] msgin Received data
22008!> \param[in] rcount Size of sent data for every process
22009!> \param[in] rdispl Offset of sent data for every process
22010!> \param[in] comm Message passing environment identifier
22011!> \par Data size
22012!> Processes can send different-sized data
22013!> \par Ranks
22014!> The last rank counts the processes
22015!> \par Offsets
22016!> Offsets are from 0
22017!> \par MPI mapping
22018!> mpi_allgather
22019! **************************************************************************************************
22020 SUBROUTINE mp_iallgatherv_rv(msgout, msgin, rcount, rdispl, comm, request)
22021 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22022 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22023 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22024 CLASS(mp_comm_type), INTENT(IN) :: comm
22025 TYPE(mp_request_type), INTENT(OUT) :: request
22026
22027 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_rv'
22028
22029 INTEGER :: handle
22030#if defined(__parallel)
22031 INTEGER :: ierr, scount, rsize
22032#endif
22033
22034 CALL mp_timeset(routinen, handle)
22035
22036#if defined(__parallel)
22037#if !defined(__GNUC__) || __GNUC__ >= 9
22038 cpassert(is_contiguous(msgout))
22039 cpassert(is_contiguous(msgin))
22040 cpassert(is_contiguous(rcount))
22041 cpassert(is_contiguous(rdispl))
22042#endif
22043
22044 scount = SIZE(msgout)
22045 rsize = SIZE(rcount)
22046 CALL mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, &
22047 rdispl, comm, request, ierr)
22048 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
22049#else
22050 mark_used(rcount)
22051 mark_used(rdispl)
22052 mark_used(comm)
22053 msgin = msgout
22054 request = mp_request_null
22055#endif
22056 CALL mp_timestop(handle)
22057 END SUBROUTINE mp_iallgatherv_rv
22058
22059! **************************************************************************************************
22060!> \brief Gathers vector data from all processes and all processes receive the
22061!> same data
22062!> \param[in] msgout Rank-1 data to send
22063!> \param[out] msgin Received data
22064!> \param[in] rcount Size of sent data for every process
22065!> \param[in] rdispl Offset of sent data for every process
22066!> \param[in] comm Message passing environment identifier
22067!> \par Data size
22068!> Processes can send different-sized data
22069!> \par Ranks
22070!> The last rank counts the processes
22071!> \par Offsets
22072!> Offsets are from 0
22073!> \par MPI mapping
22074!> mpi_allgather
22075! **************************************************************************************************
22076 SUBROUTINE mp_iallgatherv_rv2(msgout, msgin, rcount, rdispl, comm, request)
22077 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22078 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22079 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
22080 CLASS(mp_comm_type), INTENT(IN) :: comm
22081 TYPE(mp_request_type), INTENT(OUT) :: request
22082
22083 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_rv2'
22084
22085 INTEGER :: handle
22086#if defined(__parallel)
22087 INTEGER :: ierr, scount, rsize
22088#endif
22089
22090 CALL mp_timeset(routinen, handle)
22091
22092#if defined(__parallel)
22093#if !defined(__GNUC__) || __GNUC__ >= 9
22094 cpassert(is_contiguous(msgout))
22095 cpassert(is_contiguous(msgin))
22096 cpassert(is_contiguous(rcount))
22097 cpassert(is_contiguous(rdispl))
22098#endif
22099
22100 scount = SIZE(msgout)
22101 rsize = SIZE(rcount)
22102 CALL mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, &
22103 rdispl, comm, request, ierr)
22104 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
22105#else
22106 mark_used(rcount)
22107 mark_used(rdispl)
22108 mark_used(comm)
22109 msgin = msgout
22110 request = mp_request_null
22111#endif
22112 CALL mp_timestop(handle)
22113 END SUBROUTINE mp_iallgatherv_rv2
22114
22115! **************************************************************************************************
22116!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
22117!> the issue is with the rank of rcount and rdispl
22118!> \param count ...
22119!> \param array_of_requests ...
22120!> \param array_of_statuses ...
22121!> \param ierr ...
22122!> \author Alfio Lazzaro
22123! **************************************************************************************************
22124#if defined(__parallel)
22125 SUBROUTINE mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
22126 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
22127 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22128 INTEGER, INTENT(IN) :: rsize
22129 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
22130 CLASS(mp_comm_type), INTENT(IN) :: comm
22131 TYPE(mp_request_type), INTENT(OUT) :: request
22132 INTEGER, INTENT(INOUT) :: ierr
22133
22134 CALL mpi_iallgatherv(msgout, scount, mpi_real, msgin, rcount, &
22135 rdispl, mpi_real, comm%handle, request%handle, ierr)
22136
22137 END SUBROUTINE mp_iallgatherv_rv_internal
22138#endif
22139
22140! **************************************************************************************************
22141!> \brief Sums a vector and partitions the result among processes
22142!> \param[in] msgout Data to sum
22143!> \param[out] msgin Received portion of summed data
22144!> \param[in] rcount Partition sizes of the summed data for
22145!> every process
22146!> \param[in] comm Message passing environment identifier
22147! **************************************************************************************************
22148 SUBROUTINE mp_sum_scatter_rv(msgout, msgin, rcount, comm)
22149 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
22150 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22151 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
22152 CLASS(mp_comm_type), INTENT(IN) :: comm
22153
22154 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_rv'
22155
22156 INTEGER :: handle
22157#if defined(__parallel)
22158 INTEGER :: ierr
22159#endif
22160
22161 CALL mp_timeset(routinen, handle)
22162
22163#if defined(__parallel)
22164 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_real, mpi_sum, &
22165 comm%handle, ierr)
22166 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
22167
22168 CALL add_perf(perf_id=3, count=1, &
22169 msg_size=rcount(1)*2*real_4_size)
22170#else
22171 mark_used(rcount)
22172 mark_used(comm)
22173 msgin = msgout(:, 1)
22174#endif
22175 CALL mp_timestop(handle)
22176 END SUBROUTINE mp_sum_scatter_rv
22177
22178! **************************************************************************************************
22179!> \brief Sends and receives vector data
22180!> \param[in] msgin Data to send
22181!> \param[in] dest Process to send data to
22182!> \param[out] msgout Received data
22183!> \param[in] source Process from which to receive
22184!> \param[in] comm Message passing environment identifier
22185!> \param[in] tag Send and recv tag (default: 0)
22186! **************************************************************************************************
22187 SUBROUTINE mp_sendrecv_r (msgin, dest, msgout, source, comm, tag)
22188 REAL(kind=real_4), INTENT(IN) :: msgin
22189 INTEGER, INTENT(IN) :: dest
22190 REAL(kind=real_4), INTENT(OUT) :: msgout
22191 INTEGER, INTENT(IN) :: source
22192 CLASS(mp_comm_type), INTENT(IN) :: comm
22193 INTEGER, INTENT(IN), OPTIONAL :: tag
22194
22195 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_r'
22196
22197 INTEGER :: handle
22198#if defined(__parallel)
22199 INTEGER :: ierr, msglen_in, msglen_out, &
22200 recv_tag, send_tag
22201#endif
22202
22203 CALL mp_timeset(routinen, handle)
22204
22205#if defined(__parallel)
22206 msglen_in = 1
22207 msglen_out = 1
22208 send_tag = 0 ! cannot think of something better here, this might be dangerous
22209 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22210 IF (PRESENT(tag)) THEN
22211 send_tag = tag
22212 recv_tag = tag
22213 END IF
22214 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22215 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22216 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22217 CALL add_perf(perf_id=7, count=1, &
22218 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22219#else
22220 mark_used(dest)
22221 mark_used(source)
22222 mark_used(comm)
22223 mark_used(tag)
22224 msgout = msgin
22225#endif
22226 CALL mp_timestop(handle)
22227 END SUBROUTINE mp_sendrecv_r
22228
22229! **************************************************************************************************
22230!> \brief Sends and receives vector data
22231!> \param[in] msgin Data to send
22232!> \param[in] dest Process to send data to
22233!> \param[out] msgout Received data
22234!> \param[in] source Process from which to receive
22235!> \param[in] comm Message passing environment identifier
22236!> \param[in] tag Send and recv tag (default: 0)
22237! **************************************************************************************************
22238 SUBROUTINE mp_sendrecv_rv(msgin, dest, msgout, source, comm, tag)
22239 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
22240 INTEGER, INTENT(IN) :: dest
22241 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
22242 INTEGER, INTENT(IN) :: source
22243 CLASS(mp_comm_type), INTENT(IN) :: comm
22244 INTEGER, INTENT(IN), OPTIONAL :: tag
22245
22246 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rv'
22247
22248 INTEGER :: handle
22249#if defined(__parallel)
22250 INTEGER :: ierr, msglen_in, msglen_out, &
22251 recv_tag, send_tag
22252#endif
22253
22254 CALL mp_timeset(routinen, handle)
22255
22256#if defined(__parallel)
22257 msglen_in = SIZE(msgin)
22258 msglen_out = SIZE(msgout)
22259 send_tag = 0 ! cannot think of something better here, this might be dangerous
22260 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22261 IF (PRESENT(tag)) THEN
22262 send_tag = tag
22263 recv_tag = tag
22264 END IF
22265 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22266 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22267 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22268 CALL add_perf(perf_id=7, count=1, &
22269 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22270#else
22271 mark_used(dest)
22272 mark_used(source)
22273 mark_used(comm)
22274 mark_used(tag)
22275 msgout = msgin
22276#endif
22277 CALL mp_timestop(handle)
22278 END SUBROUTINE mp_sendrecv_rv
22279
22280! **************************************************************************************************
22281!> \brief Sends and receives matrix data
22282!> \param msgin ...
22283!> \param dest ...
22284!> \param msgout ...
22285!> \param source ...
22286!> \param comm ...
22287!> \param tag ...
22288!> \note see mp_sendrecv_rv
22289! **************************************************************************************************
22290 SUBROUTINE mp_sendrecv_rm2(msgin, dest, msgout, source, comm, tag)
22291 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
22292 INTEGER, INTENT(IN) :: dest
22293 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
22294 INTEGER, INTENT(IN) :: source
22295 CLASS(mp_comm_type), INTENT(IN) :: comm
22296 INTEGER, INTENT(IN), OPTIONAL :: tag
22297
22298 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm2'
22299
22300 INTEGER :: handle
22301#if defined(__parallel)
22302 INTEGER :: ierr, msglen_in, msglen_out, &
22303 recv_tag, send_tag
22304#endif
22305
22306 CALL mp_timeset(routinen, handle)
22307
22308#if defined(__parallel)
22309 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
22310 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
22311 send_tag = 0 ! cannot think of something better here, this might be dangerous
22312 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22313 IF (PRESENT(tag)) THEN
22314 send_tag = tag
22315 recv_tag = tag
22316 END IF
22317 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22318 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22319 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22320 CALL add_perf(perf_id=7, count=1, &
22321 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22322#else
22323 mark_used(dest)
22324 mark_used(source)
22325 mark_used(comm)
22326 mark_used(tag)
22327 msgout = msgin
22328#endif
22329 CALL mp_timestop(handle)
22330 END SUBROUTINE mp_sendrecv_rm2
22331
22332! **************************************************************************************************
22333!> \brief Sends and receives rank-3 data
22334!> \param msgin ...
22335!> \param dest ...
22336!> \param msgout ...
22337!> \param source ...
22338!> \param comm ...
22339!> \note see mp_sendrecv_rv
22340! **************************************************************************************************
22341 SUBROUTINE mp_sendrecv_rm3(msgin, dest, msgout, source, comm, tag)
22342 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
22343 INTEGER, INTENT(IN) :: dest
22344 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
22345 INTEGER, INTENT(IN) :: source
22346 CLASS(mp_comm_type), INTENT(IN) :: comm
22347 INTEGER, INTENT(IN), OPTIONAL :: tag
22348
22349 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm3'
22350
22351 INTEGER :: handle
22352#if defined(__parallel)
22353 INTEGER :: ierr, msglen_in, msglen_out, &
22354 recv_tag, send_tag
22355#endif
22356
22357 CALL mp_timeset(routinen, handle)
22358
22359#if defined(__parallel)
22360 msglen_in = SIZE(msgin)
22361 msglen_out = SIZE(msgout)
22362 send_tag = 0 ! cannot think of something better here, this might be dangerous
22363 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22364 IF (PRESENT(tag)) THEN
22365 send_tag = tag
22366 recv_tag = tag
22367 END IF
22368 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22369 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22370 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22371 CALL add_perf(perf_id=7, count=1, &
22372 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22373#else
22374 mark_used(dest)
22375 mark_used(source)
22376 mark_used(comm)
22377 mark_used(tag)
22378 msgout = msgin
22379#endif
22380 CALL mp_timestop(handle)
22381 END SUBROUTINE mp_sendrecv_rm3
22382
22383! **************************************************************************************************
22384!> \brief Sends and receives rank-4 data
22385!> \param msgin ...
22386!> \param dest ...
22387!> \param msgout ...
22388!> \param source ...
22389!> \param comm ...
22390!> \note see mp_sendrecv_rv
22391! **************************************************************************************************
22392 SUBROUTINE mp_sendrecv_rm4(msgin, dest, msgout, source, comm, tag)
22393 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
22394 INTEGER, INTENT(IN) :: dest
22395 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
22396 INTEGER, INTENT(IN) :: source
22397 CLASS(mp_comm_type), INTENT(IN) :: comm
22398 INTEGER, INTENT(IN), OPTIONAL :: tag
22399
22400 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm4'
22401
22402 INTEGER :: handle
22403#if defined(__parallel)
22404 INTEGER :: ierr, msglen_in, msglen_out, &
22405 recv_tag, send_tag
22406#endif
22407
22408 CALL mp_timeset(routinen, handle)
22409
22410#if defined(__parallel)
22411 msglen_in = SIZE(msgin)
22412 msglen_out = SIZE(msgout)
22413 send_tag = 0 ! cannot think of something better here, this might be dangerous
22414 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22415 IF (PRESENT(tag)) THEN
22416 send_tag = tag
22417 recv_tag = tag
22418 END IF
22419 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22420 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22421 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22422 CALL add_perf(perf_id=7, count=1, &
22423 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22424#else
22425 mark_used(dest)
22426 mark_used(source)
22427 mark_used(comm)
22428 mark_used(tag)
22429 msgout = msgin
22430#endif
22431 CALL mp_timestop(handle)
22432 END SUBROUTINE mp_sendrecv_rm4
22433
22434! **************************************************************************************************
22435!> \brief Non-blocking send and receive of a scalar
22436!> \param[in] msgin Scalar data to send
22437!> \param[in] dest Which process to send to
22438!> \param[out] msgout Receive data into this pointer
22439!> \param[in] source Process to receive from
22440!> \param[in] comm Message passing environment identifier
22441!> \param[out] send_request Request handle for the send
22442!> \param[out] recv_request Request handle for the receive
22443!> \param[in] tag (optional) tag to differentiate requests
22444!> \par Implementation
22445!> Calls mpi_isend and mpi_irecv.
22446!> \par History
22447!> 02.2005 created [Alfio Lazzaro]
22448! **************************************************************************************************
22449 SUBROUTINE mp_isendrecv_r (msgin, dest, msgout, source, comm, send_request, &
22450 recv_request, tag)
22451 REAL(kind=real_4), INTENT(IN) :: msgin
22452 INTEGER, INTENT(IN) :: dest
22453 REAL(kind=real_4), INTENT(INOUT) :: msgout
22454 INTEGER, INTENT(IN) :: source
22455 CLASS(mp_comm_type), INTENT(IN) :: comm
22456 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
22457 INTEGER, INTENT(in), OPTIONAL :: tag
22458
22459 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_r'
22460
22461 INTEGER :: handle
22462#if defined(__parallel)
22463 INTEGER :: ierr, my_tag
22464#endif
22465
22466 CALL mp_timeset(routinen, handle)
22467
22468#if defined(__parallel)
22469 my_tag = 0
22470 IF (PRESENT(tag)) my_tag = tag
22471
22472 CALL mpi_irecv(msgout, 1, mpi_real, source, my_tag, &
22473 comm%handle, recv_request%handle, ierr)
22474 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
22475
22476 CALL mpi_isend(msgin, 1, mpi_real, dest, my_tag, &
22477 comm%handle, send_request%handle, ierr)
22478 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22479
22480 CALL add_perf(perf_id=8, count=1, msg_size=2*real_4_size)
22481#else
22482 mark_used(dest)
22483 mark_used(source)
22484 mark_used(comm)
22485 mark_used(tag)
22486 send_request = mp_request_null
22487 recv_request = mp_request_null
22488 msgout = msgin
22489#endif
22490 CALL mp_timestop(handle)
22491 END SUBROUTINE mp_isendrecv_r
22492
22493! **************************************************************************************************
22494!> \brief Non-blocking send and receive of a vector
22495!> \param[in] msgin Vector data to send
22496!> \param[in] dest Which process to send to
22497!> \param[out] msgout Receive data into this pointer
22498!> \param[in] source Process to receive from
22499!> \param[in] comm Message passing environment identifier
22500!> \param[out] send_request Request handle for the send
22501!> \param[out] recv_request Request handle for the receive
22502!> \param[in] tag (optional) tag to differentiate requests
22503!> \par Implementation
22504!> Calls mpi_isend and mpi_irecv.
22505!> \par History
22506!> 11.2004 created [Joost VandeVondele]
22507!> \note
22508!> arrays can be pointers or assumed shape, but they must be contiguous!
22509! **************************************************************************************************
22510 SUBROUTINE mp_isendrecv_rv(msgin, dest, msgout, source, comm, send_request, &
22511 recv_request, tag)
22512 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
22513 INTEGER, INTENT(IN) :: dest
22514 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
22515 INTEGER, INTENT(IN) :: source
22516 CLASS(mp_comm_type), INTENT(IN) :: comm
22517 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
22518 INTEGER, INTENT(in), OPTIONAL :: tag
22519
22520 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_rv'
22521
22522 INTEGER :: handle
22523#if defined(__parallel)
22524 INTEGER :: ierr, msglen, my_tag
22525 REAL(kind=real_4) :: foo
22526#endif
22527
22528 CALL mp_timeset(routinen, handle)
22529
22530#if defined(__parallel)
22531#if !defined(__GNUC__) || __GNUC__ >= 9
22532 cpassert(is_contiguous(msgout))
22533 cpassert(is_contiguous(msgin))
22534#endif
22535
22536 my_tag = 0
22537 IF (PRESENT(tag)) my_tag = tag
22538
22539 msglen = SIZE(msgout, 1)
22540 IF (msglen > 0) THEN
22541 CALL mpi_irecv(msgout(1), msglen, mpi_real, source, my_tag, &
22542 comm%handle, recv_request%handle, ierr)
22543 ELSE
22544 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
22545 comm%handle, recv_request%handle, ierr)
22546 END IF
22547 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
22548
22549 msglen = SIZE(msgin, 1)
22550 IF (msglen > 0) THEN
22551 CALL mpi_isend(msgin(1), msglen, mpi_real, dest, my_tag, &
22552 comm%handle, send_request%handle, ierr)
22553 ELSE
22554 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22555 comm%handle, send_request%handle, ierr)
22556 END IF
22557 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22558
22559 msglen = (msglen + SIZE(msgout, 1) + 1)/2
22560 CALL add_perf(perf_id=8, count=1, msg_size=msglen*real_4_size)
22561#else
22562 mark_used(dest)
22563 mark_used(source)
22564 mark_used(comm)
22565 mark_used(tag)
22566 send_request = mp_request_null
22567 recv_request = mp_request_null
22568 msgout = msgin
22569#endif
22570 CALL mp_timestop(handle)
22571 END SUBROUTINE mp_isendrecv_rv
22572
22573! **************************************************************************************************
22574!> \brief Non-blocking send of vector data
22575!> \param msgin ...
22576!> \param dest ...
22577!> \param comm ...
22578!> \param request ...
22579!> \param tag ...
22580!> \par History
22581!> 08.2003 created [f&j]
22582!> \note see mp_isendrecv_rv
22583!> \note
22584!> arrays can be pointers or assumed shape, but they must be contiguous!
22585! **************************************************************************************************
22586 SUBROUTINE mp_isend_rv(msgin, dest, comm, request, tag)
22587 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
22588 INTEGER, INTENT(IN) :: dest
22589 CLASS(mp_comm_type), INTENT(IN) :: comm
22590 TYPE(mp_request_type), INTENT(out) :: request
22591 INTEGER, INTENT(in), OPTIONAL :: tag
22592
22593 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rv'
22594
22595 INTEGER :: handle, ierr
22596#if defined(__parallel)
22597 INTEGER :: msglen, my_tag
22598 REAL(kind=real_4) :: foo(1)
22599#endif
22600
22601 CALL mp_timeset(routinen, handle)
22602
22603#if defined(__parallel)
22604#if !defined(__GNUC__) || __GNUC__ >= 9
22605 cpassert(is_contiguous(msgin))
22606#endif
22607 my_tag = 0
22608 IF (PRESENT(tag)) my_tag = tag
22609
22610 msglen = SIZE(msgin)
22611 IF (msglen > 0) THEN
22612 CALL mpi_isend(msgin(1), msglen, mpi_real, dest, my_tag, &
22613 comm%handle, request%handle, ierr)
22614 ELSE
22615 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22616 comm%handle, request%handle, ierr)
22617 END IF
22618 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22619
22620 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22621#else
22622 mark_used(msgin)
22623 mark_used(dest)
22624 mark_used(comm)
22625 mark_used(request)
22626 mark_used(tag)
22627 ierr = 1
22628 request = mp_request_null
22629 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22630#endif
22631 CALL mp_timestop(handle)
22632 END SUBROUTINE mp_isend_rv
22633
22634! **************************************************************************************************
22635!> \brief Non-blocking send of matrix data
22636!> \param msgin ...
22637!> \param dest ...
22638!> \param comm ...
22639!> \param request ...
22640!> \param tag ...
22641!> \par History
22642!> 2009-11-25 [UB] Made type-generic for templates
22643!> \author fawzi
22644!> \note see mp_isendrecv_rv
22645!> \note see mp_isend_rv
22646!> \note
22647!> arrays can be pointers or assumed shape, but they must be contiguous!
22648! **************************************************************************************************
22649 SUBROUTINE mp_isend_rm2(msgin, dest, comm, request, tag)
22650 REAL(kind=real_4), DIMENSION(:, :), INTENT(IN) :: msgin
22651 INTEGER, INTENT(IN) :: dest
22652 CLASS(mp_comm_type), INTENT(IN) :: comm
22653 TYPE(mp_request_type), INTENT(out) :: request
22654 INTEGER, INTENT(in), OPTIONAL :: tag
22655
22656 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm2'
22657
22658 INTEGER :: handle, ierr
22659#if defined(__parallel)
22660 INTEGER :: msglen, my_tag
22661 REAL(kind=real_4) :: foo(1)
22662#endif
22663
22664 CALL mp_timeset(routinen, handle)
22665
22666#if defined(__parallel)
22667#if !defined(__GNUC__) || __GNUC__ >= 9
22668 cpassert(is_contiguous(msgin))
22669#endif
22670
22671 my_tag = 0
22672 IF (PRESENT(tag)) my_tag = tag
22673
22674 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
22675 IF (msglen > 0) THEN
22676 CALL mpi_isend(msgin(1, 1), msglen, mpi_real, dest, my_tag, &
22677 comm%handle, request%handle, ierr)
22678 ELSE
22679 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22680 comm%handle, request%handle, ierr)
22681 END IF
22682 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22683
22684 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22685#else
22686 mark_used(msgin)
22687 mark_used(dest)
22688 mark_used(comm)
22689 mark_used(request)
22690 mark_used(tag)
22691 ierr = 1
22692 request = mp_request_null
22693 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22694#endif
22695 CALL mp_timestop(handle)
22696 END SUBROUTINE mp_isend_rm2
22697
22698! **************************************************************************************************
22699!> \brief Non-blocking send of rank-3 data
22700!> \param msgin ...
22701!> \param dest ...
22702!> \param comm ...
22703!> \param request ...
22704!> \param tag ...
22705!> \par History
22706!> 9.2008 added _rm3 subroutine [Iain Bethune]
22707!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
22708!> 2009-11-25 [UB] Made type-generic for templates
22709!> \author fawzi
22710!> \note see mp_isendrecv_rv
22711!> \note see mp_isend_rv
22712!> \note
22713!> arrays can be pointers or assumed shape, but they must be contiguous!
22714! **************************************************************************************************
22715 SUBROUTINE mp_isend_rm3(msgin, dest, comm, request, tag)
22716 REAL(kind=real_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
22717 INTEGER, INTENT(IN) :: dest
22718 CLASS(mp_comm_type), INTENT(IN) :: comm
22719 TYPE(mp_request_type), INTENT(out) :: request
22720 INTEGER, INTENT(in), OPTIONAL :: tag
22721
22722 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm3'
22723
22724 INTEGER :: handle, ierr
22725#if defined(__parallel)
22726 INTEGER :: msglen, my_tag
22727 REAL(kind=real_4) :: foo(1)
22728#endif
22729
22730 CALL mp_timeset(routinen, handle)
22731
22732#if defined(__parallel)
22733#if !defined(__GNUC__) || __GNUC__ >= 9
22734 cpassert(is_contiguous(msgin))
22735#endif
22736
22737 my_tag = 0
22738 IF (PRESENT(tag)) my_tag = tag
22739
22740 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
22741 IF (msglen > 0) THEN
22742 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_real, dest, my_tag, &
22743 comm%handle, request%handle, ierr)
22744 ELSE
22745 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22746 comm%handle, request%handle, ierr)
22747 END IF
22748 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22749
22750 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22751#else
22752 mark_used(msgin)
22753 mark_used(dest)
22754 mark_used(comm)
22755 mark_used(request)
22756 mark_used(tag)
22757 ierr = 1
22758 request = mp_request_null
22759 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22760#endif
22761 CALL mp_timestop(handle)
22762 END SUBROUTINE mp_isend_rm3
22763
22764! **************************************************************************************************
22765!> \brief Non-blocking send of rank-4 data
22766!> \param msgin the input message
22767!> \param dest the destination processor
22768!> \param comm the communicator object
22769!> \param request the communication request id
22770!> \param tag the message tag
22771!> \par History
22772!> 2.2016 added _rm4 subroutine [Nico Holmberg]
22773!> \author fawzi
22774!> \note see mp_isend_rv
22775!> \note
22776!> arrays can be pointers or assumed shape, but they must be contiguous!
22777! **************************************************************************************************
22778 SUBROUTINE mp_isend_rm4(msgin, dest, comm, request, tag)
22779 REAL(kind=real_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
22780 INTEGER, INTENT(IN) :: dest
22781 CLASS(mp_comm_type), INTENT(IN) :: comm
22782 TYPE(mp_request_type), INTENT(out) :: request
22783 INTEGER, INTENT(in), OPTIONAL :: tag
22784
22785 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm4'
22786
22787 INTEGER :: handle, ierr
22788#if defined(__parallel)
22789 INTEGER :: msglen, my_tag
22790 REAL(kind=real_4) :: foo(1)
22791#endif
22792
22793 CALL mp_timeset(routinen, handle)
22794
22795#if defined(__parallel)
22796#if !defined(__GNUC__) || __GNUC__ >= 9
22797 cpassert(is_contiguous(msgin))
22798#endif
22799
22800 my_tag = 0
22801 IF (PRESENT(tag)) my_tag = tag
22802
22803 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
22804 IF (msglen > 0) THEN
22805 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_real, dest, my_tag, &
22806 comm%handle, request%handle, ierr)
22807 ELSE
22808 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22809 comm%handle, request%handle, ierr)
22810 END IF
22811 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22812
22813 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22814#else
22815 mark_used(msgin)
22816 mark_used(dest)
22817 mark_used(comm)
22818 mark_used(request)
22819 mark_used(tag)
22820 ierr = 1
22821 request = mp_request_null
22822 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22823#endif
22824 CALL mp_timestop(handle)
22825 END SUBROUTINE mp_isend_rm4
22826
22827! **************************************************************************************************
22828!> \brief Non-blocking receive of vector data
22829!> \param msgout ...
22830!> \param source ...
22831!> \param comm ...
22832!> \param request ...
22833!> \param tag ...
22834!> \par History
22835!> 08.2003 created [f&j]
22836!> 2009-11-25 [UB] Made type-generic for templates
22837!> \note see mp_isendrecv_rv
22838!> \note
22839!> arrays can be pointers or assumed shape, but they must be contiguous!
22840! **************************************************************************************************
22841 SUBROUTINE mp_irecv_rv(msgout, source, comm, request, tag)
22842 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
22843 INTEGER, INTENT(IN) :: source
22844 CLASS(mp_comm_type), INTENT(IN) :: comm
22845 TYPE(mp_request_type), INTENT(out) :: request
22846 INTEGER, INTENT(in), OPTIONAL :: tag
22847
22848 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rv'
22849
22850 INTEGER :: handle
22851#if defined(__parallel)
22852 INTEGER :: ierr, msglen, my_tag
22853 REAL(kind=real_4) :: foo(1)
22854#endif
22855
22856 CALL mp_timeset(routinen, handle)
22857
22858#if defined(__parallel)
22859#if !defined(__GNUC__) || __GNUC__ >= 9
22860 cpassert(is_contiguous(msgout))
22861#endif
22862
22863 my_tag = 0
22864 IF (PRESENT(tag)) my_tag = tag
22865
22866 msglen = SIZE(msgout)
22867 IF (msglen > 0) THEN
22868 CALL mpi_irecv(msgout(1), msglen, mpi_real, source, my_tag, &
22869 comm%handle, request%handle, ierr)
22870 ELSE
22871 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
22872 comm%handle, request%handle, ierr)
22873 END IF
22874 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
22875
22876 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
22877#else
22878 cpabort("mp_irecv called in non parallel case")
22879 mark_used(msgout)
22880 mark_used(source)
22881 mark_used(comm)
22882 mark_used(tag)
22883 request = mp_request_null
22884#endif
22885 CALL mp_timestop(handle)
22886 END SUBROUTINE mp_irecv_rv
22887
22888! **************************************************************************************************
22889!> \brief Non-blocking receive of matrix data
22890!> \param msgout ...
22891!> \param source ...
22892!> \param comm ...
22893!> \param request ...
22894!> \param tag ...
22895!> \par History
22896!> 2009-11-25 [UB] Made type-generic for templates
22897!> \author fawzi
22898!> \note see mp_isendrecv_rv
22899!> \note see mp_irecv_rv
22900!> \note
22901!> arrays can be pointers or assumed shape, but they must be contiguous!
22902! **************************************************************************************************
22903 SUBROUTINE mp_irecv_rm2(msgout, source, comm, request, tag)
22904 REAL(kind=real_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
22905 INTEGER, INTENT(IN) :: source
22906 CLASS(mp_comm_type), INTENT(IN) :: comm
22907 TYPE(mp_request_type), INTENT(out) :: request
22908 INTEGER, INTENT(in), OPTIONAL :: tag
22909
22910 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm2'
22911
22912 INTEGER :: handle
22913#if defined(__parallel)
22914 INTEGER :: ierr, msglen, my_tag
22915 REAL(kind=real_4) :: foo(1)
22916#endif
22917
22918 CALL mp_timeset(routinen, handle)
22919
22920#if defined(__parallel)
22921#if !defined(__GNUC__) || __GNUC__ >= 9
22922 cpassert(is_contiguous(msgout))
22923#endif
22924
22925 my_tag = 0
22926 IF (PRESENT(tag)) my_tag = tag
22927
22928 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
22929 IF (msglen > 0) THEN
22930 CALL mpi_irecv(msgout(1, 1), msglen, mpi_real, source, my_tag, &
22931 comm%handle, request%handle, ierr)
22932 ELSE
22933 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
22934 comm%handle, request%handle, ierr)
22935 END IF
22936 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
22937
22938 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
22939#else
22940 mark_used(msgout)
22941 mark_used(source)
22942 mark_used(comm)
22943 mark_used(tag)
22944 request = mp_request_null
22945 cpabort("mp_irecv called in non parallel case")
22946#endif
22947 CALL mp_timestop(handle)
22948 END SUBROUTINE mp_irecv_rm2
22949
22950! **************************************************************************************************
22951!> \brief Non-blocking send of rank-3 data
22952!> \param msgout ...
22953!> \param source ...
22954!> \param comm ...
22955!> \param request ...
22956!> \param tag ...
22957!> \par History
22958!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
22959!> 2009-11-25 [UB] Made type-generic for templates
22960!> \author fawzi
22961!> \note see mp_isendrecv_rv
22962!> \note see mp_irecv_rv
22963!> \note
22964!> arrays can be pointers or assumed shape, but they must be contiguous!
22965! **************************************************************************************************
22966 SUBROUTINE mp_irecv_rm3(msgout, source, comm, request, tag)
22967 REAL(kind=real_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
22968 INTEGER, INTENT(IN) :: source
22969 CLASS(mp_comm_type), INTENT(IN) :: comm
22970 TYPE(mp_request_type), INTENT(out) :: request
22971 INTEGER, INTENT(in), OPTIONAL :: tag
22972
22973 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm3'
22974
22975 INTEGER :: handle
22976#if defined(__parallel)
22977 INTEGER :: ierr, msglen, my_tag
22978 REAL(kind=real_4) :: foo(1)
22979#endif
22980
22981 CALL mp_timeset(routinen, handle)
22982
22983#if defined(__parallel)
22984#if !defined(__GNUC__) || __GNUC__ >= 9
22985 cpassert(is_contiguous(msgout))
22986#endif
22987
22988 my_tag = 0
22989 IF (PRESENT(tag)) my_tag = tag
22990
22991 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
22992 IF (msglen > 0) THEN
22993 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_real, source, my_tag, &
22994 comm%handle, request%handle, ierr)
22995 ELSE
22996 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
22997 comm%handle, request%handle, ierr)
22998 END IF
22999 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
23000
23001 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23002#else
23003 mark_used(msgout)
23004 mark_used(source)
23005 mark_used(comm)
23006 mark_used(tag)
23007 request = mp_request_null
23008 cpabort("mp_irecv called in non parallel case")
23009#endif
23010 CALL mp_timestop(handle)
23011 END SUBROUTINE mp_irecv_rm3
23012
23013! **************************************************************************************************
23014!> \brief Non-blocking receive of rank-4 data
23015!> \param msgout the output message
23016!> \param source the source processor
23017!> \param comm the communicator object
23018!> \param request the communication request id
23019!> \param tag the message tag
23020!> \par History
23021!> 2.2016 added _rm4 subroutine [Nico Holmberg]
23022!> \author fawzi
23023!> \note see mp_irecv_rv
23024!> \note
23025!> arrays can be pointers or assumed shape, but they must be contiguous!
23026! **************************************************************************************************
23027 SUBROUTINE mp_irecv_rm4(msgout, source, comm, request, tag)
23028 REAL(kind=real_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
23029 INTEGER, INTENT(IN) :: source
23030 CLASS(mp_comm_type), INTENT(IN) :: comm
23031 TYPE(mp_request_type), INTENT(out) :: request
23032 INTEGER, INTENT(in), OPTIONAL :: tag
23033
23034 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm4'
23035
23036 INTEGER :: handle
23037#if defined(__parallel)
23038 INTEGER :: ierr, msglen, my_tag
23039 REAL(kind=real_4) :: foo(1)
23040#endif
23041
23042 CALL mp_timeset(routinen, handle)
23043
23044#if defined(__parallel)
23045#if !defined(__GNUC__) || __GNUC__ >= 9
23046 cpassert(is_contiguous(msgout))
23047#endif
23048
23049 my_tag = 0
23050 IF (PRESENT(tag)) my_tag = tag
23051
23052 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
23053 IF (msglen > 0) THEN
23054 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_real, source, my_tag, &
23055 comm%handle, request%handle, ierr)
23056 ELSE
23057 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23058 comm%handle, request%handle, ierr)
23059 END IF
23060 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
23061
23062 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23063#else
23064 mark_used(msgout)
23065 mark_used(source)
23066 mark_used(comm)
23067 mark_used(tag)
23068 request = mp_request_null
23069 cpabort("mp_irecv called in non parallel case")
23070#endif
23071 CALL mp_timestop(handle)
23072 END SUBROUTINE mp_irecv_rm4
23073
23074! **************************************************************************************************
23075!> \brief Window initialization function for vector data
23076!> \param base ...
23077!> \param comm ...
23078!> \param win ...
23079!> \par History
23080!> 02.2015 created [Alfio Lazzaro]
23081!> \note
23082!> arrays can be pointers or assumed shape, but they must be contiguous!
23083! **************************************************************************************************
23084 SUBROUTINE mp_win_create_rv(base, comm, win)
23085 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
23086 TYPE(mp_comm_type), INTENT(IN) :: comm
23087 CLASS(mp_win_type), INTENT(INOUT) :: win
23088
23089 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_rv'
23090
23091 INTEGER :: handle
23092#if defined(__parallel)
23093 INTEGER :: ierr
23094 INTEGER(kind=mpi_address_kind) :: len
23095 REAL(kind=real_4) :: foo(1)
23096#endif
23097
23098 CALL mp_timeset(routinen, handle)
23099
23100#if defined(__parallel)
23101
23102 len = SIZE(base)*real_4_size
23103 IF (len > 0) THEN
23104 CALL mpi_win_create(base(1), len, real_4_size, mpi_info_null, comm%handle, win%handle, ierr)
23105 ELSE
23106 CALL mpi_win_create(foo, len, real_4_size, mpi_info_null, comm%handle, win%handle, ierr)
23107 END IF
23108 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
23109
23110 CALL add_perf(perf_id=20, count=1)
23111#else
23112 mark_used(base)
23113 mark_used(comm)
23114 win%handle = mp_win_null_handle
23115#endif
23116 CALL mp_timestop(handle)
23117 END SUBROUTINE mp_win_create_rv
23118
23119! **************************************************************************************************
23120!> \brief Single-sided get function for vector data
23121!> \param base ...
23122!> \param comm ...
23123!> \param win ...
23124!> \par History
23125!> 02.2015 created [Alfio Lazzaro]
23126!> \note
23127!> arrays can be pointers or assumed shape, but they must be contiguous!
23128! **************************************************************************************************
23129 SUBROUTINE mp_rget_rv(base, source, win, win_data, myproc, disp, request, &
23130 origin_datatype, target_datatype)
23131 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
23132 INTEGER, INTENT(IN) :: source
23133 CLASS(mp_win_type), INTENT(IN) :: win
23134 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: win_data
23135 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
23136 TYPE(mp_request_type), INTENT(OUT) :: request
23137 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
23138
23139 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_rv'
23140
23141 INTEGER :: handle
23142#if defined(__parallel)
23143 INTEGER :: ierr, len, &
23144 origin_len, target_len
23145 LOGICAL :: do_local_copy
23146 INTEGER(kind=mpi_address_kind) :: disp_aint
23147 mpi_data_type :: handle_origin_datatype, handle_target_datatype
23148#endif
23149
23150 CALL mp_timeset(routinen, handle)
23151
23152#if defined(__parallel)
23153 len = SIZE(base)
23154 disp_aint = 0
23155 IF (PRESENT(disp)) THEN
23156 disp_aint = int(disp, kind=mpi_address_kind)
23157 END IF
23158 handle_origin_datatype = mpi_real
23159 origin_len = len
23160 IF (PRESENT(origin_datatype)) THEN
23161 handle_origin_datatype = origin_datatype%type_handle
23162 origin_len = 1
23163 END IF
23164 handle_target_datatype = mpi_real
23165 target_len = len
23166 IF (PRESENT(target_datatype)) THEN
23167 handle_target_datatype = target_datatype%type_handle
23168 target_len = 1
23169 END IF
23170 IF (len > 0) THEN
23171 do_local_copy = .false.
23172 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
23173 IF (myproc .EQ. source) do_local_copy = .true.
23174 END IF
23175 IF (do_local_copy) THEN
23176 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
23177 base(:) = win_data(disp_aint + 1:disp_aint + len)
23178 !$OMP END PARALLEL WORKSHARE
23179 request = mp_request_null
23180 ierr = 0
23181 ELSE
23182 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
23183 target_len, handle_target_datatype, win%handle, request%handle, ierr)
23184 END IF
23185 ELSE
23186 request = mp_request_null
23187 ierr = 0
23188 END IF
23189 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
23190
23191 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*real_4_size)
23192#else
23193 mark_used(source)
23194 mark_used(win)
23195 mark_used(myproc)
23196 mark_used(origin_datatype)
23197 mark_used(target_datatype)
23198
23199 request = mp_request_null
23200 !
23201 IF (PRESENT(disp)) THEN
23202 base(:) = win_data(disp + 1:disp + SIZE(base))
23203 ELSE
23204 base(:) = win_data(:SIZE(base))
23205 END IF
23206
23207#endif
23208 CALL mp_timestop(handle)
23209 END SUBROUTINE mp_rget_rv
23210
23211! **************************************************************************************************
23212!> \brief ...
23213!> \param count ...
23214!> \param lengths ...
23215!> \param displs ...
23216!> \return ...
23217! ***************************************************************************
23218 FUNCTION mp_type_indexed_make_r (count, lengths, displs) &
23219 result(type_descriptor)
23220 INTEGER, INTENT(IN) :: count
23221 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
23222 TYPE(mp_type_descriptor_type) :: type_descriptor
23223
23224 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_r'
23225
23226 INTEGER :: handle
23227#if defined(__parallel)
23228 INTEGER :: ierr
23229#endif
23230
23231 CALL mp_timeset(routinen, handle)
23232
23233#if defined(__parallel)
23234 CALL mpi_type_indexed(count, lengths, displs, mpi_real, &
23235 type_descriptor%type_handle, ierr)
23236 IF (ierr /= 0) &
23237 cpabort("MPI_Type_Indexed @ "//routinen)
23238 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
23239 IF (ierr /= 0) &
23240 cpabort("MPI_Type_commit @ "//routinen)
23241#else
23242 type_descriptor%type_handle = 1
23243#endif
23244 type_descriptor%length = count
23245 NULLIFY (type_descriptor%subtype)
23246 type_descriptor%vector_descriptor(1:2) = 1
23247 type_descriptor%has_indexing = .true.
23248 type_descriptor%index_descriptor%index => lengths
23249 type_descriptor%index_descriptor%chunks => displs
23250
23251 CALL mp_timestop(handle)
23252
23253 END FUNCTION mp_type_indexed_make_r
23254
23255! **************************************************************************************************
23256!> \brief Allocates special parallel memory
23257!> \param[in] DATA pointer to integer array to allocate
23258!> \param[in] len number of integers to allocate
23259!> \param[out] stat (optional) allocation status result
23260!> \author UB
23261! **************************************************************************************************
23262 SUBROUTINE mp_allocate_r (DATA, len, stat)
23263 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23264 INTEGER, INTENT(IN) :: len
23265 INTEGER, INTENT(OUT), OPTIONAL :: stat
23266
23267 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_r'
23268
23269 INTEGER :: handle, ierr
23270
23271 CALL mp_timeset(routinen, handle)
23272
23273#if defined(__parallel)
23274 NULLIFY (data)
23275 CALL mp_alloc_mem(DATA, len, stat=ierr)
23276 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
23277 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
23278 CALL add_perf(perf_id=15, count=1)
23279#else
23280 ALLOCATE (DATA(len), stat=ierr)
23281 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
23282 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
23283#endif
23284 IF (PRESENT(stat)) stat = ierr
23285 CALL mp_timestop(handle)
23286 END SUBROUTINE mp_allocate_r
23287
23288! **************************************************************************************************
23289!> \brief Deallocates special parallel memory
23290!> \param[in] DATA pointer to special memory to deallocate
23291!> \param stat ...
23292!> \author UB
23293! **************************************************************************************************
23294 SUBROUTINE mp_deallocate_r (DATA, stat)
23295 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23296 INTEGER, INTENT(OUT), OPTIONAL :: stat
23297
23298 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_r'
23299
23300 INTEGER :: handle
23301#if defined(__parallel)
23302 INTEGER :: ierr
23303#endif
23304
23305 CALL mp_timeset(routinen, handle)
23306
23307#if defined(__parallel)
23308 CALL mp_free_mem(DATA, ierr)
23309 IF (PRESENT(stat)) THEN
23310 stat = ierr
23311 ELSE
23312 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
23313 END IF
23314 NULLIFY (data)
23315 CALL add_perf(perf_id=15, count=1)
23316#else
23317 DEALLOCATE (data)
23318 IF (PRESENT(stat)) stat = 0
23319#endif
23320 CALL mp_timestop(handle)
23321 END SUBROUTINE mp_deallocate_r
23322
23323! **************************************************************************************************
23324!> \brief (parallel) Blocking individual file write using explicit offsets
23325!> (serial) Unformatted stream write
23326!> \param[in] fh file handle (file storage unit)
23327!> \param[in] offset file offset (position)
23328!> \param[in] msg data to be written to the file
23329!> \param msglen ...
23330!> \par MPI-I/O mapping mpi_file_write_at
23331!> \par STREAM-I/O mapping WRITE
23332!> \param[in](optional) msglen number of the elements of data
23333! **************************************************************************************************
23334 SUBROUTINE mp_file_write_at_rv(fh, offset, msg, msglen)
23335 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
23336 CLASS(mp_file_type), INTENT(IN) :: fh
23337 INTEGER, INTENT(IN), OPTIONAL :: msglen
23338 INTEGER(kind=file_offset), INTENT(IN) :: offset
23339
23340 INTEGER :: msg_len
23341#if defined(__parallel)
23342 INTEGER :: ierr
23343#endif
23344
23345 msg_len = SIZE(msg)
23346 IF (PRESENT(msglen)) msg_len = msglen
23347#if defined(__parallel)
23348 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23349 IF (ierr .NE. 0) &
23350 cpabort("mpi_file_write_at_rv @ mp_file_write_at_rv")
23351#else
23352 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23353#endif
23354 END SUBROUTINE mp_file_write_at_rv
23355
23356! **************************************************************************************************
23357!> \brief ...
23358!> \param fh ...
23359!> \param offset ...
23360!> \param msg ...
23361! **************************************************************************************************
23362 SUBROUTINE mp_file_write_at_r (fh, offset, msg)
23363 REAL(kind=real_4), INTENT(IN) :: msg
23364 CLASS(mp_file_type), INTENT(IN) :: fh
23365 INTEGER(kind=file_offset), INTENT(IN) :: offset
23366
23367#if defined(__parallel)
23368 INTEGER :: ierr
23369
23370 ierr = 0
23371 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23372 IF (ierr .NE. 0) &
23373 cpabort("mpi_file_write_at_r @ mp_file_write_at_r")
23374#else
23375 WRITE (unit=fh%handle, pos=offset + 1) msg
23376#endif
23377 END SUBROUTINE mp_file_write_at_r
23378
23379! **************************************************************************************************
23380!> \brief (parallel) Blocking collective file write using explicit offsets
23381!> (serial) Unformatted stream write
23382!> \param fh ...
23383!> \param offset ...
23384!> \param msg ...
23385!> \param msglen ...
23386!> \par MPI-I/O mapping mpi_file_write_at_all
23387!> \par STREAM-I/O mapping WRITE
23388! **************************************************************************************************
23389 SUBROUTINE mp_file_write_at_all_rv(fh, offset, msg, msglen)
23390 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
23391 CLASS(mp_file_type), INTENT(IN) :: fh
23392 INTEGER, INTENT(IN), OPTIONAL :: msglen
23393 INTEGER(kind=file_offset), INTENT(IN) :: offset
23394
23395 INTEGER :: msg_len
23396#if defined(__parallel)
23397 INTEGER :: ierr
23398#endif
23399
23400 msg_len = SIZE(msg)
23401 IF (PRESENT(msglen)) msg_len = msglen
23402#if defined(__parallel)
23403 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23404 IF (ierr .NE. 0) &
23405 cpabort("mpi_file_write_at_all_rv @ mp_file_write_at_all_rv")
23406#else
23407 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23408#endif
23409 END SUBROUTINE mp_file_write_at_all_rv
23410
23411! **************************************************************************************************
23412!> \brief ...
23413!> \param fh ...
23414!> \param offset ...
23415!> \param msg ...
23416! **************************************************************************************************
23417 SUBROUTINE mp_file_write_at_all_r (fh, offset, msg)
23418 REAL(kind=real_4), INTENT(IN) :: msg
23419 CLASS(mp_file_type), INTENT(IN) :: fh
23420 INTEGER(kind=file_offset), INTENT(IN) :: offset
23421
23422#if defined(__parallel)
23423 INTEGER :: ierr
23424
23425 ierr = 0
23426 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23427 IF (ierr .NE. 0) &
23428 cpabort("mpi_file_write_at_all_r @ mp_file_write_at_all_r")
23429#else
23430 WRITE (unit=fh%handle, pos=offset + 1) msg
23431#endif
23432 END SUBROUTINE mp_file_write_at_all_r
23433
23434! **************************************************************************************************
23435!> \brief (parallel) Blocking individual file read using explicit offsets
23436!> (serial) Unformatted stream read
23437!> \param[in] fh file handle (file storage unit)
23438!> \param[in] offset file offset (position)
23439!> \param[out] msg data to be read from the file
23440!> \param msglen ...
23441!> \par MPI-I/O mapping mpi_file_read_at
23442!> \par STREAM-I/O mapping READ
23443!> \param[in](optional) msglen number of elements of data
23444! **************************************************************************************************
23445 SUBROUTINE mp_file_read_at_rv(fh, offset, msg, msglen)
23446 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
23447 CLASS(mp_file_type), INTENT(IN) :: fh
23448 INTEGER, INTENT(IN), OPTIONAL :: msglen
23449 INTEGER(kind=file_offset), INTENT(IN) :: offset
23450
23451 INTEGER :: msg_len
23452#if defined(__parallel)
23453 INTEGER :: ierr
23454#endif
23455
23456 msg_len = SIZE(msg)
23457 IF (PRESENT(msglen)) msg_len = msglen
23458#if defined(__parallel)
23459 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23460 IF (ierr .NE. 0) &
23461 cpabort("mpi_file_read_at_rv @ mp_file_read_at_rv")
23462#else
23463 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23464#endif
23465 END SUBROUTINE mp_file_read_at_rv
23466
23467! **************************************************************************************************
23468!> \brief ...
23469!> \param fh ...
23470!> \param offset ...
23471!> \param msg ...
23472! **************************************************************************************************
23473 SUBROUTINE mp_file_read_at_r (fh, offset, msg)
23474 REAL(kind=real_4), INTENT(OUT) :: msg
23475 CLASS(mp_file_type), INTENT(IN) :: fh
23476 INTEGER(kind=file_offset), INTENT(IN) :: offset
23477
23478#if defined(__parallel)
23479 INTEGER :: ierr
23480
23481 ierr = 0
23482 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23483 IF (ierr .NE. 0) &
23484 cpabort("mpi_file_read_at_r @ mp_file_read_at_r")
23485#else
23486 READ (unit=fh%handle, pos=offset + 1) msg
23487#endif
23488 END SUBROUTINE mp_file_read_at_r
23489
23490! **************************************************************************************************
23491!> \brief (parallel) Blocking collective file read using explicit offsets
23492!> (serial) Unformatted stream read
23493!> \param fh ...
23494!> \param offset ...
23495!> \param msg ...
23496!> \param msglen ...
23497!> \par MPI-I/O mapping mpi_file_read_at_all
23498!> \par STREAM-I/O mapping READ
23499! **************************************************************************************************
23500 SUBROUTINE mp_file_read_at_all_rv(fh, offset, msg, msglen)
23501 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
23502 CLASS(mp_file_type), INTENT(IN) :: fh
23503 INTEGER, INTENT(IN), OPTIONAL :: msglen
23504 INTEGER(kind=file_offset), INTENT(IN) :: offset
23505
23506 INTEGER :: msg_len
23507#if defined(__parallel)
23508 INTEGER :: ierr
23509#endif
23510
23511 msg_len = SIZE(msg)
23512 IF (PRESENT(msglen)) msg_len = msglen
23513#if defined(__parallel)
23514 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23515 IF (ierr .NE. 0) &
23516 cpabort("mpi_file_read_at_all_rv @ mp_file_read_at_all_rv")
23517#else
23518 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23519#endif
23520 END SUBROUTINE mp_file_read_at_all_rv
23521
23522! **************************************************************************************************
23523!> \brief ...
23524!> \param fh ...
23525!> \param offset ...
23526!> \param msg ...
23527! **************************************************************************************************
23528 SUBROUTINE mp_file_read_at_all_r (fh, offset, msg)
23529 REAL(kind=real_4), INTENT(OUT) :: msg
23530 CLASS(mp_file_type), INTENT(IN) :: fh
23531 INTEGER(kind=file_offset), INTENT(IN) :: offset
23532
23533#if defined(__parallel)
23534 INTEGER :: ierr
23535
23536 ierr = 0
23537 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23538 IF (ierr .NE. 0) &
23539 cpabort("mpi_file_read_at_all_r @ mp_file_read_at_all_r")
23540#else
23541 READ (unit=fh%handle, pos=offset + 1) msg
23542#endif
23543 END SUBROUTINE mp_file_read_at_all_r
23544
23545! **************************************************************************************************
23546!> \brief ...
23547!> \param ptr ...
23548!> \param vector_descriptor ...
23549!> \param index_descriptor ...
23550!> \return ...
23551! **************************************************************************************************
23552 FUNCTION mp_type_make_r (ptr, &
23553 vector_descriptor, index_descriptor) &
23554 result(type_descriptor)
23555 REAL(kind=real_4), DIMENSION(:), TARGET, asynchronous :: ptr
23556 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
23557 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
23558 TYPE(mp_type_descriptor_type) :: type_descriptor
23559
23560 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_r'
23561
23562#if defined(__parallel)
23563 INTEGER :: ierr
23564#if defined(__MPI_F08)
23565 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
23566 EXTERNAL :: mpi_get_address
23567#endif
23568#endif
23569
23570 NULLIFY (type_descriptor%subtype)
23571 type_descriptor%length = SIZE(ptr)
23572#if defined(__parallel)
23573 type_descriptor%type_handle = mpi_real
23574 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
23575 IF (ierr /= 0) &
23576 cpabort("MPI_Get_address @ "//routinen)
23577#else
23578 type_descriptor%type_handle = 1
23579#endif
23580 type_descriptor%vector_descriptor(1:2) = 1
23581 type_descriptor%has_indexing = .false.
23582 type_descriptor%data_r => ptr
23583 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
23584 cpabort(routinen//": Vectors and indices NYI")
23585 END IF
23586 END FUNCTION mp_type_make_r
23587
23588! **************************************************************************************************
23589!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
23590!> as the Fortran version returns an integer, which we take to be a C_PTR
23591!> \param DATA data array to allocate
23592!> \param[in] len length (in data elements) of data array allocation
23593!> \param[out] stat (optional) allocation status result
23594! **************************************************************************************************
23595 SUBROUTINE mp_alloc_mem_r (DATA, len, stat)
23596 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23597 INTEGER, INTENT(IN) :: len
23598 INTEGER, INTENT(OUT), OPTIONAL :: stat
23599
23600#if defined(__parallel)
23601 INTEGER :: size, ierr, length, &
23602 mp_res
23603 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
23604 TYPE(c_ptr) :: mp_baseptr
23605 mpi_info_type :: mp_info
23606
23607 length = max(len, 1)
23608 CALL mpi_type_size(mpi_real, size, ierr)
23609 mp_size = int(length, kind=mpi_address_kind)*size
23610 IF (mp_size .GT. mp_max_memory_size) THEN
23611 cpabort("MPI cannot allocate more than 2 GiByte")
23612 END IF
23613 mp_info = mpi_info_null
23614 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
23615 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
23616 IF (PRESENT(stat)) stat = mp_res
23617#else
23618 INTEGER :: length, mystat
23619 length = max(len, 1)
23620 IF (PRESENT(stat)) THEN
23621 ALLOCATE (DATA(length), stat=mystat)
23622 stat = mystat ! show to convention checker that stat is used
23623 ELSE
23624 ALLOCATE (DATA(length))
23625 END IF
23626#endif
23627 END SUBROUTINE mp_alloc_mem_r
23628
23629! **************************************************************************************************
23630!> \brief Deallocates am array, ... this is hackish
23631!> as the Fortran version takes an integer, which we hope to get by reference
23632!> \param DATA data array to allocate
23633!> \param[out] stat (optional) allocation status result
23634! **************************************************************************************************
23635 SUBROUTINE mp_free_mem_r (DATA, stat)
23636 REAL(kind=real_4), DIMENSION(:), &
23637 POINTER, asynchronous :: DATA
23638 INTEGER, INTENT(OUT), OPTIONAL :: stat
23639
23640#if defined(__parallel)
23641 INTEGER :: mp_res
23642 CALL mpi_free_mem(DATA, mp_res)
23643 IF (PRESENT(stat)) stat = mp_res
23644#else
23645 DEALLOCATE (data)
23646 IF (PRESENT(stat)) stat = 0
23647#endif
23648 END SUBROUTINE mp_free_mem_r
23649! **************************************************************************************************
23650!> \brief Shift around the data in msg
23651!> \param[in,out] msg Rank-2 data to shift
23652!> \param[in] comm message passing environment identifier
23653!> \param[in] displ_in displacements (?)
23654!> \par Example
23655!> msg will be moved from rank to rank+displ_in (in a circular way)
23656!> \par Limitations
23657!> * displ_in will be 1 by default (others not tested)
23658!> * the message array needs to be the same size on all processes
23659! **************************************************************************************************
23660 SUBROUTINE mp_shift_zm(msg, comm, displ_in)
23661
23662 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
23663 CLASS(mp_comm_type), INTENT(IN) :: comm
23664 INTEGER, INTENT(IN), OPTIONAL :: displ_in
23665
23666 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_zm'
23667
23668 INTEGER :: handle, ierror
23669#if defined(__parallel)
23670 INTEGER :: displ, left, &
23671 msglen, myrank, nprocs, &
23672 right, tag
23673#endif
23674
23675 ierror = 0
23676 CALL mp_timeset(routinen, handle)
23677
23678#if defined(__parallel)
23679 CALL mpi_comm_rank(comm%handle, myrank, ierror)
23680 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
23681 CALL mpi_comm_size(comm%handle, nprocs, ierror)
23682 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
23683 IF (PRESENT(displ_in)) THEN
23684 displ = displ_in
23685 ELSE
23686 displ = 1
23687 END IF
23688 right = modulo(myrank + displ, nprocs)
23689 left = modulo(myrank - displ, nprocs)
23690 tag = 17
23691 msglen = SIZE(msg)
23692 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_complex, right, tag, left, tag, &
23693 comm%handle, mpi_status_ignore, ierror)
23694 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
23695 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_8_size))
23696#else
23697 mark_used(msg)
23698 mark_used(comm)
23699 mark_used(displ_in)
23700#endif
23701 CALL mp_timestop(handle)
23702
23703 END SUBROUTINE mp_shift_zm
23704
23705! **************************************************************************************************
23706!> \brief Shift around the data in msg
23707!> \param[in,out] msg Data to shift
23708!> \param[in] comm message passing environment identifier
23709!> \param[in] displ_in displacements (?)
23710!> \par Example
23711!> msg will be moved from rank to rank+displ_in (in a circular way)
23712!> \par Limitations
23713!> * displ_in will be 1 by default (others not tested)
23714!> * the message array needs to be the same size on all processes
23715! **************************************************************************************************
23716 SUBROUTINE mp_shift_z (msg, comm, displ_in)
23717
23718 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
23719 CLASS(mp_comm_type), INTENT(IN) :: comm
23720 INTEGER, INTENT(IN), OPTIONAL :: displ_in
23721
23722 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_z'
23723
23724 INTEGER :: handle, ierror
23725#if defined(__parallel)
23726 INTEGER :: displ, left, &
23727 msglen, myrank, nprocs, &
23728 right, tag
23729#endif
23730
23731 ierror = 0
23732 CALL mp_timeset(routinen, handle)
23733
23734#if defined(__parallel)
23735 CALL mpi_comm_rank(comm%handle, myrank, ierror)
23736 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
23737 CALL mpi_comm_size(comm%handle, nprocs, ierror)
23738 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
23739 IF (PRESENT(displ_in)) THEN
23740 displ = displ_in
23741 ELSE
23742 displ = 1
23743 END IF
23744 right = modulo(myrank + displ, nprocs)
23745 left = modulo(myrank - displ, nprocs)
23746 tag = 19
23747 msglen = SIZE(msg)
23748 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_complex, right, tag, left, &
23749 tag, comm%handle, mpi_status_ignore, ierror)
23750 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
23751 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_8_size))
23752#else
23753 mark_used(msg)
23754 mark_used(comm)
23755 mark_used(displ_in)
23756#endif
23757 CALL mp_timestop(handle)
23758
23759 END SUBROUTINE mp_shift_z
23760
23761! **************************************************************************************************
23762!> \brief All-to-all data exchange, rank-1 data of different sizes
23763!> \param[in] sb Data to send
23764!> \param[in] scount Data counts for data sent to other processes
23765!> \param[in] sdispl Respective data offsets for data sent to process
23766!> \param[in,out] rb Buffer into which to receive data
23767!> \param[in] rcount Data counts for data received from other
23768!> processes
23769!> \param[in] rdispl Respective data offsets for data received from
23770!> other processes
23771!> \param[in] comm Message passing environment identifier
23772!> \par MPI mapping
23773!> mpi_alltoallv
23774!> \par Array sizes
23775!> The scount, rcount, and the sdispl and rdispl arrays have a
23776!> size equal to the number of processes.
23777!> \par Offsets
23778!> Values in sdispl and rdispl start with 0.
23779! **************************************************************************************************
23780 SUBROUTINE mp_alltoall_z11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
23781
23782 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
23783 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
23784 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
23785 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
23786 CLASS(mp_comm_type), INTENT(IN) :: comm
23787
23788 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z11v'
23789
23790 INTEGER :: handle
23791#if defined(__parallel)
23792 INTEGER :: ierr, msglen
23793#else
23794 INTEGER :: i
23795#endif
23796
23797 CALL mp_timeset(routinen, handle)
23798
23799#if defined(__parallel)
23800 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_complex, &
23801 rb, rcount, rdispl, mpi_double_complex, comm%handle, ierr)
23802 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
23803 msglen = sum(scount) + sum(rcount)
23804 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
23805#else
23806 mark_used(comm)
23807 mark_used(scount)
23808 mark_used(sdispl)
23809 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
23810 DO i = 1, rcount(1)
23811 rb(rdispl(1) + i) = sb(sdispl(1) + i)
23812 END DO
23813#endif
23814 CALL mp_timestop(handle)
23815
23816 END SUBROUTINE mp_alltoall_z11v
23817
23818! **************************************************************************************************
23819!> \brief All-to-all data exchange, rank-2 data of different sizes
23820!> \param sb ...
23821!> \param scount ...
23822!> \param sdispl ...
23823!> \param rb ...
23824!> \param rcount ...
23825!> \param rdispl ...
23826!> \param comm ...
23827!> \par MPI mapping
23828!> mpi_alltoallv
23829!> \note see mp_alltoall_z11v
23830! **************************************************************************************************
23831 SUBROUTINE mp_alltoall_z22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
23832
23833 COMPLEX(kind=real_8), DIMENSION(:, :), &
23834 INTENT(IN), CONTIGUOUS :: sb
23835 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
23836 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, &
23837 INTENT(INOUT) :: rb
23838 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
23839 CLASS(mp_comm_type), INTENT(IN) :: comm
23840
23841 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z22v'
23842
23843 INTEGER :: handle
23844#if defined(__parallel)
23845 INTEGER :: ierr, msglen
23846#endif
23847
23848 CALL mp_timeset(routinen, handle)
23849
23850#if defined(__parallel)
23851 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_complex, &
23852 rb, rcount, rdispl, mpi_double_complex, comm%handle, ierr)
23853 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
23854 msglen = sum(scount) + sum(rcount)
23855 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*(2*real_8_size))
23856#else
23857 mark_used(comm)
23858 mark_used(scount)
23859 mark_used(sdispl)
23860 mark_used(rcount)
23861 mark_used(rdispl)
23862 rb = sb
23863#endif
23864 CALL mp_timestop(handle)
23865
23866 END SUBROUTINE mp_alltoall_z22v
23867
23868! **************************************************************************************************
23869!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
23870!> \param[in] sb array with data to send
23871!> \param[out] rb array into which data is received
23872!> \param[in] count number of elements to send/receive (product of the
23873!> extents of the first two dimensions)
23874!> \param[in] comm Message passing environment identifier
23875!> \par Index meaning
23876!> \par The first two indices specify the data while the last index counts
23877!> the processes
23878!> \par Sizes of ranks
23879!> All processes have the same data size.
23880!> \par MPI mapping
23881!> mpi_alltoall
23882! **************************************************************************************************
23883 SUBROUTINE mp_alltoall_z (sb, rb, count, comm)
23884
23885 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
23886 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
23887 INTEGER, INTENT(IN) :: count
23888 CLASS(mp_comm_type), INTENT(IN) :: comm
23889
23890 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z'
23891
23892 INTEGER :: handle
23893#if defined(__parallel)
23894 INTEGER :: ierr, msglen, np
23895#endif
23896
23897 CALL mp_timeset(routinen, handle)
23898
23899#if defined(__parallel)
23900 CALL mpi_alltoall(sb, count, mpi_double_complex, &
23901 rb, count, mpi_double_complex, comm%handle, ierr)
23902 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
23903 CALL mpi_comm_size(comm%handle, np, ierr)
23904 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
23905 msglen = 2*count*np
23906 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
23907#else
23908 mark_used(count)
23909 mark_used(comm)
23910 rb = sb
23911#endif
23912 CALL mp_timestop(handle)
23913
23914 END SUBROUTINE mp_alltoall_z
23915
23916! **************************************************************************************************
23917!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
23918!> \param sb ...
23919!> \param rb ...
23920!> \param count ...
23921!> \param commp ...
23922!> \note see mp_alltoall_z
23923! **************************************************************************************************
23924 SUBROUTINE mp_alltoall_z22(sb, rb, count, comm)
23925
23926 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
23927 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
23928 INTEGER, INTENT(IN) :: count
23929 CLASS(mp_comm_type), INTENT(IN) :: comm
23930
23931 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z22'
23932
23933 INTEGER :: handle
23934#if defined(__parallel)
23935 INTEGER :: ierr, msglen, np
23936#endif
23937
23938 CALL mp_timeset(routinen, handle)
23939
23940#if defined(__parallel)
23941 CALL mpi_alltoall(sb, count, mpi_double_complex, &
23942 rb, count, mpi_double_complex, comm%handle, ierr)
23943 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
23944 CALL mpi_comm_size(comm%handle, np, ierr)
23945 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
23946 msglen = 2*SIZE(sb)*np
23947 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
23948#else
23949 mark_used(count)
23950 mark_used(comm)
23951 rb = sb
23952#endif
23953 CALL mp_timestop(handle)
23954
23955 END SUBROUTINE mp_alltoall_z22
23956
23957! **************************************************************************************************
23958!> \brief All-to-all data exchange, rank-3 data with equal sizes
23959!> \param sb ...
23960!> \param rb ...
23961!> \param count ...
23962!> \param comm ...
23963!> \note see mp_alltoall_z
23964! **************************************************************************************************
23965 SUBROUTINE mp_alltoall_z33(sb, rb, count, comm)
23966
23967 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
23968 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
23969 INTEGER, INTENT(IN) :: count
23970 CLASS(mp_comm_type), INTENT(IN) :: comm
23971
23972 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z33'
23973
23974 INTEGER :: handle
23975#if defined(__parallel)
23976 INTEGER :: ierr, msglen, np
23977#endif
23978
23979 CALL mp_timeset(routinen, handle)
23980
23981#if defined(__parallel)
23982 CALL mpi_alltoall(sb, count, mpi_double_complex, &
23983 rb, count, mpi_double_complex, comm%handle, ierr)
23984 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
23985 CALL mpi_comm_size(comm%handle, np, ierr)
23986 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
23987 msglen = 2*count*np
23988 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
23989#else
23990 mark_used(count)
23991 mark_used(comm)
23992 rb = sb
23993#endif
23994 CALL mp_timestop(handle)
23995
23996 END SUBROUTINE mp_alltoall_z33
23997
23998! **************************************************************************************************
23999!> \brief All-to-all data exchange, rank 4 data, equal sizes
24000!> \param sb ...
24001!> \param rb ...
24002!> \param count ...
24003!> \param comm ...
24004!> \note see mp_alltoall_z
24005! **************************************************************************************************
24006 SUBROUTINE mp_alltoall_z44(sb, rb, count, comm)
24007
24008 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24009 INTENT(IN) :: sb
24010 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24011 INTENT(OUT) :: rb
24012 INTEGER, INTENT(IN) :: count
24013 CLASS(mp_comm_type), INTENT(IN) :: comm
24014
24015 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z44'
24016
24017 INTEGER :: handle
24018#if defined(__parallel)
24019 INTEGER :: ierr, msglen, np
24020#endif
24021
24022 CALL mp_timeset(routinen, handle)
24023
24024#if defined(__parallel)
24025 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24026 rb, count, mpi_double_complex, comm%handle, ierr)
24027 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24028 CALL mpi_comm_size(comm%handle, np, ierr)
24029 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24030 msglen = 2*count*np
24031 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24032#else
24033 mark_used(count)
24034 mark_used(comm)
24035 rb = sb
24036#endif
24037 CALL mp_timestop(handle)
24038
24039 END SUBROUTINE mp_alltoall_z44
24040
24041! **************************************************************************************************
24042!> \brief All-to-all data exchange, rank 5 data, equal sizes
24043!> \param sb ...
24044!> \param rb ...
24045!> \param count ...
24046!> \param comm ...
24047!> \note see mp_alltoall_z
24048! **************************************************************************************************
24049 SUBROUTINE mp_alltoall_z55(sb, rb, count, comm)
24050
24051 COMPLEX(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
24052 INTENT(IN) :: sb
24053 COMPLEX(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
24054 INTENT(OUT) :: rb
24055 INTEGER, INTENT(IN) :: count
24056 CLASS(mp_comm_type), INTENT(IN) :: comm
24057
24058 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z55'
24059
24060 INTEGER :: handle
24061#if defined(__parallel)
24062 INTEGER :: ierr, msglen, np
24063#endif
24064
24065 CALL mp_timeset(routinen, handle)
24066
24067#if defined(__parallel)
24068 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24069 rb, count, mpi_double_complex, comm%handle, ierr)
24070 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24071 CALL mpi_comm_size(comm%handle, np, ierr)
24072 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24073 msglen = 2*count*np
24074 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24075#else
24076 mark_used(count)
24077 mark_used(comm)
24078 rb = sb
24079#endif
24080 CALL mp_timestop(handle)
24081
24082 END SUBROUTINE mp_alltoall_z55
24083
24084! **************************************************************************************************
24085!> \brief All-to-all data exchange, rank-4 data to rank-5 data
24086!> \param sb ...
24087!> \param rb ...
24088!> \param count ...
24089!> \param comm ...
24090!> \note see mp_alltoall_z
24091!> \note User must ensure size consistency.
24092! **************************************************************************************************
24093 SUBROUTINE mp_alltoall_z45(sb, rb, count, comm)
24094
24095 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24096 INTENT(IN) :: sb
24097 COMPLEX(kind=real_8), &
24098 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
24099 INTEGER, INTENT(IN) :: count
24100 CLASS(mp_comm_type), INTENT(IN) :: comm
24101
24102 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z45'
24103
24104 INTEGER :: handle
24105#if defined(__parallel)
24106 INTEGER :: ierr, msglen, np
24107#endif
24108
24109 CALL mp_timeset(routinen, handle)
24110
24111#if defined(__parallel)
24112 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24113 rb, count, mpi_double_complex, comm%handle, ierr)
24114 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24115 CALL mpi_comm_size(comm%handle, np, ierr)
24116 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24117 msglen = 2*count*np
24118 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24119#else
24120 mark_used(count)
24121 mark_used(comm)
24122 rb = reshape(sb, shape(rb))
24123#endif
24124 CALL mp_timestop(handle)
24125
24126 END SUBROUTINE mp_alltoall_z45
24127
24128! **************************************************************************************************
24129!> \brief All-to-all data exchange, rank-3 data to rank-4 data
24130!> \param sb ...
24131!> \param rb ...
24132!> \param count ...
24133!> \param comm ...
24134!> \note see mp_alltoall_z
24135!> \note User must ensure size consistency.
24136! **************************************************************************************************
24137 SUBROUTINE mp_alltoall_z34(sb, rb, count, comm)
24138
24139 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, &
24140 INTENT(IN) :: sb
24141 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24142 INTENT(OUT) :: rb
24143 INTEGER, INTENT(IN) :: count
24144 CLASS(mp_comm_type), INTENT(IN) :: comm
24145
24146 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z34'
24147
24148 INTEGER :: handle
24149#if defined(__parallel)
24150 INTEGER :: ierr, msglen, np
24151#endif
24152
24153 CALL mp_timeset(routinen, handle)
24154
24155#if defined(__parallel)
24156 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24157 rb, count, mpi_double_complex, comm%handle, ierr)
24158 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24159 CALL mpi_comm_size(comm%handle, np, ierr)
24160 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24161 msglen = 2*count*np
24162 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24163#else
24164 mark_used(count)
24165 mark_used(comm)
24166 rb = reshape(sb, shape(rb))
24167#endif
24168 CALL mp_timestop(handle)
24169
24170 END SUBROUTINE mp_alltoall_z34
24171
24172! **************************************************************************************************
24173!> \brief All-to-all data exchange, rank-5 data to rank-4 data
24174!> \param sb ...
24175!> \param rb ...
24176!> \param count ...
24177!> \param comm ...
24178!> \note see mp_alltoall_z
24179!> \note User must ensure size consistency.
24180! **************************************************************************************************
24181 SUBROUTINE mp_alltoall_z54(sb, rb, count, comm)
24182
24183 COMPLEX(kind=real_8), &
24184 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
24185 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24186 INTENT(OUT) :: rb
24187 INTEGER, INTENT(IN) :: count
24188 CLASS(mp_comm_type), INTENT(IN) :: comm
24189
24190 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z54'
24191
24192 INTEGER :: handle
24193#if defined(__parallel)
24194 INTEGER :: ierr, msglen, np
24195#endif
24196
24197 CALL mp_timeset(routinen, handle)
24198
24199#if defined(__parallel)
24200 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24201 rb, count, mpi_double_complex, comm%handle, ierr)
24202 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24203 CALL mpi_comm_size(comm%handle, np, ierr)
24204 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24205 msglen = 2*count*np
24206 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24207#else
24208 mark_used(count)
24209 mark_used(comm)
24210 rb = reshape(sb, shape(rb))
24211#endif
24212 CALL mp_timestop(handle)
24213
24214 END SUBROUTINE mp_alltoall_z54
24215
24216! **************************************************************************************************
24217!> \brief Send one datum to another process
24218!> \param[in] msg Scalar to send
24219!> \param[in] dest Destination process
24220!> \param[in] tag Transfer identifier
24221!> \param[in] comm Message passing environment identifier
24222!> \par MPI mapping
24223!> mpi_send
24224! **************************************************************************************************
24225 SUBROUTINE mp_send_z (msg, dest, tag, comm)
24226 COMPLEX(kind=real_8), INTENT(IN) :: msg
24227 INTEGER, INTENT(IN) :: dest, tag
24228 CLASS(mp_comm_type), INTENT(IN) :: comm
24229
24230 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_z'
24231
24232 INTEGER :: handle
24233#if defined(__parallel)
24234 INTEGER :: ierr, msglen
24235#endif
24236
24237 CALL mp_timeset(routinen, handle)
24238
24239#if defined(__parallel)
24240 msglen = 1
24241 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24242 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24243 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24244#else
24245 mark_used(msg)
24246 mark_used(dest)
24247 mark_used(tag)
24248 mark_used(comm)
24249 ! only defined in parallel
24250 cpabort("not in parallel mode")
24251#endif
24252 CALL mp_timestop(handle)
24253 END SUBROUTINE mp_send_z
24254
24255! **************************************************************************************************
24256!> \brief Send rank-1 data to another process
24257!> \param[in] msg Rank-1 data to send
24258!> \param dest ...
24259!> \param tag ...
24260!> \param comm ...
24261!> \note see mp_send_z
24262! **************************************************************************************************
24263 SUBROUTINE mp_send_zv(msg, dest, tag, comm)
24264 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
24265 INTEGER, INTENT(IN) :: dest, tag
24266 CLASS(mp_comm_type), INTENT(IN) :: comm
24267
24268 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_zv'
24269
24270 INTEGER :: handle
24271#if defined(__parallel)
24272 INTEGER :: ierr, msglen
24273#endif
24274
24275 CALL mp_timeset(routinen, handle)
24276
24277#if defined(__parallel)
24278 msglen = SIZE(msg)
24279 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24280 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24281 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24282#else
24283 mark_used(msg)
24284 mark_used(dest)
24285 mark_used(tag)
24286 mark_used(comm)
24287 ! only defined in parallel
24288 cpabort("not in parallel mode")
24289#endif
24290 CALL mp_timestop(handle)
24291 END SUBROUTINE mp_send_zv
24292
24293! **************************************************************************************************
24294!> \brief Send rank-2 data to another process
24295!> \param[in] msg Rank-2 data to send
24296!> \param dest ...
24297!> \param tag ...
24298!> \param comm ...
24299!> \note see mp_send_z
24300! **************************************************************************************************
24301 SUBROUTINE mp_send_zm2(msg, dest, tag, comm)
24302 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
24303 INTEGER, INTENT(IN) :: dest, tag
24304 CLASS(mp_comm_type), INTENT(IN) :: comm
24305
24306 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_zm2'
24307
24308 INTEGER :: handle
24309#if defined(__parallel)
24310 INTEGER :: ierr, msglen
24311#endif
24312
24313 CALL mp_timeset(routinen, handle)
24314
24315#if defined(__parallel)
24316 msglen = SIZE(msg)
24317 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24318 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24319 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24320#else
24321 mark_used(msg)
24322 mark_used(dest)
24323 mark_used(tag)
24324 mark_used(comm)
24325 ! only defined in parallel
24326 cpabort("not in parallel mode")
24327#endif
24328 CALL mp_timestop(handle)
24329 END SUBROUTINE mp_send_zm2
24330
24331! **************************************************************************************************
24332!> \brief Send rank-3 data to another process
24333!> \param[in] msg Rank-3 data to send
24334!> \param dest ...
24335!> \param tag ...
24336!> \param comm ...
24337!> \note see mp_send_z
24338! **************************************************************************************************
24339 SUBROUTINE mp_send_zm3(msg, dest, tag, comm)
24340 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
24341 INTEGER, INTENT(IN) :: dest, tag
24342 CLASS(mp_comm_type), INTENT(IN) :: comm
24343
24344 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
24345
24346 INTEGER :: handle
24347#if defined(__parallel)
24348 INTEGER :: ierr, msglen
24349#endif
24350
24351 CALL mp_timeset(routinen, handle)
24352
24353#if defined(__parallel)
24354 msglen = SIZE(msg)
24355 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24356 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24357 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24358#else
24359 mark_used(msg)
24360 mark_used(dest)
24361 mark_used(tag)
24362 mark_used(comm)
24363 ! only defined in parallel
24364 cpabort("not in parallel mode")
24365#endif
24366 CALL mp_timestop(handle)
24367 END SUBROUTINE mp_send_zm3
24368
24369! **************************************************************************************************
24370!> \brief Receive one datum from another process
24371!> \param[in,out] msg Place received data into this variable
24372!> \param[in,out] source Process to receive from
24373!> \param[in,out] tag Transfer identifier
24374!> \param[in] comm Message passing environment identifier
24375!> \par MPI mapping
24376!> mpi_send
24377! **************************************************************************************************
24378 SUBROUTINE mp_recv_z (msg, source, tag, comm)
24379 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24380 INTEGER, INTENT(INOUT) :: source, tag
24381 CLASS(mp_comm_type), INTENT(IN) :: comm
24382
24383 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_z'
24384
24385 INTEGER :: handle
24386#if defined(__parallel)
24387 INTEGER :: ierr, msglen
24388 mpi_status_type :: status
24389#endif
24390
24391 CALL mp_timeset(routinen, handle)
24392
24393#if defined(__parallel)
24394 msglen = 1
24395 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24396 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24397 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24398 ELSE
24399 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24400 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24401 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24402 source = status mpi_status_extract(mpi_source)
24403 tag = status mpi_status_extract(mpi_tag)
24404 END IF
24405#else
24406 mark_used(msg)
24407 mark_used(source)
24408 mark_used(tag)
24409 mark_used(comm)
24410 ! only defined in parallel
24411 cpabort("not in parallel mode")
24412#endif
24413 CALL mp_timestop(handle)
24414 END SUBROUTINE mp_recv_z
24415
24416! **************************************************************************************************
24417!> \brief Receive rank-1 data from another process
24418!> \param[in,out] msg Place received data into this rank-1 array
24419!> \param source ...
24420!> \param tag ...
24421!> \param comm ...
24422!> \note see mp_recv_z
24423! **************************************************************************************************
24424 SUBROUTINE mp_recv_zv(msg, source, tag, comm)
24425 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24426 INTEGER, INTENT(INOUT) :: source, tag
24427 CLASS(mp_comm_type), INTENT(IN) :: comm
24428
24429 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zv'
24430
24431 INTEGER :: handle
24432#if defined(__parallel)
24433 INTEGER :: ierr, msglen
24434 mpi_status_type :: status
24435#endif
24436
24437 CALL mp_timeset(routinen, handle)
24438
24439#if defined(__parallel)
24440 msglen = SIZE(msg)
24441 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24442 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24443 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24444 ELSE
24445 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24446 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24447 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24448 source = status mpi_status_extract(mpi_source)
24449 tag = status mpi_status_extract(mpi_tag)
24450 END IF
24451#else
24452 mark_used(msg)
24453 mark_used(source)
24454 mark_used(tag)
24455 mark_used(comm)
24456 ! only defined in parallel
24457 cpabort("not in parallel mode")
24458#endif
24459 CALL mp_timestop(handle)
24460 END SUBROUTINE mp_recv_zv
24461
24462! **************************************************************************************************
24463!> \brief Receive rank-2 data from another process
24464!> \param[in,out] msg Place received data into this rank-2 array
24465!> \param source ...
24466!> \param tag ...
24467!> \param comm ...
24468!> \note see mp_recv_z
24469! **************************************************************************************************
24470 SUBROUTINE mp_recv_zm2(msg, source, tag, comm)
24471 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24472 INTEGER, INTENT(INOUT) :: source, tag
24473 CLASS(mp_comm_type), INTENT(IN) :: comm
24474
24475 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zm2'
24476
24477 INTEGER :: handle
24478#if defined(__parallel)
24479 INTEGER :: ierr, msglen
24480 mpi_status_type :: status
24481#endif
24482
24483 CALL mp_timeset(routinen, handle)
24484
24485#if defined(__parallel)
24486 msglen = SIZE(msg)
24487 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24488 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24489 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24490 ELSE
24491 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24492 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24493 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24494 source = status mpi_status_extract(mpi_source)
24495 tag = status mpi_status_extract(mpi_tag)
24496 END IF
24497#else
24498 mark_used(msg)
24499 mark_used(source)
24500 mark_used(tag)
24501 mark_used(comm)
24502 ! only defined in parallel
24503 cpabort("not in parallel mode")
24504#endif
24505 CALL mp_timestop(handle)
24506 END SUBROUTINE mp_recv_zm2
24507
24508! **************************************************************************************************
24509!> \brief Receive rank-3 data from another process
24510!> \param[in,out] msg Place received data into this rank-3 array
24511!> \param source ...
24512!> \param tag ...
24513!> \param comm ...
24514!> \note see mp_recv_z
24515! **************************************************************************************************
24516 SUBROUTINE mp_recv_zm3(msg, source, tag, comm)
24517 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
24518 INTEGER, INTENT(INOUT) :: source, tag
24519 CLASS(mp_comm_type), INTENT(IN) :: comm
24520
24521 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zm3'
24522
24523 INTEGER :: handle
24524#if defined(__parallel)
24525 INTEGER :: ierr, msglen
24526 mpi_status_type :: status
24527#endif
24528
24529 CALL mp_timeset(routinen, handle)
24530
24531#if defined(__parallel)
24532 msglen = SIZE(msg)
24533 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24534 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24535 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24536 ELSE
24537 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24538 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24539 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24540 source = status mpi_status_extract(mpi_source)
24541 tag = status mpi_status_extract(mpi_tag)
24542 END IF
24543#else
24544 mark_used(msg)
24545 mark_used(source)
24546 mark_used(tag)
24547 mark_used(comm)
24548 ! only defined in parallel
24549 cpabort("not in parallel mode")
24550#endif
24551 CALL mp_timestop(handle)
24552 END SUBROUTINE mp_recv_zm3
24553
24554! **************************************************************************************************
24555!> \brief Broadcasts a datum to all processes.
24556!> \param[in] msg Datum to broadcast
24557!> \param[in] source Processes which broadcasts
24558!> \param[in] comm Message passing environment identifier
24559!> \par MPI mapping
24560!> mpi_bcast
24561! **************************************************************************************************
24562 SUBROUTINE mp_bcast_z (msg, source, comm)
24563 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24564 INTEGER, INTENT(IN) :: source
24565 CLASS(mp_comm_type), INTENT(IN) :: comm
24566
24567 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z'
24568
24569 INTEGER :: handle
24570#if defined(__parallel)
24571 INTEGER :: ierr, msglen
24572#endif
24573
24574 CALL mp_timeset(routinen, handle)
24575
24576#if defined(__parallel)
24577 msglen = 1
24578 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24579 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24580 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24581#else
24582 mark_used(msg)
24583 mark_used(source)
24584 mark_used(comm)
24585#endif
24586 CALL mp_timestop(handle)
24587 END SUBROUTINE mp_bcast_z
24588
24589! **************************************************************************************************
24590!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
24591!> \param[in] msg Datum to broadcast
24592!> \param[in] comm Message passing environment identifier
24593!> \par MPI mapping
24594!> mpi_bcast
24595! **************************************************************************************************
24596 SUBROUTINE mp_bcast_z_src(msg, comm)
24597 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24598 CLASS(mp_comm_type), INTENT(IN) :: comm
24599
24600 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z_src'
24601
24602 INTEGER :: handle
24603#if defined(__parallel)
24604 INTEGER :: ierr, msglen
24605#endif
24606
24607 CALL mp_timeset(routinen, handle)
24608
24609#if defined(__parallel)
24610 msglen = 1
24611 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24612 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24613 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24614#else
24615 mark_used(msg)
24616 mark_used(comm)
24617#endif
24618 CALL mp_timestop(handle)
24619 END SUBROUTINE mp_bcast_z_src
24620
24621! **************************************************************************************************
24622!> \brief Broadcasts a datum to all processes.
24623!> \param[in] msg Datum to broadcast
24624!> \param[in] source Processes which broadcasts
24625!> \param[in] comm Message passing environment identifier
24626!> \par MPI mapping
24627!> mpi_bcast
24628! **************************************************************************************************
24629 SUBROUTINE mp_ibcast_z (msg, source, comm, request)
24630 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24631 INTEGER, INTENT(IN) :: source
24632 CLASS(mp_comm_type), INTENT(IN) :: comm
24633 TYPE(mp_request_type), INTENT(OUT) :: request
24634
24635 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_z'
24636
24637 INTEGER :: handle
24638#if defined(__parallel)
24639 INTEGER :: ierr, msglen
24640#endif
24641
24642 CALL mp_timeset(routinen, handle)
24643
24644#if defined(__parallel)
24645 msglen = 1
24646 CALL mpi_ibcast(msg, msglen, mpi_double_complex, source, comm%handle, request%handle, ierr)
24647 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
24648 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_8_size))
24649#else
24650 mark_used(msg)
24651 mark_used(source)
24652 mark_used(comm)
24653 request = mp_request_null
24654#endif
24655 CALL mp_timestop(handle)
24656 END SUBROUTINE mp_ibcast_z
24657
24658! **************************************************************************************************
24659!> \brief Broadcasts rank-1 data to all processes
24660!> \param[in] msg Data to broadcast
24661!> \param source ...
24662!> \param comm ...
24663!> \note see mp_bcast_z1
24664! **************************************************************************************************
24665 SUBROUTINE mp_bcast_zv(msg, source, comm)
24666 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24667 INTEGER, INTENT(IN) :: source
24668 CLASS(mp_comm_type), INTENT(IN) :: comm
24669
24670 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zv'
24671
24672 INTEGER :: handle
24673#if defined(__parallel)
24674 INTEGER :: ierr, msglen
24675#endif
24676
24677 CALL mp_timeset(routinen, handle)
24678
24679#if defined(__parallel)
24680 msglen = SIZE(msg)
24681 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24682 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24683 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24684#else
24685 mark_used(msg)
24686 mark_used(source)
24687 mark_used(comm)
24688#endif
24689 CALL mp_timestop(handle)
24690 END SUBROUTINE mp_bcast_zv
24691
24692! **************************************************************************************************
24693!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
24694!> \param[in] msg Data to broadcast
24695!> \param comm ...
24696!> \note see mp_bcast_z1
24697! **************************************************************************************************
24698 SUBROUTINE mp_bcast_zv_src(msg, comm)
24699 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24700 CLASS(mp_comm_type), INTENT(IN) :: comm
24701
24702 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zv_src'
24703
24704 INTEGER :: handle
24705#if defined(__parallel)
24706 INTEGER :: ierr, msglen
24707#endif
24708
24709 CALL mp_timeset(routinen, handle)
24710
24711#if defined(__parallel)
24712 msglen = SIZE(msg)
24713 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24714 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24715 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24716#else
24717 mark_used(msg)
24718 mark_used(comm)
24719#endif
24720 CALL mp_timestop(handle)
24721 END SUBROUTINE mp_bcast_zv_src
24722
24723! **************************************************************************************************
24724!> \brief Broadcasts rank-1 data to all processes
24725!> \param[in] msg Data to broadcast
24726!> \param source ...
24727!> \param comm ...
24728!> \note see mp_bcast_z1
24729! **************************************************************************************************
24730 SUBROUTINE mp_ibcast_zv(msg, source, comm, request)
24731 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
24732 INTEGER, INTENT(IN) :: source
24733 CLASS(mp_comm_type), INTENT(IN) :: comm
24734 TYPE(mp_request_type) :: request
24735
24736 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_zv'
24737
24738 INTEGER :: handle
24739#if defined(__parallel)
24740 INTEGER :: ierr, msglen
24741#endif
24742
24743 CALL mp_timeset(routinen, handle)
24744
24745#if defined(__parallel)
24746#if !defined(__GNUC__) || __GNUC__ >= 9
24747 cpassert(is_contiguous(msg))
24748#endif
24749 msglen = SIZE(msg)
24750 CALL mpi_ibcast(msg, msglen, mpi_double_complex, source, comm%handle, request%handle, ierr)
24751 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
24752 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_8_size))
24753#else
24754 mark_used(msg)
24755 mark_used(source)
24756 mark_used(comm)
24757 request = mp_request_null
24758#endif
24759 CALL mp_timestop(handle)
24760 END SUBROUTINE mp_ibcast_zv
24761
24762! **************************************************************************************************
24763!> \brief Broadcasts rank-2 data to all processes
24764!> \param[in] msg Data to broadcast
24765!> \param source ...
24766!> \param comm ...
24767!> \note see mp_bcast_z1
24768! **************************************************************************************************
24769 SUBROUTINE mp_bcast_zm(msg, source, comm)
24770 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24771 INTEGER, INTENT(IN) :: source
24772 CLASS(mp_comm_type), INTENT(IN) :: comm
24773
24774 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zm'
24775
24776 INTEGER :: handle
24777#if defined(__parallel)
24778 INTEGER :: ierr, msglen
24779#endif
24780
24781 CALL mp_timeset(routinen, handle)
24782
24783#if defined(__parallel)
24784 msglen = SIZE(msg)
24785 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24786 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24787 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24788#else
24789 mark_used(msg)
24790 mark_used(source)
24791 mark_used(comm)
24792#endif
24793 CALL mp_timestop(handle)
24794 END SUBROUTINE mp_bcast_zm
24795
24796! **************************************************************************************************
24797!> \brief Broadcasts rank-2 data to all processes
24798!> \param[in] msg Data to broadcast
24799!> \param source ...
24800!> \param comm ...
24801!> \note see mp_bcast_z1
24802! **************************************************************************************************
24803 SUBROUTINE mp_bcast_zm_src(msg, comm)
24804 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24805 CLASS(mp_comm_type), INTENT(IN) :: comm
24806
24807 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zm_src'
24808
24809 INTEGER :: handle
24810#if defined(__parallel)
24811 INTEGER :: ierr, msglen
24812#endif
24813
24814 CALL mp_timeset(routinen, handle)
24815
24816#if defined(__parallel)
24817 msglen = SIZE(msg)
24818 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24819 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24820 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24821#else
24822 mark_used(msg)
24823 mark_used(comm)
24824#endif
24825 CALL mp_timestop(handle)
24826 END SUBROUTINE mp_bcast_zm_src
24827
24828! **************************************************************************************************
24829!> \brief Broadcasts rank-3 data to all processes
24830!> \param[in] msg Data to broadcast
24831!> \param source ...
24832!> \param comm ...
24833!> \note see mp_bcast_z1
24834! **************************************************************************************************
24835 SUBROUTINE mp_bcast_z3(msg, source, comm)
24836 COMPLEX(kind=real_8), CONTIGUOUS :: msg(:, :, :)
24837 INTEGER, INTENT(IN) :: source
24838 CLASS(mp_comm_type), INTENT(IN) :: comm
24839
24840 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z3'
24841
24842 INTEGER :: handle
24843#if defined(__parallel)
24844 INTEGER :: ierr, msglen
24845#endif
24846
24847 CALL mp_timeset(routinen, handle)
24848
24849#if defined(__parallel)
24850 msglen = SIZE(msg)
24851 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24852 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24853 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24854#else
24855 mark_used(msg)
24856 mark_used(source)
24857 mark_used(comm)
24858#endif
24859 CALL mp_timestop(handle)
24860 END SUBROUTINE mp_bcast_z3
24861
24862! **************************************************************************************************
24863!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
24864!> \param[in] msg Data to broadcast
24865!> \param source ...
24866!> \param comm ...
24867!> \note see mp_bcast_z1
24868! **************************************************************************************************
24869 SUBROUTINE mp_bcast_z3_src(msg, comm)
24870 COMPLEX(kind=real_8), CONTIGUOUS :: msg(:, :, :)
24871 CLASS(mp_comm_type), INTENT(IN) :: comm
24872
24873 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z3_src'
24874
24875 INTEGER :: handle
24876#if defined(__parallel)
24877 INTEGER :: ierr, msglen
24878#endif
24879
24880 CALL mp_timeset(routinen, handle)
24881
24882#if defined(__parallel)
24883 msglen = SIZE(msg)
24884 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24885 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24886 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24887#else
24888 mark_used(msg)
24889 mark_used(comm)
24890#endif
24891 CALL mp_timestop(handle)
24892 END SUBROUTINE mp_bcast_z3_src
24893
24894! **************************************************************************************************
24895!> \brief Sums a datum from all processes with result left on all processes.
24896!> \param[in,out] msg Datum to sum (input) and result (output)
24897!> \param[in] comm Message passing environment identifier
24898!> \par MPI mapping
24899!> mpi_allreduce
24900! **************************************************************************************************
24901 SUBROUTINE mp_sum_z (msg, comm)
24902 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24903 CLASS(mp_comm_type), INTENT(IN) :: comm
24904
24905 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_z'
24906
24907 INTEGER :: handle
24908#if defined(__parallel)
24909 INTEGER :: ierr, msglen
24910#endif
24911
24912 CALL mp_timeset(routinen, handle)
24913
24914#if defined(__parallel)
24915 msglen = 1
24916 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
24917 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
24918 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
24919#else
24920 mark_used(msg)
24921 mark_used(comm)
24922#endif
24923 CALL mp_timestop(handle)
24924 END SUBROUTINE mp_sum_z
24925
24926! **************************************************************************************************
24927!> \brief Element-wise sum of a rank-1 array on all processes.
24928!> \param[in,out] msg Vector to sum and result
24929!> \param comm ...
24930!> \note see mp_sum_z
24931! **************************************************************************************************
24932 SUBROUTINE mp_sum_zv(msg, comm)
24933 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24934 CLASS(mp_comm_type), INTENT(IN) :: comm
24935
24936 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zv'
24937
24938 INTEGER :: handle
24939#if defined(__parallel)
24940 INTEGER :: ierr, msglen
24941#endif
24942
24943 CALL mp_timeset(routinen, handle)
24944
24945#if defined(__parallel)
24946 msglen = SIZE(msg)
24947 IF (msglen > 0) THEN
24948 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
24949 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
24950 END IF
24951 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
24952#else
24953 mark_used(msg)
24954 mark_used(comm)
24955#endif
24956 CALL mp_timestop(handle)
24957 END SUBROUTINE mp_sum_zv
24958
24959! **************************************************************************************************
24960!> \brief Element-wise sum of a rank-1 array on all processes.
24961!> \param[in,out] msg Vector to sum and result
24962!> \param comm ...
24963!> \note see mp_sum_z
24964! **************************************************************************************************
24965 SUBROUTINE mp_isum_zv(msg, comm, request)
24966 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
24967 CLASS(mp_comm_type), INTENT(IN) :: comm
24968 TYPE(mp_request_type), INTENT(OUT) :: request
24969
24970 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_zv'
24971
24972 INTEGER :: handle
24973#if defined(__parallel)
24974 INTEGER :: ierr, msglen
24975#endif
24976
24977 CALL mp_timeset(routinen, handle)
24978
24979#if defined(__parallel)
24980#if !defined(__GNUC__) || __GNUC__ >= 9
24981 cpassert(is_contiguous(msg))
24982#endif
24983 msglen = SIZE(msg)
24984 IF (msglen > 0) THEN
24985 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, request%handle, ierr)
24986 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
24987 ELSE
24988 request = mp_request_null
24989 END IF
24990 CALL add_perf(perf_id=23, count=1, msg_size=msglen*(2*real_8_size))
24991#else
24992 mark_used(msg)
24993 mark_used(comm)
24994 request = mp_request_null
24995#endif
24996 CALL mp_timestop(handle)
24997 END SUBROUTINE mp_isum_zv
24998
24999! **************************************************************************************************
25000!> \brief Element-wise sum of a rank-2 array on all processes.
25001!> \param[in] msg Matrix to sum and result
25002!> \param comm ...
25003!> \note see mp_sum_z
25004! **************************************************************************************************
25005 SUBROUTINE mp_sum_zm(msg, comm)
25006 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25007 CLASS(mp_comm_type), INTENT(IN) :: comm
25008
25009 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm'
25010
25011 INTEGER :: handle
25012#if defined(__parallel)
25013 INTEGER, PARAMETER :: max_msg = 2**25
25014 INTEGER :: ierr, m1, msglen, step, msglensum
25015#endif
25016
25017 CALL mp_timeset(routinen, handle)
25018
25019#if defined(__parallel)
25020 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
25021 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
25022 msglensum = 0
25023 DO m1 = lbound(msg, 2), ubound(msg, 2), step
25024 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
25025 msglensum = msglensum + msglen
25026 IF (msglen > 0) THEN
25027 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25028 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25029 END IF
25030 END DO
25031 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_8_size))
25032#else
25033 mark_used(msg)
25034 mark_used(comm)
25035#endif
25036 CALL mp_timestop(handle)
25037 END SUBROUTINE mp_sum_zm
25038
25039! **************************************************************************************************
25040!> \brief Element-wise sum of a rank-3 array on all processes.
25041!> \param[in] msg Array to sum and result
25042!> \param comm ...
25043!> \note see mp_sum_z
25044! **************************************************************************************************
25045 SUBROUTINE mp_sum_zm3(msg, comm)
25046 COMPLEX(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
25047 CLASS(mp_comm_type), INTENT(IN) :: comm
25048
25049 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm3'
25050
25051 INTEGER :: handle
25052#if defined(__parallel)
25053 INTEGER :: ierr, msglen
25054#endif
25055
25056 CALL mp_timeset(routinen, handle)
25057
25058#if defined(__parallel)
25059 msglen = SIZE(msg)
25060 IF (msglen > 0) THEN
25061 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25062 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25063 END IF
25064 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25065#else
25066 mark_used(msg)
25067 mark_used(comm)
25068#endif
25069 CALL mp_timestop(handle)
25070 END SUBROUTINE mp_sum_zm3
25071
25072! **************************************************************************************************
25073!> \brief Element-wise sum of a rank-4 array on all processes.
25074!> \param[in] msg Array to sum and result
25075!> \param comm ...
25076!> \note see mp_sum_z
25077! **************************************************************************************************
25078 SUBROUTINE mp_sum_zm4(msg, comm)
25079 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
25080 CLASS(mp_comm_type), INTENT(IN) :: comm
25081
25082 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm4'
25083
25084 INTEGER :: handle
25085#if defined(__parallel)
25086 INTEGER :: ierr, msglen
25087#endif
25088
25089 CALL mp_timeset(routinen, handle)
25090
25091#if defined(__parallel)
25092 msglen = SIZE(msg)
25093 IF (msglen > 0) THEN
25094 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25095 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25096 END IF
25097 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25098#else
25099 mark_used(msg)
25100 mark_used(comm)
25101#endif
25102 CALL mp_timestop(handle)
25103 END SUBROUTINE mp_sum_zm4
25104
25105! **************************************************************************************************
25106!> \brief Element-wise sum of data from all processes with result left only on
25107!> one.
25108!> \param[in,out] msg Vector to sum (input) and (only on process root)
25109!> result (output)
25110!> \param root ...
25111!> \param[in] comm Message passing environment identifier
25112!> \par MPI mapping
25113!> mpi_reduce
25114! **************************************************************************************************
25115 SUBROUTINE mp_sum_root_zv(msg, root, comm)
25116 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25117 INTEGER, INTENT(IN) :: root
25118 CLASS(mp_comm_type), INTENT(IN) :: comm
25119
25120 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_zv'
25121
25122 INTEGER :: handle
25123#if defined(__parallel)
25124 INTEGER :: ierr, m1, msglen, taskid
25125 COMPLEX(kind=real_8), ALLOCATABLE :: res(:)
25126#endif
25127
25128 CALL mp_timeset(routinen, handle)
25129
25130#if defined(__parallel)
25131 msglen = SIZE(msg)
25132 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25133 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25134 IF (msglen > 0) THEN
25135 m1 = SIZE(msg, 1)
25136 ALLOCATE (res(m1))
25137 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_sum, &
25138 root, comm%handle, ierr)
25139 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25140 IF (taskid == root) THEN
25141 msg = res
25142 END IF
25143 DEALLOCATE (res)
25144 END IF
25145 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25146#else
25147 mark_used(msg)
25148 mark_used(root)
25149 mark_used(comm)
25150#endif
25151 CALL mp_timestop(handle)
25152 END SUBROUTINE mp_sum_root_zv
25153
25154! **************************************************************************************************
25155!> \brief Element-wise sum of data from all processes with result left only on
25156!> one.
25157!> \param[in,out] msg Matrix to sum (input) and (only on process root)
25158!> result (output)
25159!> \param root ...
25160!> \param comm ...
25161!> \note see mp_sum_root_zv
25162! **************************************************************************************************
25163 SUBROUTINE mp_sum_root_zm(msg, root, comm)
25164 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25165 INTEGER, INTENT(IN) :: root
25166 CLASS(mp_comm_type), INTENT(IN) :: comm
25167
25168 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
25169
25170 INTEGER :: handle
25171#if defined(__parallel)
25172 INTEGER :: ierr, m1, m2, msglen, taskid
25173 COMPLEX(kind=real_8), ALLOCATABLE :: res(:, :)
25174#endif
25175
25176 CALL mp_timeset(routinen, handle)
25177
25178#if defined(__parallel)
25179 msglen = SIZE(msg)
25180 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25181 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25182 IF (msglen > 0) THEN
25183 m1 = SIZE(msg, 1)
25184 m2 = SIZE(msg, 2)
25185 ALLOCATE (res(m1, m2))
25186 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_sum, root, comm%handle, ierr)
25187 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25188 IF (taskid == root) THEN
25189 msg = res
25190 END IF
25191 DEALLOCATE (res)
25192 END IF
25193 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25194#else
25195 mark_used(root)
25196 mark_used(msg)
25197 mark_used(comm)
25198#endif
25199 CALL mp_timestop(handle)
25200 END SUBROUTINE mp_sum_root_zm
25201
25202! **************************************************************************************************
25203!> \brief Partial sum of data from all processes with result on each process.
25204!> \param[in] msg Matrix to sum (input)
25205!> \param[out] res Matrix containing result (output)
25206!> \param[in] comm Message passing environment identifier
25207! **************************************************************************************************
25208 SUBROUTINE mp_sum_partial_zm(msg, res, comm)
25209 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
25210 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
25211 CLASS(mp_comm_type), INTENT(IN) :: comm
25212
25213 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_zm'
25214
25215 INTEGER :: handle
25216#if defined(__parallel)
25217 INTEGER :: ierr, msglen, taskid
25218#endif
25219
25220 CALL mp_timeset(routinen, handle)
25221
25222#if defined(__parallel)
25223 msglen = SIZE(msg)
25224 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25225 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25226 IF (msglen > 0) THEN
25227 CALL mpi_scan(msg, res, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25228 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
25229 END IF
25230 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25231 ! perf_id is same as for other summation routines
25232#else
25233 res = msg
25234 mark_used(comm)
25235#endif
25236 CALL mp_timestop(handle)
25237 END SUBROUTINE mp_sum_partial_zm
25238
25239! **************************************************************************************************
25240!> \brief Finds the maximum of a datum with the result left on all processes.
25241!> \param[in,out] msg Find maximum among these data (input) and
25242!> maximum (output)
25243!> \param[in] comm Message passing environment identifier
25244!> \par MPI mapping
25245!> mpi_allreduce
25246! **************************************************************************************************
25247 SUBROUTINE mp_max_z (msg, comm)
25248 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25249 CLASS(mp_comm_type), INTENT(IN) :: comm
25250
25251 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_z'
25252
25253 INTEGER :: handle
25254#if defined(__parallel)
25255 INTEGER :: ierr, msglen
25256#endif
25257
25258 CALL mp_timeset(routinen, handle)
25259
25260#if defined(__parallel)
25261 msglen = 1
25262 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25263 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25264 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25265#else
25266 mark_used(msg)
25267 mark_used(comm)
25268#endif
25269 CALL mp_timestop(handle)
25270 END SUBROUTINE mp_max_z
25271
25272! **************************************************************************************************
25273!> \brief Finds the maximum of a datum with the result left on all processes.
25274!> \param[in,out] msg Find maximum among these data (input) and
25275!> maximum (output)
25276!> \param[in] comm Message passing environment identifier
25277!> \par MPI mapping
25278!> mpi_allreduce
25279! **************************************************************************************************
25280 SUBROUTINE mp_max_root_z (msg, root, comm)
25281 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25282 INTEGER, INTENT(IN) :: root
25283 CLASS(mp_comm_type), INTENT(IN) :: comm
25284
25285 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_z'
25286
25287 INTEGER :: handle
25288#if defined(__parallel)
25289 INTEGER :: ierr, msglen
25290 COMPLEX(kind=real_8) :: res
25291#endif
25292
25293 CALL mp_timeset(routinen, handle)
25294
25295#if defined(__parallel)
25296 msglen = 1
25297 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_max, root, comm%handle, ierr)
25298 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25299 IF (root == comm%mepos) msg = res
25300 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25301#else
25302 mark_used(msg)
25303 mark_used(comm)
25304 mark_used(root)
25305#endif
25306 CALL mp_timestop(handle)
25307 END SUBROUTINE mp_max_root_z
25308
25309! **************************************************************************************************
25310!> \brief Finds the element-wise maximum of a vector with the result left on
25311!> all processes.
25312!> \param[in,out] msg Find maximum among these data (input) and
25313!> maximum (output)
25314!> \param comm ...
25315!> \note see mp_max_z
25316! **************************************************************************************************
25317 SUBROUTINE mp_max_zv(msg, comm)
25318 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25319 CLASS(mp_comm_type), INTENT(IN) :: comm
25320
25321 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_zv'
25322
25323 INTEGER :: handle
25324#if defined(__parallel)
25325 INTEGER :: ierr, msglen
25326#endif
25327
25328 CALL mp_timeset(routinen, handle)
25329
25330#if defined(__parallel)
25331 msglen = SIZE(msg)
25332 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25333 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25334 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25335#else
25336 mark_used(msg)
25337 mark_used(comm)
25338#endif
25339 CALL mp_timestop(handle)
25340 END SUBROUTINE mp_max_zv
25341
25342! **************************************************************************************************
25343!> \brief Finds the element-wise maximum of a vector with the result left on
25344!> all processes.
25345!> \param[in,out] msg Find maximum among these data (input) and
25346!> maximum (output)
25347!> \param comm ...
25348!> \note see mp_max_z
25349! **************************************************************************************************
25350 SUBROUTINE mp_max_root_zm(msg, root, comm)
25351 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25352 INTEGER :: root
25353 CLASS(mp_comm_type), INTENT(IN) :: comm
25354
25355 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_zm'
25356
25357 INTEGER :: handle
25358#if defined(__parallel)
25359 INTEGER :: ierr, msglen
25360 COMPLEX(kind=real_8) :: res(size(msg, 1), size(msg, 2))
25361#endif
25362
25363 CALL mp_timeset(routinen, handle)
25364
25365#if defined(__parallel)
25366 msglen = SIZE(msg)
25367 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_max, root, comm%handle, ierr)
25368 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25369 IF (root == comm%mepos) msg = res
25370 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25371#else
25372 mark_used(msg)
25373 mark_used(comm)
25374 mark_used(root)
25375#endif
25376 CALL mp_timestop(handle)
25377 END SUBROUTINE mp_max_root_zm
25378
25379! **************************************************************************************************
25380!> \brief Finds the minimum of a datum with the result left on all processes.
25381!> \param[in,out] msg Find minimum among these data (input) and
25382!> maximum (output)
25383!> \param[in] comm Message passing environment identifier
25384!> \par MPI mapping
25385!> mpi_allreduce
25386! **************************************************************************************************
25387 SUBROUTINE mp_min_z (msg, comm)
25388 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25389 CLASS(mp_comm_type), INTENT(IN) :: comm
25390
25391 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_z'
25392
25393 INTEGER :: handle
25394#if defined(__parallel)
25395 INTEGER :: ierr, msglen
25396#endif
25397
25398 CALL mp_timeset(routinen, handle)
25399
25400#if defined(__parallel)
25401 msglen = 1
25402 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
25403 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25404 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25405#else
25406 mark_used(msg)
25407 mark_used(comm)
25408#endif
25409 CALL mp_timestop(handle)
25410 END SUBROUTINE mp_min_z
25411
25412! **************************************************************************************************
25413!> \brief Finds the element-wise minimum of vector with the result left on
25414!> all processes.
25415!> \param[in,out] msg Find minimum among these data (input) and
25416!> maximum (output)
25417!> \param comm ...
25418!> \par MPI mapping
25419!> mpi_allreduce
25420!> \note see mp_min_z
25421! **************************************************************************************************
25422 SUBROUTINE mp_min_zv(msg, comm)
25423 COMPLEX(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
25424 CLASS(mp_comm_type), INTENT(IN) :: comm
25425
25426 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_zv'
25427
25428 INTEGER :: handle
25429#if defined(__parallel)
25430 INTEGER :: ierr, msglen
25431#endif
25432
25433 CALL mp_timeset(routinen, handle)
25434
25435#if defined(__parallel)
25436 msglen = SIZE(msg)
25437 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
25438 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25439 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25440#else
25441 mark_used(msg)
25442 mark_used(comm)
25443#endif
25444 CALL mp_timestop(handle)
25445 END SUBROUTINE mp_min_zv
25446
25447! **************************************************************************************************
25448!> \brief Multiplies a set of numbers scattered across a number of processes,
25449!> then replicates the result.
25450!> \param[in,out] msg a number to multiply (input) and result (output)
25451!> \param[in] comm message passing environment identifier
25452!> \par MPI mapping
25453!> mpi_allreduce
25454! **************************************************************************************************
25455 SUBROUTINE mp_prod_z (msg, comm)
25456 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25457 CLASS(mp_comm_type), INTENT(IN) :: comm
25458
25459 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_z'
25460
25461 INTEGER :: handle
25462#if defined(__parallel)
25463 INTEGER :: ierr, msglen
25464#endif
25465
25466 CALL mp_timeset(routinen, handle)
25467
25468#if defined(__parallel)
25469 msglen = 1
25470 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_prod, comm%handle, ierr)
25471 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25472 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25473#else
25474 mark_used(msg)
25475 mark_used(comm)
25476#endif
25477 CALL mp_timestop(handle)
25478 END SUBROUTINE mp_prod_z
25479
25480! **************************************************************************************************
25481!> \brief Scatters data from one processes to all others
25482!> \param[in] msg_scatter Data to scatter (for root process)
25483!> \param[out] msg Received data
25484!> \param[in] root Process which scatters data
25485!> \param[in] comm Message passing environment identifier
25486!> \par MPI mapping
25487!> mpi_scatter
25488! **************************************************************************************************
25489 SUBROUTINE mp_scatter_zv(msg_scatter, msg, root, comm)
25490 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
25491 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
25492 INTEGER, INTENT(IN) :: root
25493 CLASS(mp_comm_type), INTENT(IN) :: comm
25494
25495 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_zv'
25496
25497 INTEGER :: handle
25498#if defined(__parallel)
25499 INTEGER :: ierr, msglen
25500#endif
25501
25502 CALL mp_timeset(routinen, handle)
25503
25504#if defined(__parallel)
25505 msglen = SIZE(msg)
25506 CALL mpi_scatter(msg_scatter, msglen, mpi_double_complex, msg, &
25507 msglen, mpi_double_complex, root, comm%handle, ierr)
25508 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
25509 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25510#else
25511 mark_used(root)
25512 mark_used(comm)
25513 msg = msg_scatter
25514#endif
25515 CALL mp_timestop(handle)
25516 END SUBROUTINE mp_scatter_zv
25517
25518! **************************************************************************************************
25519!> \brief Scatters data from one processes to all others
25520!> \param[in] msg_scatter Data to scatter (for root process)
25521!> \param[in] root Process which scatters data
25522!> \param[in] comm Message passing environment identifier
25523!> \par MPI mapping
25524!> mpi_scatter
25525! **************************************************************************************************
25526 SUBROUTINE mp_iscatter_z (msg_scatter, msg, root, comm, request)
25527 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:)
25528 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25529 INTEGER, INTENT(IN) :: root
25530 CLASS(mp_comm_type), INTENT(IN) :: comm
25531 TYPE(mp_request_type), INTENT(OUT) :: request
25532
25533 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_z'
25534
25535 INTEGER :: handle
25536#if defined(__parallel)
25537 INTEGER :: ierr, msglen
25538#endif
25539
25540 CALL mp_timeset(routinen, handle)
25541
25542#if defined(__parallel)
25543#if !defined(__GNUC__) || __GNUC__ >= 9
25544 cpassert(is_contiguous(msg_scatter))
25545#endif
25546 msglen = 1
25547 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_complex, msg, &
25548 msglen, mpi_double_complex, root, comm%handle, request%handle, ierr)
25549 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
25550 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25551#else
25552 mark_used(root)
25553 mark_used(comm)
25554 msg = msg_scatter(1)
25555 request = mp_request_null
25556#endif
25557 CALL mp_timestop(handle)
25558 END SUBROUTINE mp_iscatter_z
25559
25560! **************************************************************************************************
25561!> \brief Scatters data from one processes to all others
25562!> \param[in] msg_scatter Data to scatter (for root process)
25563!> \param[in] root Process which scatters data
25564!> \param[in] comm Message passing environment identifier
25565!> \par MPI mapping
25566!> mpi_scatter
25567! **************************************************************************************************
25568 SUBROUTINE mp_iscatter_zv2(msg_scatter, msg, root, comm, request)
25569 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:, :)
25570 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25571 INTEGER, INTENT(IN) :: root
25572 CLASS(mp_comm_type), INTENT(IN) :: comm
25573 TYPE(mp_request_type), INTENT(OUT) :: request
25574
25575 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_zv2'
25576
25577 INTEGER :: handle
25578#if defined(__parallel)
25579 INTEGER :: ierr, msglen
25580#endif
25581
25582 CALL mp_timeset(routinen, handle)
25583
25584#if defined(__parallel)
25585#if !defined(__GNUC__) || __GNUC__ >= 9
25586 cpassert(is_contiguous(msg_scatter))
25587#endif
25588 msglen = SIZE(msg)
25589 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_complex, msg, &
25590 msglen, mpi_double_complex, root, comm%handle, request%handle, ierr)
25591 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
25592 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25593#else
25594 mark_used(root)
25595 mark_used(comm)
25596 msg(:) = msg_scatter(:, 1)
25597 request = mp_request_null
25598#endif
25599 CALL mp_timestop(handle)
25600 END SUBROUTINE mp_iscatter_zv2
25601
25602! **************************************************************************************************
25603!> \brief Scatters data from one processes to all others
25604!> \param[in] msg_scatter Data to scatter (for root process)
25605!> \param[in] root Process which scatters data
25606!> \param[in] comm Message passing environment identifier
25607!> \par MPI mapping
25608!> mpi_scatter
25609! **************************************************************************************************
25610 SUBROUTINE mp_iscatterv_zv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
25611 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:)
25612 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
25613 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25614 INTEGER, INTENT(IN) :: recvcount, root
25615 CLASS(mp_comm_type), INTENT(IN) :: comm
25616 TYPE(mp_request_type), INTENT(OUT) :: request
25617
25618 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_zv'
25619
25620 INTEGER :: handle
25621#if defined(__parallel)
25622 INTEGER :: ierr
25623#endif
25624
25625 CALL mp_timeset(routinen, handle)
25626
25627#if defined(__parallel)
25628#if !defined(__GNUC__) || __GNUC__ >= 9
25629 cpassert(is_contiguous(msg_scatter))
25630 cpassert(is_contiguous(msg))
25631 cpassert(is_contiguous(sendcounts))
25632 cpassert(is_contiguous(displs))
25633#endif
25634 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_double_complex, msg, &
25635 recvcount, mpi_double_complex, root, comm%handle, request%handle, ierr)
25636 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
25637 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25638#else
25639 mark_used(sendcounts)
25640 mark_used(displs)
25641 mark_used(recvcount)
25642 mark_used(root)
25643 mark_used(comm)
25644 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
25645 request = mp_request_null
25646#endif
25647 CALL mp_timestop(handle)
25648 END SUBROUTINE mp_iscatterv_zv
25649
25650! **************************************************************************************************
25651!> \brief Gathers a datum from all processes to one
25652!> \param[in] msg Datum to send to root
25653!> \param[out] msg_gather Received data (on root)
25654!> \param[in] root Process which gathers the data
25655!> \param[in] comm Message passing environment identifier
25656!> \par MPI mapping
25657!> mpi_gather
25658! **************************************************************************************************
25659 SUBROUTINE mp_gather_z (msg, msg_gather, root, comm)
25660 COMPLEX(kind=real_8), INTENT(IN) :: msg
25661 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25662 INTEGER, INTENT(IN) :: root
25663 CLASS(mp_comm_type), INTENT(IN) :: comm
25664
25665 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_z'
25666
25667 INTEGER :: handle
25668#if defined(__parallel)
25669 INTEGER :: ierr, msglen
25670#endif
25671
25672 CALL mp_timeset(routinen, handle)
25673
25674#if defined(__parallel)
25675 msglen = 1
25676 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25677 msglen, mpi_double_complex, root, comm%handle, ierr)
25678 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25679 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25680#else
25681 mark_used(root)
25682 mark_used(comm)
25683 msg_gather(1) = msg
25684#endif
25685 CALL mp_timestop(handle)
25686 END SUBROUTINE mp_gather_z
25687
25688! **************************************************************************************************
25689!> \brief Gathers a datum from all processes to one, uses the source process of comm
25690!> \param[in] msg Datum to send to root
25691!> \param[out] msg_gather Received data (on root)
25692!> \param[in] comm Message passing environment identifier
25693!> \par MPI mapping
25694!> mpi_gather
25695! **************************************************************************************************
25696 SUBROUTINE mp_gather_z_src(msg, msg_gather, comm)
25697 COMPLEX(kind=real_8), INTENT(IN) :: msg
25698 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25699 CLASS(mp_comm_type), INTENT(IN) :: comm
25700
25701 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_z_src'
25702
25703 INTEGER :: handle
25704#if defined(__parallel)
25705 INTEGER :: ierr, msglen
25706#endif
25707
25708 CALL mp_timeset(routinen, handle)
25709
25710#if defined(__parallel)
25711 msglen = 1
25712 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25713 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25714 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25715 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25716#else
25717 mark_used(comm)
25718 msg_gather(1) = msg
25719#endif
25720 CALL mp_timestop(handle)
25721 END SUBROUTINE mp_gather_z_src
25722
25723! **************************************************************************************************
25724!> \brief Gathers data from all processes to one
25725!> \param[in] msg Datum to send to root
25726!> \param msg_gather ...
25727!> \param root ...
25728!> \param comm ...
25729!> \par Data length
25730!> All data (msg) is equal-sized
25731!> \par MPI mapping
25732!> mpi_gather
25733!> \note see mp_gather_z
25734! **************************************************************************************************
25735 SUBROUTINE mp_gather_zv(msg, msg_gather, root, comm)
25736 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
25737 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25738 INTEGER, INTENT(IN) :: root
25739 CLASS(mp_comm_type), INTENT(IN) :: comm
25740
25741 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zv'
25742
25743 INTEGER :: handle
25744#if defined(__parallel)
25745 INTEGER :: ierr, msglen
25746#endif
25747
25748 CALL mp_timeset(routinen, handle)
25749
25750#if defined(__parallel)
25751 msglen = SIZE(msg)
25752 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25753 msglen, mpi_double_complex, root, comm%handle, ierr)
25754 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25755 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25756#else
25757 mark_used(root)
25758 mark_used(comm)
25759 msg_gather = msg
25760#endif
25761 CALL mp_timestop(handle)
25762 END SUBROUTINE mp_gather_zv
25763
25764! **************************************************************************************************
25765!> \brief Gathers data from all processes to one. Gathers from comm%source
25766!> \param[in] msg Datum to send to root
25767!> \param msg_gather ...
25768!> \param comm ...
25769!> \par Data length
25770!> All data (msg) is equal-sized
25771!> \par MPI mapping
25772!> mpi_gather
25773!> \note see mp_gather_z
25774! **************************************************************************************************
25775 SUBROUTINE mp_gather_zv_src(msg, msg_gather, comm)
25776 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
25777 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25778 CLASS(mp_comm_type), INTENT(IN) :: comm
25779
25780 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zv_src'
25781
25782 INTEGER :: handle
25783#if defined(__parallel)
25784 INTEGER :: ierr, msglen
25785#endif
25786
25787 CALL mp_timeset(routinen, handle)
25788
25789#if defined(__parallel)
25790 msglen = SIZE(msg)
25791 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25792 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25793 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25794 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25795#else
25796 mark_used(comm)
25797 msg_gather = msg
25798#endif
25799 CALL mp_timestop(handle)
25800 END SUBROUTINE mp_gather_zv_src
25801
25802! **************************************************************************************************
25803!> \brief Gathers data from all processes to one
25804!> \param[in] msg Datum to send to root
25805!> \param msg_gather ...
25806!> \param root ...
25807!> \param comm ...
25808!> \par Data length
25809!> All data (msg) is equal-sized
25810!> \par MPI mapping
25811!> mpi_gather
25812!> \note see mp_gather_z
25813! **************************************************************************************************
25814 SUBROUTINE mp_gather_zm(msg, msg_gather, root, comm)
25815 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
25816 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
25817 INTEGER, INTENT(IN) :: root
25818 CLASS(mp_comm_type), INTENT(IN) :: comm
25819
25820 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zm'
25821
25822 INTEGER :: handle
25823#if defined(__parallel)
25824 INTEGER :: ierr, msglen
25825#endif
25826
25827 CALL mp_timeset(routinen, handle)
25828
25829#if defined(__parallel)
25830 msglen = SIZE(msg)
25831 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25832 msglen, mpi_double_complex, root, comm%handle, ierr)
25833 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25834 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25835#else
25836 mark_used(root)
25837 mark_used(comm)
25838 msg_gather = msg
25839#endif
25840 CALL mp_timestop(handle)
25841 END SUBROUTINE mp_gather_zm
25842
25843! **************************************************************************************************
25844!> \brief Gathers data from all processes to one. Gathers from comm%source
25845!> \param[in] msg Datum to send to root
25846!> \param msg_gather ...
25847!> \param comm ...
25848!> \par Data length
25849!> All data (msg) is equal-sized
25850!> \par MPI mapping
25851!> mpi_gather
25852!> \note see mp_gather_z
25853! **************************************************************************************************
25854 SUBROUTINE mp_gather_zm_src(msg, msg_gather, comm)
25855 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
25856 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
25857 CLASS(mp_comm_type), INTENT(IN) :: comm
25858
25859 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zm_src'
25860
25861 INTEGER :: handle
25862#if defined(__parallel)
25863 INTEGER :: ierr, msglen
25864#endif
25865
25866 CALL mp_timeset(routinen, handle)
25867
25868#if defined(__parallel)
25869 msglen = SIZE(msg)
25870 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25871 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25872 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25873 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25874#else
25875 mark_used(comm)
25876 msg_gather = msg
25877#endif
25878 CALL mp_timestop(handle)
25879 END SUBROUTINE mp_gather_zm_src
25880
25881! **************************************************************************************************
25882!> \brief Gathers data from all processes to one.
25883!> \param[in] sendbuf Data to send to root
25884!> \param[out] recvbuf Received data (on root)
25885!> \param[in] recvcounts Sizes of data received from processes
25886!> \param[in] displs Offsets of data received from processes
25887!> \param[in] root Process which gathers the data
25888!> \param[in] comm Message passing environment identifier
25889!> \par Data length
25890!> Data can have different lengths
25891!> \par Offsets
25892!> Offsets start at 0
25893!> \par MPI mapping
25894!> mpi_gather
25895! **************************************************************************************************
25896 SUBROUTINE mp_gatherv_zv(sendbuf, recvbuf, recvcounts, displs, root, comm)
25897
25898 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
25899 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
25900 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
25901 INTEGER, INTENT(IN) :: root
25902 CLASS(mp_comm_type), INTENT(IN) :: comm
25903
25904 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zv'
25905
25906 INTEGER :: handle
25907#if defined(__parallel)
25908 INTEGER :: ierr, sendcount
25909#endif
25910
25911 CALL mp_timeset(routinen, handle)
25912
25913#if defined(__parallel)
25914 sendcount = SIZE(sendbuf)
25915 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
25916 recvbuf, recvcounts, displs, mpi_double_complex, &
25917 root, comm%handle, ierr)
25918 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
25919 CALL add_perf(perf_id=4, &
25920 count=1, &
25921 msg_size=sendcount*(2*real_8_size))
25922#else
25923 mark_used(recvcounts)
25924 mark_used(root)
25925 mark_used(comm)
25926 recvbuf(1 + displs(1):) = sendbuf
25927#endif
25928 CALL mp_timestop(handle)
25929 END SUBROUTINE mp_gatherv_zv
25930
25931! **************************************************************************************************
25932!> \brief Gathers data from all processes to one. Gathers from comm%source
25933!> \param[in] sendbuf Data to send to root
25934!> \param[out] recvbuf Received data (on root)
25935!> \param[in] recvcounts Sizes of data received from processes
25936!> \param[in] displs Offsets of data received from processes
25937!> \param[in] comm Message passing environment identifier
25938!> \par Data length
25939!> Data can have different lengths
25940!> \par Offsets
25941!> Offsets start at 0
25942!> \par MPI mapping
25943!> mpi_gather
25944! **************************************************************************************************
25945 SUBROUTINE mp_gatherv_zv_src(sendbuf, recvbuf, recvcounts, displs, comm)
25946
25947 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
25948 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
25949 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
25950 CLASS(mp_comm_type), INTENT(IN) :: comm
25951
25952 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zv_src'
25953
25954 INTEGER :: handle
25955#if defined(__parallel)
25956 INTEGER :: ierr, sendcount
25957#endif
25958
25959 CALL mp_timeset(routinen, handle)
25960
25961#if defined(__parallel)
25962 sendcount = SIZE(sendbuf)
25963 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
25964 recvbuf, recvcounts, displs, mpi_double_complex, &
25965 comm%source, comm%handle, ierr)
25966 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
25967 CALL add_perf(perf_id=4, &
25968 count=1, &
25969 msg_size=sendcount*(2*real_8_size))
25970#else
25971 mark_used(recvcounts)
25972 mark_used(comm)
25973 recvbuf(1 + displs(1):) = sendbuf
25974#endif
25975 CALL mp_timestop(handle)
25976 END SUBROUTINE mp_gatherv_zv_src
25977
25978! **************************************************************************************************
25979!> \brief Gathers data from all processes to one.
25980!> \param[in] sendbuf Data to send to root
25981!> \param[out] recvbuf Received data (on root)
25982!> \param[in] recvcounts Sizes of data received from processes
25983!> \param[in] displs Offsets of data received from processes
25984!> \param[in] root Process which gathers the data
25985!> \param[in] comm Message passing environment identifier
25986!> \par Data length
25987!> Data can have different lengths
25988!> \par Offsets
25989!> Offsets start at 0
25990!> \par MPI mapping
25991!> mpi_gather
25992! **************************************************************************************************
25993 SUBROUTINE mp_gatherv_zm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
25994
25995 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
25996 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
25997 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
25998 INTEGER, INTENT(IN) :: root
25999 CLASS(mp_comm_type), INTENT(IN) :: comm
26000
26001 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zm2'
26002
26003 INTEGER :: handle
26004#if defined(__parallel)
26005 INTEGER :: ierr, sendcount
26006#endif
26007
26008 CALL mp_timeset(routinen, handle)
26009
26010#if defined(__parallel)
26011 sendcount = SIZE(sendbuf)
26012 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26013 recvbuf, recvcounts, displs, mpi_double_complex, &
26014 root, comm%handle, ierr)
26015 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26016 CALL add_perf(perf_id=4, &
26017 count=1, &
26018 msg_size=sendcount*(2*real_8_size))
26019#else
26020 mark_used(recvcounts)
26021 mark_used(root)
26022 mark_used(comm)
26023 recvbuf(:, 1 + displs(1):) = sendbuf
26024#endif
26025 CALL mp_timestop(handle)
26026 END SUBROUTINE mp_gatherv_zm2
26027
26028! **************************************************************************************************
26029!> \brief Gathers data from all processes to one.
26030!> \param[in] sendbuf Data to send to root
26031!> \param[out] recvbuf Received data (on root)
26032!> \param[in] recvcounts Sizes of data received from processes
26033!> \param[in] displs Offsets of data received from processes
26034!> \param[in] comm Message passing environment identifier
26035!> \par Data length
26036!> Data can have different lengths
26037!> \par Offsets
26038!> Offsets start at 0
26039!> \par MPI mapping
26040!> mpi_gather
26041! **************************************************************************************************
26042 SUBROUTINE mp_gatherv_zm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
26043
26044 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
26045 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
26046 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26047 CLASS(mp_comm_type), INTENT(IN) :: comm
26048
26049 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zm2_src'
26050
26051 INTEGER :: handle
26052#if defined(__parallel)
26053 INTEGER :: ierr, sendcount
26054#endif
26055
26056 CALL mp_timeset(routinen, handle)
26057
26058#if defined(__parallel)
26059 sendcount = SIZE(sendbuf)
26060 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26061 recvbuf, recvcounts, displs, mpi_double_complex, &
26062 comm%source, comm%handle, ierr)
26063 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26064 CALL add_perf(perf_id=4, &
26065 count=1, &
26066 msg_size=sendcount*(2*real_8_size))
26067#else
26068 mark_used(recvcounts)
26069 mark_used(comm)
26070 recvbuf(:, 1 + displs(1):) = sendbuf
26071#endif
26072 CALL mp_timestop(handle)
26073 END SUBROUTINE mp_gatherv_zm2_src
26074
26075! **************************************************************************************************
26076!> \brief Gathers data from all processes to one.
26077!> \param[in] sendbuf Data to send to root
26078!> \param[out] recvbuf Received data (on root)
26079!> \param[in] recvcounts Sizes of data received from processes
26080!> \param[in] displs Offsets of data received from processes
26081!> \param[in] root Process which gathers the data
26082!> \param[in] comm Message passing environment identifier
26083!> \par Data length
26084!> Data can have different lengths
26085!> \par Offsets
26086!> Offsets start at 0
26087!> \par MPI mapping
26088!> mpi_gather
26089! **************************************************************************************************
26090 SUBROUTINE mp_igatherv_zv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
26091 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: sendbuf
26092 COMPLEX(kind=real_8), DIMENSION(:), INTENT(OUT) :: recvbuf
26093 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26094 INTEGER, INTENT(IN) :: sendcount, root
26095 CLASS(mp_comm_type), INTENT(IN) :: comm
26096 TYPE(mp_request_type), INTENT(OUT) :: request
26097
26098 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_zv'
26099
26100 INTEGER :: handle
26101#if defined(__parallel)
26102 INTEGER :: ierr
26103#endif
26104
26105 CALL mp_timeset(routinen, handle)
26106
26107#if defined(__parallel)
26108#if !defined(__GNUC__) || __GNUC__ >= 9
26109 cpassert(is_contiguous(sendbuf))
26110 cpassert(is_contiguous(recvbuf))
26111 cpassert(is_contiguous(recvcounts))
26112 cpassert(is_contiguous(displs))
26113#endif
26114 CALL mpi_igatherv(sendbuf, sendcount, mpi_double_complex, &
26115 recvbuf, recvcounts, displs, mpi_double_complex, &
26116 root, comm%handle, request%handle, ierr)
26117 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26118 CALL add_perf(perf_id=24, &
26119 count=1, &
26120 msg_size=sendcount*(2*real_8_size))
26121#else
26122 mark_used(sendcount)
26123 mark_used(recvcounts)
26124 mark_used(root)
26125 mark_used(comm)
26126 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
26127 request = mp_request_null
26128#endif
26129 CALL mp_timestop(handle)
26130 END SUBROUTINE mp_igatherv_zv
26131
26132! **************************************************************************************************
26133!> \brief Gathers a datum from all processes and all processes receive the
26134!> same data
26135!> \param[in] msgout Datum to send
26136!> \param[out] msgin Received data
26137!> \param[in] comm Message passing environment identifier
26138!> \par Data size
26139!> All processes send equal-sized data
26140!> \par MPI mapping
26141!> mpi_allgather
26142! **************************************************************************************************
26143 SUBROUTINE mp_allgather_z (msgout, msgin, comm)
26144 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26145 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
26146 CLASS(mp_comm_type), INTENT(IN) :: comm
26147
26148 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z'
26149
26150 INTEGER :: handle
26151#if defined(__parallel)
26152 INTEGER :: ierr, rcount, scount
26153#endif
26154
26155 CALL mp_timeset(routinen, handle)
26156
26157#if defined(__parallel)
26158 scount = 1
26159 rcount = 1
26160 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26161 msgin, rcount, mpi_double_complex, &
26162 comm%handle, ierr)
26163 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26164#else
26165 mark_used(comm)
26166 msgin = msgout
26167#endif
26168 CALL mp_timestop(handle)
26169 END SUBROUTINE mp_allgather_z
26170
26171! **************************************************************************************************
26172!> \brief Gathers a datum from all processes and all processes receive the
26173!> same data
26174!> \param[in] msgout Datum to send
26175!> \param[out] msgin Received data
26176!> \param[in] comm Message passing environment identifier
26177!> \par Data size
26178!> All processes send equal-sized data
26179!> \par MPI mapping
26180!> mpi_allgather
26181! **************************************************************************************************
26182 SUBROUTINE mp_allgather_z2(msgout, msgin, comm)
26183 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26184 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26185 CLASS(mp_comm_type), INTENT(IN) :: comm
26186
26187 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z2'
26188
26189 INTEGER :: handle
26190#if defined(__parallel)
26191 INTEGER :: ierr, rcount, scount
26192#endif
26193
26194 CALL mp_timeset(routinen, handle)
26195
26196#if defined(__parallel)
26197 scount = 1
26198 rcount = 1
26199 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26200 msgin, rcount, mpi_double_complex, &
26201 comm%handle, ierr)
26202 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26203#else
26204 mark_used(comm)
26205 msgin = msgout
26206#endif
26207 CALL mp_timestop(handle)
26208 END SUBROUTINE mp_allgather_z2
26209
26210! **************************************************************************************************
26211!> \brief Gathers a datum from all processes and all processes receive the
26212!> same data
26213!> \param[in] msgout Datum to send
26214!> \param[out] msgin Received data
26215!> \param[in] comm Message passing environment identifier
26216!> \par Data size
26217!> All processes send equal-sized data
26218!> \par MPI mapping
26219!> mpi_allgather
26220! **************************************************************************************************
26221 SUBROUTINE mp_iallgather_z (msgout, msgin, comm, request)
26222 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26223 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26224 CLASS(mp_comm_type), INTENT(IN) :: comm
26225 TYPE(mp_request_type), INTENT(OUT) :: request
26226
26227 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z'
26228
26229 INTEGER :: handle
26230#if defined(__parallel)
26231 INTEGER :: ierr, rcount, scount
26232#endif
26233
26234 CALL mp_timeset(routinen, handle)
26235
26236#if defined(__parallel)
26237#if !defined(__GNUC__) || __GNUC__ >= 9
26238 cpassert(is_contiguous(msgin))
26239#endif
26240 scount = 1
26241 rcount = 1
26242 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26243 msgin, rcount, mpi_double_complex, &
26244 comm%handle, request%handle, ierr)
26245 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26246#else
26247 mark_used(comm)
26248 msgin = msgout
26249 request = mp_request_null
26250#endif
26251 CALL mp_timestop(handle)
26252 END SUBROUTINE mp_iallgather_z
26253
26254! **************************************************************************************************
26255!> \brief Gathers vector data from all processes and all processes receive the
26256!> same data
26257!> \param[in] msgout Rank-1 data to send
26258!> \param[out] msgin Received data
26259!> \param[in] comm Message passing environment identifier
26260!> \par Data size
26261!> All processes send equal-sized data
26262!> \par Ranks
26263!> The last rank counts the processes
26264!> \par MPI mapping
26265!> mpi_allgather
26266! **************************************************************************************************
26267 SUBROUTINE mp_allgather_z12(msgout, msgin, comm)
26268 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:)
26269 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26270 CLASS(mp_comm_type), INTENT(IN) :: comm
26271
26272 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z12'
26273
26274 INTEGER :: handle
26275#if defined(__parallel)
26276 INTEGER :: ierr, rcount, scount
26277#endif
26278
26279 CALL mp_timeset(routinen, handle)
26280
26281#if defined(__parallel)
26282 scount = SIZE(msgout(:))
26283 rcount = scount
26284 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26285 msgin, rcount, mpi_double_complex, &
26286 comm%handle, ierr)
26287 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26288#else
26289 mark_used(comm)
26290 msgin(:, 1) = msgout(:)
26291#endif
26292 CALL mp_timestop(handle)
26293 END SUBROUTINE mp_allgather_z12
26294
26295! **************************************************************************************************
26296!> \brief Gathers matrix data from all processes and all processes receive the
26297!> same data
26298!> \param[in] msgout Rank-2 data to send
26299!> \param msgin ...
26300!> \param comm ...
26301!> \note see mp_allgather_z12
26302! **************************************************************************************************
26303 SUBROUTINE mp_allgather_z23(msgout, msgin, comm)
26304 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
26305 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
26306 CLASS(mp_comm_type), INTENT(IN) :: comm
26307
26308 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z23'
26309
26310 INTEGER :: handle
26311#if defined(__parallel)
26312 INTEGER :: ierr, rcount, scount
26313#endif
26314
26315 CALL mp_timeset(routinen, handle)
26316
26317#if defined(__parallel)
26318 scount = SIZE(msgout(:, :))
26319 rcount = scount
26320 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26321 msgin, rcount, mpi_double_complex, &
26322 comm%handle, ierr)
26323 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26324#else
26325 mark_used(comm)
26326 msgin(:, :, 1) = msgout(:, :)
26327#endif
26328 CALL mp_timestop(handle)
26329 END SUBROUTINE mp_allgather_z23
26330
26331! **************************************************************************************************
26332!> \brief Gathers rank-3 data from all processes and all processes receive the
26333!> same data
26334!> \param[in] msgout Rank-3 data to send
26335!> \param msgin ...
26336!> \param comm ...
26337!> \note see mp_allgather_z12
26338! **************************************************************************************************
26339 SUBROUTINE mp_allgather_z34(msgout, msgin, comm)
26340 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
26341 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
26342 CLASS(mp_comm_type), INTENT(IN) :: comm
26343
26344 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z34'
26345
26346 INTEGER :: handle
26347#if defined(__parallel)
26348 INTEGER :: ierr, rcount, scount
26349#endif
26350
26351 CALL mp_timeset(routinen, handle)
26352
26353#if defined(__parallel)
26354 scount = SIZE(msgout(:, :, :))
26355 rcount = scount
26356 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26357 msgin, rcount, mpi_double_complex, &
26358 comm%handle, ierr)
26359 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26360#else
26361 mark_used(comm)
26362 msgin(:, :, :, 1) = msgout(:, :, :)
26363#endif
26364 CALL mp_timestop(handle)
26365 END SUBROUTINE mp_allgather_z34
26366
26367! **************************************************************************************************
26368!> \brief Gathers rank-2 data from all processes and all processes receive the
26369!> same data
26370!> \param[in] msgout Rank-2 data to send
26371!> \param msgin ...
26372!> \param comm ...
26373!> \note see mp_allgather_z12
26374! **************************************************************************************************
26375 SUBROUTINE mp_allgather_z22(msgout, msgin, comm)
26376 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
26377 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26378 CLASS(mp_comm_type), INTENT(IN) :: comm
26379
26380 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z22'
26381
26382 INTEGER :: handle
26383#if defined(__parallel)
26384 INTEGER :: ierr, rcount, scount
26385#endif
26386
26387 CALL mp_timeset(routinen, handle)
26388
26389#if defined(__parallel)
26390 scount = SIZE(msgout(:, :))
26391 rcount = scount
26392 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26393 msgin, rcount, mpi_double_complex, &
26394 comm%handle, ierr)
26395 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26396#else
26397 mark_used(comm)
26398 msgin(:, :) = msgout(:, :)
26399#endif
26400 CALL mp_timestop(handle)
26401 END SUBROUTINE mp_allgather_z22
26402
26403! **************************************************************************************************
26404!> \brief Gathers rank-1 data from all processes and all processes receive the
26405!> same data
26406!> \param[in] msgout Rank-1 data to send
26407!> \param msgin ...
26408!> \param comm ...
26409!> \param request ...
26410!> \note see mp_allgather_z11
26411! **************************************************************************************************
26412 SUBROUTINE mp_iallgather_z11(msgout, msgin, comm, request)
26413 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26414 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26415 CLASS(mp_comm_type), INTENT(IN) :: comm
26416 TYPE(mp_request_type), INTENT(OUT) :: request
26417
26418 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z11'
26419
26420 INTEGER :: handle
26421#if defined(__parallel)
26422 INTEGER :: ierr, rcount, scount
26423#endif
26424
26425 CALL mp_timeset(routinen, handle)
26426
26427#if defined(__parallel)
26428#if !defined(__GNUC__) || __GNUC__ >= 9
26429 cpassert(is_contiguous(msgout))
26430 cpassert(is_contiguous(msgin))
26431#endif
26432 scount = SIZE(msgout(:))
26433 rcount = scount
26434 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26435 msgin, rcount, mpi_double_complex, &
26436 comm%handle, request%handle, ierr)
26437 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26438#else
26439 mark_used(comm)
26440 msgin = msgout
26441 request = mp_request_null
26442#endif
26443 CALL mp_timestop(handle)
26444 END SUBROUTINE mp_iallgather_z11
26445
26446! **************************************************************************************************
26447!> \brief Gathers rank-2 data from all processes and all processes receive the
26448!> same data
26449!> \param[in] msgout Rank-2 data to send
26450!> \param msgin ...
26451!> \param comm ...
26452!> \param request ...
26453!> \note see mp_allgather_z12
26454! **************************************************************************************************
26455 SUBROUTINE mp_iallgather_z13(msgout, msgin, comm, request)
26456 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26457 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
26458 CLASS(mp_comm_type), INTENT(IN) :: comm
26459 TYPE(mp_request_type), INTENT(OUT) :: request
26460
26461 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z13'
26462
26463 INTEGER :: handle
26464#if defined(__parallel)
26465 INTEGER :: ierr, rcount, scount
26466#endif
26467
26468 CALL mp_timeset(routinen, handle)
26469
26470#if defined(__parallel)
26471#if !defined(__GNUC__) || __GNUC__ >= 9
26472 cpassert(is_contiguous(msgout))
26473 cpassert(is_contiguous(msgin))
26474#endif
26475
26476 scount = SIZE(msgout(:))
26477 rcount = scount
26478 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26479 msgin, rcount, mpi_double_complex, &
26480 comm%handle, request%handle, ierr)
26481 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26482#else
26483 mark_used(comm)
26484 msgin(:, 1, 1) = msgout(:)
26485 request = mp_request_null
26486#endif
26487 CALL mp_timestop(handle)
26488 END SUBROUTINE mp_iallgather_z13
26489
26490! **************************************************************************************************
26491!> \brief Gathers rank-2 data from all processes and all processes receive the
26492!> same data
26493!> \param[in] msgout Rank-2 data to send
26494!> \param msgin ...
26495!> \param comm ...
26496!> \param request ...
26497!> \note see mp_allgather_z12
26498! **************************************************************************************************
26499 SUBROUTINE mp_iallgather_z22(msgout, msgin, comm, request)
26500 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :)
26501 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :)
26502 CLASS(mp_comm_type), INTENT(IN) :: comm
26503 TYPE(mp_request_type), INTENT(OUT) :: request
26504
26505 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z22'
26506
26507 INTEGER :: handle
26508#if defined(__parallel)
26509 INTEGER :: ierr, rcount, scount
26510#endif
26511
26512 CALL mp_timeset(routinen, handle)
26513
26514#if defined(__parallel)
26515#if !defined(__GNUC__) || __GNUC__ >= 9
26516 cpassert(is_contiguous(msgout))
26517 cpassert(is_contiguous(msgin))
26518#endif
26519
26520 scount = SIZE(msgout(:, :))
26521 rcount = scount
26522 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26523 msgin, rcount, mpi_double_complex, &
26524 comm%handle, request%handle, ierr)
26525 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26526#else
26527 mark_used(comm)
26528 msgin(:, :) = msgout(:, :)
26529 request = mp_request_null
26530#endif
26531 CALL mp_timestop(handle)
26532 END SUBROUTINE mp_iallgather_z22
26533
26534! **************************************************************************************************
26535!> \brief Gathers rank-2 data from all processes and all processes receive the
26536!> same data
26537!> \param[in] msgout Rank-2 data to send
26538!> \param msgin ...
26539!> \param comm ...
26540!> \param request ...
26541!> \note see mp_allgather_z12
26542! **************************************************************************************************
26543 SUBROUTINE mp_iallgather_z24(msgout, msgin, comm, request)
26544 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :)
26545 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :, :)
26546 CLASS(mp_comm_type), INTENT(IN) :: comm
26547 TYPE(mp_request_type), INTENT(OUT) :: request
26548
26549 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z24'
26550
26551 INTEGER :: handle
26552#if defined(__parallel)
26553 INTEGER :: ierr, rcount, scount
26554#endif
26555
26556 CALL mp_timeset(routinen, handle)
26557
26558#if defined(__parallel)
26559#if !defined(__GNUC__) || __GNUC__ >= 9
26560 cpassert(is_contiguous(msgout))
26561 cpassert(is_contiguous(msgin))
26562#endif
26563
26564 scount = SIZE(msgout(:, :))
26565 rcount = scount
26566 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26567 msgin, rcount, mpi_double_complex, &
26568 comm%handle, request%handle, ierr)
26569 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26570#else
26571 mark_used(comm)
26572 msgin(:, :, 1, 1) = msgout(:, :)
26573 request = mp_request_null
26574#endif
26575 CALL mp_timestop(handle)
26576 END SUBROUTINE mp_iallgather_z24
26577
26578! **************************************************************************************************
26579!> \brief Gathers rank-3 data from all processes and all processes receive the
26580!> same data
26581!> \param[in] msgout Rank-3 data to send
26582!> \param msgin ...
26583!> \param comm ...
26584!> \param request ...
26585!> \note see mp_allgather_z12
26586! **************************************************************************************************
26587 SUBROUTINE mp_iallgather_z33(msgout, msgin, comm, request)
26588 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :, :)
26589 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
26590 CLASS(mp_comm_type), INTENT(IN) :: comm
26591 TYPE(mp_request_type), INTENT(OUT) :: request
26592
26593 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z33'
26594
26595 INTEGER :: handle
26596#if defined(__parallel)
26597 INTEGER :: ierr, rcount, scount
26598#endif
26599
26600 CALL mp_timeset(routinen, handle)
26601
26602#if defined(__parallel)
26603#if !defined(__GNUC__) || __GNUC__ >= 9
26604 cpassert(is_contiguous(msgout))
26605 cpassert(is_contiguous(msgin))
26606#endif
26607
26608 scount = SIZE(msgout(:, :, :))
26609 rcount = scount
26610 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26611 msgin, rcount, mpi_double_complex, &
26612 comm%handle, request%handle, ierr)
26613 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26614#else
26615 mark_used(comm)
26616 msgin(:, :, :) = msgout(:, :, :)
26617 request = mp_request_null
26618#endif
26619 CALL mp_timestop(handle)
26620 END SUBROUTINE mp_iallgather_z33
26621
26622! **************************************************************************************************
26623!> \brief Gathers vector data from all processes and all processes receive the
26624!> same data
26625!> \param[in] msgout Rank-1 data to send
26626!> \param[out] msgin Received data
26627!> \param[in] rcount Size of sent data for every process
26628!> \param[in] rdispl Offset of sent data for every process
26629!> \param[in] comm Message passing environment identifier
26630!> \par Data size
26631!> Processes can send different-sized data
26632!> \par Ranks
26633!> The last rank counts the processes
26634!> \par Offsets
26635!> Offsets are from 0
26636!> \par MPI mapping
26637!> mpi_allgather
26638! **************************************************************************************************
26639 SUBROUTINE mp_allgatherv_zv(msgout, msgin, rcount, rdispl, comm)
26640 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
26641 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
26642 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26643 CLASS(mp_comm_type), INTENT(IN) :: comm
26644
26645 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_zv'
26646
26647 INTEGER :: handle
26648#if defined(__parallel)
26649 INTEGER :: ierr, scount
26650#endif
26651
26652 CALL mp_timeset(routinen, handle)
26653
26654#if defined(__parallel)
26655 scount = SIZE(msgout)
26656 CALL mpi_allgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
26657 rdispl, mpi_double_complex, comm%handle, ierr)
26658 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
26659#else
26660 mark_used(rcount)
26661 mark_used(rdispl)
26662 mark_used(comm)
26663 msgin = msgout
26664#endif
26665 CALL mp_timestop(handle)
26666 END SUBROUTINE mp_allgatherv_zv
26667
26668! **************************************************************************************************
26669!> \brief Gathers vector data from all processes and all processes receive the
26670!> same data
26671!> \param[in] msgout Rank-1 data to send
26672!> \param[out] msgin Received data
26673!> \param[in] rcount Size of sent data for every process
26674!> \param[in] rdispl Offset of sent data for every process
26675!> \param[in] comm Message passing environment identifier
26676!> \par Data size
26677!> Processes can send different-sized data
26678!> \par Ranks
26679!> The last rank counts the processes
26680!> \par Offsets
26681!> Offsets are from 0
26682!> \par MPI mapping
26683!> mpi_allgather
26684! **************************************************************************************************
26685 SUBROUTINE mp_allgatherv_zm2(msgout, msgin, rcount, rdispl, comm)
26686 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
26687 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
26688 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26689 CLASS(mp_comm_type), INTENT(IN) :: comm
26690
26691 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_zv'
26692
26693 INTEGER :: handle
26694#if defined(__parallel)
26695 INTEGER :: ierr, scount
26696#endif
26697
26698 CALL mp_timeset(routinen, handle)
26699
26700#if defined(__parallel)
26701 scount = SIZE(msgout)
26702 CALL mpi_allgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
26703 rdispl, mpi_double_complex, comm%handle, ierr)
26704 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
26705#else
26706 mark_used(rcount)
26707 mark_used(rdispl)
26708 mark_used(comm)
26709 msgin = msgout
26710#endif
26711 CALL mp_timestop(handle)
26712 END SUBROUTINE mp_allgatherv_zm2
26713
26714! **************************************************************************************************
26715!> \brief Gathers vector data from all processes and all processes receive the
26716!> same data
26717!> \param[in] msgout Rank-1 data to send
26718!> \param[out] msgin Received data
26719!> \param[in] rcount Size of sent data for every process
26720!> \param[in] rdispl Offset of sent data for every process
26721!> \param[in] comm Message passing environment identifier
26722!> \par Data size
26723!> Processes can send different-sized data
26724!> \par Ranks
26725!> The last rank counts the processes
26726!> \par Offsets
26727!> Offsets are from 0
26728!> \par MPI mapping
26729!> mpi_allgather
26730! **************************************************************************************************
26731 SUBROUTINE mp_iallgatherv_zv(msgout, msgin, rcount, rdispl, comm, request)
26732 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26733 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26734 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26735 CLASS(mp_comm_type), INTENT(IN) :: comm
26736 TYPE(mp_request_type), INTENT(OUT) :: request
26737
26738 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_zv'
26739
26740 INTEGER :: handle
26741#if defined(__parallel)
26742 INTEGER :: ierr, scount, rsize
26743#endif
26744
26745 CALL mp_timeset(routinen, handle)
26746
26747#if defined(__parallel)
26748#if !defined(__GNUC__) || __GNUC__ >= 9
26749 cpassert(is_contiguous(msgout))
26750 cpassert(is_contiguous(msgin))
26751 cpassert(is_contiguous(rcount))
26752 cpassert(is_contiguous(rdispl))
26753#endif
26754
26755 scount = SIZE(msgout)
26756 rsize = SIZE(rcount)
26757 CALL mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, &
26758 rdispl, comm, request, ierr)
26759 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
26760#else
26761 mark_used(rcount)
26762 mark_used(rdispl)
26763 mark_used(comm)
26764 msgin = msgout
26765 request = mp_request_null
26766#endif
26767 CALL mp_timestop(handle)
26768 END SUBROUTINE mp_iallgatherv_zv
26769
26770! **************************************************************************************************
26771!> \brief Gathers vector data from all processes and all processes receive the
26772!> same data
26773!> \param[in] msgout Rank-1 data to send
26774!> \param[out] msgin Received data
26775!> \param[in] rcount Size of sent data for every process
26776!> \param[in] rdispl Offset of sent data for every process
26777!> \param[in] comm Message passing environment identifier
26778!> \par Data size
26779!> Processes can send different-sized data
26780!> \par Ranks
26781!> The last rank counts the processes
26782!> \par Offsets
26783!> Offsets are from 0
26784!> \par MPI mapping
26785!> mpi_allgather
26786! **************************************************************************************************
26787 SUBROUTINE mp_iallgatherv_zv2(msgout, msgin, rcount, rdispl, comm, request)
26788 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26789 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26790 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
26791 CLASS(mp_comm_type), INTENT(IN) :: comm
26792 TYPE(mp_request_type), INTENT(OUT) :: request
26793
26794 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_zv2'
26795
26796 INTEGER :: handle
26797#if defined(__parallel)
26798 INTEGER :: ierr, scount, rsize
26799#endif
26800
26801 CALL mp_timeset(routinen, handle)
26802
26803#if defined(__parallel)
26804#if !defined(__GNUC__) || __GNUC__ >= 9
26805 cpassert(is_contiguous(msgout))
26806 cpassert(is_contiguous(msgin))
26807 cpassert(is_contiguous(rcount))
26808 cpassert(is_contiguous(rdispl))
26809#endif
26810
26811 scount = SIZE(msgout)
26812 rsize = SIZE(rcount)
26813 CALL mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, &
26814 rdispl, comm, request, ierr)
26815 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
26816#else
26817 mark_used(rcount)
26818 mark_used(rdispl)
26819 mark_used(comm)
26820 msgin = msgout
26821 request = mp_request_null
26822#endif
26823 CALL mp_timestop(handle)
26824 END SUBROUTINE mp_iallgatherv_zv2
26825
26826! **************************************************************************************************
26827!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
26828!> the issue is with the rank of rcount and rdispl
26829!> \param count ...
26830!> \param array_of_requests ...
26831!> \param array_of_statuses ...
26832!> \param ierr ...
26833!> \author Alfio Lazzaro
26834! **************************************************************************************************
26835#if defined(__parallel)
26836 SUBROUTINE mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
26837 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
26838 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
26839 INTEGER, INTENT(IN) :: rsize
26840 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
26841 CLASS(mp_comm_type), INTENT(IN) :: comm
26842 TYPE(mp_request_type), INTENT(OUT) :: request
26843 INTEGER, INTENT(INOUT) :: ierr
26844
26845 CALL mpi_iallgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
26846 rdispl, mpi_double_complex, comm%handle, request%handle, ierr)
26847
26848 END SUBROUTINE mp_iallgatherv_zv_internal
26849#endif
26850
26851! **************************************************************************************************
26852!> \brief Sums a vector and partitions the result among processes
26853!> \param[in] msgout Data to sum
26854!> \param[out] msgin Received portion of summed data
26855!> \param[in] rcount Partition sizes of the summed data for
26856!> every process
26857!> \param[in] comm Message passing environment identifier
26858! **************************************************************************************************
26859 SUBROUTINE mp_sum_scatter_zv(msgout, msgin, rcount, comm)
26860 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
26861 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
26862 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
26863 CLASS(mp_comm_type), INTENT(IN) :: comm
26864
26865 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_zv'
26866
26867 INTEGER :: handle
26868#if defined(__parallel)
26869 INTEGER :: ierr
26870#endif
26871
26872 CALL mp_timeset(routinen, handle)
26873
26874#if defined(__parallel)
26875 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_double_complex, mpi_sum, &
26876 comm%handle, ierr)
26877 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
26878
26879 CALL add_perf(perf_id=3, count=1, &
26880 msg_size=rcount(1)*2*(2*real_8_size))
26881#else
26882 mark_used(rcount)
26883 mark_used(comm)
26884 msgin = msgout(:, 1)
26885#endif
26886 CALL mp_timestop(handle)
26887 END SUBROUTINE mp_sum_scatter_zv
26888
26889! **************************************************************************************************
26890!> \brief Sends and receives vector data
26891!> \param[in] msgin Data to send
26892!> \param[in] dest Process to send data to
26893!> \param[out] msgout Received data
26894!> \param[in] source Process from which to receive
26895!> \param[in] comm Message passing environment identifier
26896!> \param[in] tag Send and recv tag (default: 0)
26897! **************************************************************************************************
26898 SUBROUTINE mp_sendrecv_z (msgin, dest, msgout, source, comm, tag)
26899 COMPLEX(kind=real_8), INTENT(IN) :: msgin
26900 INTEGER, INTENT(IN) :: dest
26901 COMPLEX(kind=real_8), INTENT(OUT) :: msgout
26902 INTEGER, INTENT(IN) :: source
26903 CLASS(mp_comm_type), INTENT(IN) :: comm
26904 INTEGER, INTENT(IN), OPTIONAL :: tag
26905
26906 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_z'
26907
26908 INTEGER :: handle
26909#if defined(__parallel)
26910 INTEGER :: ierr, msglen_in, msglen_out, &
26911 recv_tag, send_tag
26912#endif
26913
26914 CALL mp_timeset(routinen, handle)
26915
26916#if defined(__parallel)
26917 msglen_in = 1
26918 msglen_out = 1
26919 send_tag = 0 ! cannot think of something better here, this might be dangerous
26920 recv_tag = 0 ! cannot think of something better here, this might be dangerous
26921 IF (PRESENT(tag)) THEN
26922 send_tag = tag
26923 recv_tag = tag
26924 END IF
26925 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
26926 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
26927 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
26928 CALL add_perf(perf_id=7, count=1, &
26929 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
26930#else
26931 mark_used(dest)
26932 mark_used(source)
26933 mark_used(comm)
26934 mark_used(tag)
26935 msgout = msgin
26936#endif
26937 CALL mp_timestop(handle)
26938 END SUBROUTINE mp_sendrecv_z
26939
26940! **************************************************************************************************
26941!> \brief Sends and receives vector data
26942!> \param[in] msgin Data to send
26943!> \param[in] dest Process to send data to
26944!> \param[out] msgout Received data
26945!> \param[in] source Process from which to receive
26946!> \param[in] comm Message passing environment identifier
26947!> \param[in] tag Send and recv tag (default: 0)
26948! **************************************************************************************************
26949 SUBROUTINE mp_sendrecv_zv(msgin, dest, msgout, source, comm, tag)
26950 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
26951 INTEGER, INTENT(IN) :: dest
26952 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
26953 INTEGER, INTENT(IN) :: source
26954 CLASS(mp_comm_type), INTENT(IN) :: comm
26955 INTEGER, INTENT(IN), OPTIONAL :: tag
26956
26957 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zv'
26958
26959 INTEGER :: handle
26960#if defined(__parallel)
26961 INTEGER :: ierr, msglen_in, msglen_out, &
26962 recv_tag, send_tag
26963#endif
26964
26965 CALL mp_timeset(routinen, handle)
26966
26967#if defined(__parallel)
26968 msglen_in = SIZE(msgin)
26969 msglen_out = SIZE(msgout)
26970 send_tag = 0 ! cannot think of something better here, this might be dangerous
26971 recv_tag = 0 ! cannot think of something better here, this might be dangerous
26972 IF (PRESENT(tag)) THEN
26973 send_tag = tag
26974 recv_tag = tag
26975 END IF
26976 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
26977 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
26978 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
26979 CALL add_perf(perf_id=7, count=1, &
26980 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
26981#else
26982 mark_used(dest)
26983 mark_used(source)
26984 mark_used(comm)
26985 mark_used(tag)
26986 msgout = msgin
26987#endif
26988 CALL mp_timestop(handle)
26989 END SUBROUTINE mp_sendrecv_zv
26990
26991! **************************************************************************************************
26992!> \brief Sends and receives matrix data
26993!> \param msgin ...
26994!> \param dest ...
26995!> \param msgout ...
26996!> \param source ...
26997!> \param comm ...
26998!> \param tag ...
26999!> \note see mp_sendrecv_zv
27000! **************************************************************************************************
27001 SUBROUTINE mp_sendrecv_zm2(msgin, dest, msgout, source, comm, tag)
27002 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
27003 INTEGER, INTENT(IN) :: dest
27004 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
27005 INTEGER, INTENT(IN) :: source
27006 CLASS(mp_comm_type), INTENT(IN) :: comm
27007 INTEGER, INTENT(IN), OPTIONAL :: tag
27008
27009 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm2'
27010
27011 INTEGER :: handle
27012#if defined(__parallel)
27013 INTEGER :: ierr, msglen_in, msglen_out, &
27014 recv_tag, send_tag
27015#endif
27016
27017 CALL mp_timeset(routinen, handle)
27018
27019#if defined(__parallel)
27020 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
27021 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
27022 send_tag = 0 ! cannot think of something better here, this might be dangerous
27023 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27024 IF (PRESENT(tag)) THEN
27025 send_tag = tag
27026 recv_tag = tag
27027 END IF
27028 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27029 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27030 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27031 CALL add_perf(perf_id=7, count=1, &
27032 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27033#else
27034 mark_used(dest)
27035 mark_used(source)
27036 mark_used(comm)
27037 mark_used(tag)
27038 msgout = msgin
27039#endif
27040 CALL mp_timestop(handle)
27041 END SUBROUTINE mp_sendrecv_zm2
27042
27043! **************************************************************************************************
27044!> \brief Sends and receives rank-3 data
27045!> \param msgin ...
27046!> \param dest ...
27047!> \param msgout ...
27048!> \param source ...
27049!> \param comm ...
27050!> \note see mp_sendrecv_zv
27051! **************************************************************************************************
27052 SUBROUTINE mp_sendrecv_zm3(msgin, dest, msgout, source, comm, tag)
27053 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
27054 INTEGER, INTENT(IN) :: dest
27055 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
27056 INTEGER, INTENT(IN) :: source
27057 CLASS(mp_comm_type), INTENT(IN) :: comm
27058 INTEGER, INTENT(IN), OPTIONAL :: tag
27059
27060 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm3'
27061
27062 INTEGER :: handle
27063#if defined(__parallel)
27064 INTEGER :: ierr, msglen_in, msglen_out, &
27065 recv_tag, send_tag
27066#endif
27067
27068 CALL mp_timeset(routinen, handle)
27069
27070#if defined(__parallel)
27071 msglen_in = SIZE(msgin)
27072 msglen_out = SIZE(msgout)
27073 send_tag = 0 ! cannot think of something better here, this might be dangerous
27074 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27075 IF (PRESENT(tag)) THEN
27076 send_tag = tag
27077 recv_tag = tag
27078 END IF
27079 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27080 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27081 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27082 CALL add_perf(perf_id=7, count=1, &
27083 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27084#else
27085 mark_used(dest)
27086 mark_used(source)
27087 mark_used(comm)
27088 mark_used(tag)
27089 msgout = msgin
27090#endif
27091 CALL mp_timestop(handle)
27092 END SUBROUTINE mp_sendrecv_zm3
27093
27094! **************************************************************************************************
27095!> \brief Sends and receives rank-4 data
27096!> \param msgin ...
27097!> \param dest ...
27098!> \param msgout ...
27099!> \param source ...
27100!> \param comm ...
27101!> \note see mp_sendrecv_zv
27102! **************************************************************************************************
27103 SUBROUTINE mp_sendrecv_zm4(msgin, dest, msgout, source, comm, tag)
27104 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
27105 INTEGER, INTENT(IN) :: dest
27106 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
27107 INTEGER, INTENT(IN) :: source
27108 CLASS(mp_comm_type), INTENT(IN) :: comm
27109 INTEGER, INTENT(IN), OPTIONAL :: tag
27110
27111 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm4'
27112
27113 INTEGER :: handle
27114#if defined(__parallel)
27115 INTEGER :: ierr, msglen_in, msglen_out, &
27116 recv_tag, send_tag
27117#endif
27118
27119 CALL mp_timeset(routinen, handle)
27120
27121#if defined(__parallel)
27122 msglen_in = SIZE(msgin)
27123 msglen_out = SIZE(msgout)
27124 send_tag = 0 ! cannot think of something better here, this might be dangerous
27125 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27126 IF (PRESENT(tag)) THEN
27127 send_tag = tag
27128 recv_tag = tag
27129 END IF
27130 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27131 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27132 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27133 CALL add_perf(perf_id=7, count=1, &
27134 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27135#else
27136 mark_used(dest)
27137 mark_used(source)
27138 mark_used(comm)
27139 mark_used(tag)
27140 msgout = msgin
27141#endif
27142 CALL mp_timestop(handle)
27143 END SUBROUTINE mp_sendrecv_zm4
27144
27145! **************************************************************************************************
27146!> \brief Non-blocking send and receive of a scalar
27147!> \param[in] msgin Scalar data to send
27148!> \param[in] dest Which process to send to
27149!> \param[out] msgout Receive data into this pointer
27150!> \param[in] source Process to receive from
27151!> \param[in] comm Message passing environment identifier
27152!> \param[out] send_request Request handle for the send
27153!> \param[out] recv_request Request handle for the receive
27154!> \param[in] tag (optional) tag to differentiate requests
27155!> \par Implementation
27156!> Calls mpi_isend and mpi_irecv.
27157!> \par History
27158!> 02.2005 created [Alfio Lazzaro]
27159! **************************************************************************************************
27160 SUBROUTINE mp_isendrecv_z (msgin, dest, msgout, source, comm, send_request, &
27161 recv_request, tag)
27162 COMPLEX(kind=real_8), INTENT(IN) :: msgin
27163 INTEGER, INTENT(IN) :: dest
27164 COMPLEX(kind=real_8), INTENT(INOUT) :: msgout
27165 INTEGER, INTENT(IN) :: source
27166 CLASS(mp_comm_type), INTENT(IN) :: comm
27167 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
27168 INTEGER, INTENT(in), OPTIONAL :: tag
27169
27170 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_z'
27171
27172 INTEGER :: handle
27173#if defined(__parallel)
27174 INTEGER :: ierr, my_tag
27175#endif
27176
27177 CALL mp_timeset(routinen, handle)
27178
27179#if defined(__parallel)
27180 my_tag = 0
27181 IF (PRESENT(tag)) my_tag = tag
27182
27183 CALL mpi_irecv(msgout, 1, mpi_double_complex, source, my_tag, &
27184 comm%handle, recv_request%handle, ierr)
27185 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27186
27187 CALL mpi_isend(msgin, 1, mpi_double_complex, dest, my_tag, &
27188 comm%handle, send_request%handle, ierr)
27189 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27190
27191 CALL add_perf(perf_id=8, count=1, msg_size=2*(2*real_8_size))
27192#else
27193 mark_used(dest)
27194 mark_used(source)
27195 mark_used(comm)
27196 mark_used(tag)
27197 send_request = mp_request_null
27198 recv_request = mp_request_null
27199 msgout = msgin
27200#endif
27201 CALL mp_timestop(handle)
27202 END SUBROUTINE mp_isendrecv_z
27203
27204! **************************************************************************************************
27205!> \brief Non-blocking send and receive of a vector
27206!> \param[in] msgin Vector data to send
27207!> \param[in] dest Which process to send to
27208!> \param[out] msgout Receive data into this pointer
27209!> \param[in] source Process to receive from
27210!> \param[in] comm Message passing environment identifier
27211!> \param[out] send_request Request handle for the send
27212!> \param[out] recv_request Request handle for the receive
27213!> \param[in] tag (optional) tag to differentiate requests
27214!> \par Implementation
27215!> Calls mpi_isend and mpi_irecv.
27216!> \par History
27217!> 11.2004 created [Joost VandeVondele]
27218!> \note
27219!> arrays can be pointers or assumed shape, but they must be contiguous!
27220! **************************************************************************************************
27221 SUBROUTINE mp_isendrecv_zv(msgin, dest, msgout, source, comm, send_request, &
27222 recv_request, tag)
27223 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
27224 INTEGER, INTENT(IN) :: dest
27225 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
27226 INTEGER, INTENT(IN) :: source
27227 CLASS(mp_comm_type), INTENT(IN) :: comm
27228 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
27229 INTEGER, INTENT(in), OPTIONAL :: tag
27230
27231 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_zv'
27232
27233 INTEGER :: handle
27234#if defined(__parallel)
27235 INTEGER :: ierr, msglen, my_tag
27236 COMPLEX(kind=real_8) :: foo
27237#endif
27238
27239 CALL mp_timeset(routinen, handle)
27240
27241#if defined(__parallel)
27242#if !defined(__GNUC__) || __GNUC__ >= 9
27243 cpassert(is_contiguous(msgout))
27244 cpassert(is_contiguous(msgin))
27245#endif
27246
27247 my_tag = 0
27248 IF (PRESENT(tag)) my_tag = tag
27249
27250 msglen = SIZE(msgout, 1)
27251 IF (msglen > 0) THEN
27252 CALL mpi_irecv(msgout(1), msglen, mpi_double_complex, source, my_tag, &
27253 comm%handle, recv_request%handle, ierr)
27254 ELSE
27255 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27256 comm%handle, recv_request%handle, ierr)
27257 END IF
27258 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27259
27260 msglen = SIZE(msgin, 1)
27261 IF (msglen > 0) THEN
27262 CALL mpi_isend(msgin(1), msglen, mpi_double_complex, dest, my_tag, &
27263 comm%handle, send_request%handle, ierr)
27264 ELSE
27265 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27266 comm%handle, send_request%handle, ierr)
27267 END IF
27268 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27269
27270 msglen = (msglen + SIZE(msgout, 1) + 1)/2
27271 CALL add_perf(perf_id=8, count=1, msg_size=msglen*(2*real_8_size))
27272#else
27273 mark_used(dest)
27274 mark_used(source)
27275 mark_used(comm)
27276 mark_used(tag)
27277 send_request = mp_request_null
27278 recv_request = mp_request_null
27279 msgout = msgin
27280#endif
27281 CALL mp_timestop(handle)
27282 END SUBROUTINE mp_isendrecv_zv
27283
27284! **************************************************************************************************
27285!> \brief Non-blocking send of vector data
27286!> \param msgin ...
27287!> \param dest ...
27288!> \param comm ...
27289!> \param request ...
27290!> \param tag ...
27291!> \par History
27292!> 08.2003 created [f&j]
27293!> \note see mp_isendrecv_zv
27294!> \note
27295!> arrays can be pointers or assumed shape, but they must be contiguous!
27296! **************************************************************************************************
27297 SUBROUTINE mp_isend_zv(msgin, dest, comm, request, tag)
27298 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
27299 INTEGER, INTENT(IN) :: dest
27300 CLASS(mp_comm_type), INTENT(IN) :: comm
27301 TYPE(mp_request_type), INTENT(out) :: request
27302 INTEGER, INTENT(in), OPTIONAL :: tag
27303
27304 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zv'
27305
27306 INTEGER :: handle, ierr
27307#if defined(__parallel)
27308 INTEGER :: msglen, my_tag
27309 COMPLEX(kind=real_8) :: foo(1)
27310#endif
27311
27312 CALL mp_timeset(routinen, handle)
27313
27314#if defined(__parallel)
27315#if !defined(__GNUC__) || __GNUC__ >= 9
27316 cpassert(is_contiguous(msgin))
27317#endif
27318 my_tag = 0
27319 IF (PRESENT(tag)) my_tag = tag
27320
27321 msglen = SIZE(msgin)
27322 IF (msglen > 0) THEN
27323 CALL mpi_isend(msgin(1), msglen, mpi_double_complex, dest, my_tag, &
27324 comm%handle, request%handle, ierr)
27325 ELSE
27326 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27327 comm%handle, request%handle, ierr)
27328 END IF
27329 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27330
27331 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27332#else
27333 mark_used(msgin)
27334 mark_used(dest)
27335 mark_used(comm)
27336 mark_used(request)
27337 mark_used(tag)
27338 ierr = 1
27339 request = mp_request_null
27340 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27341#endif
27342 CALL mp_timestop(handle)
27343 END SUBROUTINE mp_isend_zv
27344
27345! **************************************************************************************************
27346!> \brief Non-blocking send of matrix data
27347!> \param msgin ...
27348!> \param dest ...
27349!> \param comm ...
27350!> \param request ...
27351!> \param tag ...
27352!> \par History
27353!> 2009-11-25 [UB] Made type-generic for templates
27354!> \author fawzi
27355!> \note see mp_isendrecv_zv
27356!> \note see mp_isend_zv
27357!> \note
27358!> arrays can be pointers or assumed shape, but they must be contiguous!
27359! **************************************************************************************************
27360 SUBROUTINE mp_isend_zm2(msgin, dest, comm, request, tag)
27361 COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(IN) :: msgin
27362 INTEGER, INTENT(IN) :: dest
27363 CLASS(mp_comm_type), INTENT(IN) :: comm
27364 TYPE(mp_request_type), INTENT(out) :: request
27365 INTEGER, INTENT(in), OPTIONAL :: tag
27366
27367 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm2'
27368
27369 INTEGER :: handle, ierr
27370#if defined(__parallel)
27371 INTEGER :: msglen, my_tag
27372 COMPLEX(kind=real_8) :: foo(1)
27373#endif
27374
27375 CALL mp_timeset(routinen, handle)
27376
27377#if defined(__parallel)
27378#if !defined(__GNUC__) || __GNUC__ >= 9
27379 cpassert(is_contiguous(msgin))
27380#endif
27381
27382 my_tag = 0
27383 IF (PRESENT(tag)) my_tag = tag
27384
27385 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
27386 IF (msglen > 0) THEN
27387 CALL mpi_isend(msgin(1, 1), msglen, mpi_double_complex, dest, my_tag, &
27388 comm%handle, request%handle, ierr)
27389 ELSE
27390 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27391 comm%handle, request%handle, ierr)
27392 END IF
27393 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27394
27395 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27396#else
27397 mark_used(msgin)
27398 mark_used(dest)
27399 mark_used(comm)
27400 mark_used(request)
27401 mark_used(tag)
27402 ierr = 1
27403 request = mp_request_null
27404 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27405#endif
27406 CALL mp_timestop(handle)
27407 END SUBROUTINE mp_isend_zm2
27408
27409! **************************************************************************************************
27410!> \brief Non-blocking send of rank-3 data
27411!> \param msgin ...
27412!> \param dest ...
27413!> \param comm ...
27414!> \param request ...
27415!> \param tag ...
27416!> \par History
27417!> 9.2008 added _rm3 subroutine [Iain Bethune]
27418!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
27419!> 2009-11-25 [UB] Made type-generic for templates
27420!> \author fawzi
27421!> \note see mp_isendrecv_zv
27422!> \note see mp_isend_zv
27423!> \note
27424!> arrays can be pointers or assumed shape, but they must be contiguous!
27425! **************************************************************************************************
27426 SUBROUTINE mp_isend_zm3(msgin, dest, comm, request, tag)
27427 COMPLEX(kind=real_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
27428 INTEGER, INTENT(IN) :: dest
27429 CLASS(mp_comm_type), INTENT(IN) :: comm
27430 TYPE(mp_request_type), INTENT(out) :: request
27431 INTEGER, INTENT(in), OPTIONAL :: tag
27432
27433 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm3'
27434
27435 INTEGER :: handle, ierr
27436#if defined(__parallel)
27437 INTEGER :: msglen, my_tag
27438 COMPLEX(kind=real_8) :: foo(1)
27439#endif
27440
27441 CALL mp_timeset(routinen, handle)
27442
27443#if defined(__parallel)
27444#if !defined(__GNUC__) || __GNUC__ >= 9
27445 cpassert(is_contiguous(msgin))
27446#endif
27447
27448 my_tag = 0
27449 IF (PRESENT(tag)) my_tag = tag
27450
27451 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
27452 IF (msglen > 0) THEN
27453 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_double_complex, dest, my_tag, &
27454 comm%handle, request%handle, ierr)
27455 ELSE
27456 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27457 comm%handle, request%handle, ierr)
27458 END IF
27459 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27460
27461 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27462#else
27463 mark_used(msgin)
27464 mark_used(dest)
27465 mark_used(comm)
27466 mark_used(request)
27467 mark_used(tag)
27468 ierr = 1
27469 request = mp_request_null
27470 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27471#endif
27472 CALL mp_timestop(handle)
27473 END SUBROUTINE mp_isend_zm3
27474
27475! **************************************************************************************************
27476!> \brief Non-blocking send of rank-4 data
27477!> \param msgin the input message
27478!> \param dest the destination processor
27479!> \param comm the communicator object
27480!> \param request the communication request id
27481!> \param tag the message tag
27482!> \par History
27483!> 2.2016 added _zm4 subroutine [Nico Holmberg]
27484!> \author fawzi
27485!> \note see mp_isend_zv
27486!> \note
27487!> arrays can be pointers or assumed shape, but they must be contiguous!
27488! **************************************************************************************************
27489 SUBROUTINE mp_isend_zm4(msgin, dest, comm, request, tag)
27490 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
27491 INTEGER, INTENT(IN) :: dest
27492 CLASS(mp_comm_type), INTENT(IN) :: comm
27493 TYPE(mp_request_type), INTENT(out) :: request
27494 INTEGER, INTENT(in), OPTIONAL :: tag
27495
27496 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm4'
27497
27498 INTEGER :: handle, ierr
27499#if defined(__parallel)
27500 INTEGER :: msglen, my_tag
27501 COMPLEX(kind=real_8) :: foo(1)
27502#endif
27503
27504 CALL mp_timeset(routinen, handle)
27505
27506#if defined(__parallel)
27507#if !defined(__GNUC__) || __GNUC__ >= 9
27508 cpassert(is_contiguous(msgin))
27509#endif
27510
27511 my_tag = 0
27512 IF (PRESENT(tag)) my_tag = tag
27513
27514 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
27515 IF (msglen > 0) THEN
27516 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_double_complex, dest, my_tag, &
27517 comm%handle, request%handle, ierr)
27518 ELSE
27519 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27520 comm%handle, request%handle, ierr)
27521 END IF
27522 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27523
27524 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27525#else
27526 mark_used(msgin)
27527 mark_used(dest)
27528 mark_used(comm)
27529 mark_used(request)
27530 mark_used(tag)
27531 ierr = 1
27532 request = mp_request_null
27533 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27534#endif
27535 CALL mp_timestop(handle)
27536 END SUBROUTINE mp_isend_zm4
27537
27538! **************************************************************************************************
27539!> \brief Non-blocking receive of vector data
27540!> \param msgout ...
27541!> \param source ...
27542!> \param comm ...
27543!> \param request ...
27544!> \param tag ...
27545!> \par History
27546!> 08.2003 created [f&j]
27547!> 2009-11-25 [UB] Made type-generic for templates
27548!> \note see mp_isendrecv_zv
27549!> \note
27550!> arrays can be pointers or assumed shape, but they must be contiguous!
27551! **************************************************************************************************
27552 SUBROUTINE mp_irecv_zv(msgout, source, comm, request, tag)
27553 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
27554 INTEGER, INTENT(IN) :: source
27555 CLASS(mp_comm_type), INTENT(IN) :: comm
27556 TYPE(mp_request_type), INTENT(out) :: request
27557 INTEGER, INTENT(in), OPTIONAL :: tag
27558
27559 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zv'
27560
27561 INTEGER :: handle
27562#if defined(__parallel)
27563 INTEGER :: ierr, msglen, my_tag
27564 COMPLEX(kind=real_8) :: foo(1)
27565#endif
27566
27567 CALL mp_timeset(routinen, handle)
27568
27569#if defined(__parallel)
27570#if !defined(__GNUC__) || __GNUC__ >= 9
27571 cpassert(is_contiguous(msgout))
27572#endif
27573
27574 my_tag = 0
27575 IF (PRESENT(tag)) my_tag = tag
27576
27577 msglen = SIZE(msgout)
27578 IF (msglen > 0) THEN
27579 CALL mpi_irecv(msgout(1), msglen, mpi_double_complex, source, my_tag, &
27580 comm%handle, request%handle, ierr)
27581 ELSE
27582 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27583 comm%handle, request%handle, ierr)
27584 END IF
27585 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27586
27587 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27588#else
27589 cpabort("mp_irecv called in non parallel case")
27590 mark_used(msgout)
27591 mark_used(source)
27592 mark_used(comm)
27593 mark_used(tag)
27594 request = mp_request_null
27595#endif
27596 CALL mp_timestop(handle)
27597 END SUBROUTINE mp_irecv_zv
27598
27599! **************************************************************************************************
27600!> \brief Non-blocking receive of matrix data
27601!> \param msgout ...
27602!> \param source ...
27603!> \param comm ...
27604!> \param request ...
27605!> \param tag ...
27606!> \par History
27607!> 2009-11-25 [UB] Made type-generic for templates
27608!> \author fawzi
27609!> \note see mp_isendrecv_zv
27610!> \note see mp_irecv_zv
27611!> \note
27612!> arrays can be pointers or assumed shape, but they must be contiguous!
27613! **************************************************************************************************
27614 SUBROUTINE mp_irecv_zm2(msgout, source, comm, request, tag)
27615 COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
27616 INTEGER, INTENT(IN) :: source
27617 CLASS(mp_comm_type), INTENT(IN) :: comm
27618 TYPE(mp_request_type), INTENT(out) :: request
27619 INTEGER, INTENT(in), OPTIONAL :: tag
27620
27621 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm2'
27622
27623 INTEGER :: handle
27624#if defined(__parallel)
27625 INTEGER :: ierr, msglen, my_tag
27626 COMPLEX(kind=real_8) :: foo(1)
27627#endif
27628
27629 CALL mp_timeset(routinen, handle)
27630
27631#if defined(__parallel)
27632#if !defined(__GNUC__) || __GNUC__ >= 9
27633 cpassert(is_contiguous(msgout))
27634#endif
27635
27636 my_tag = 0
27637 IF (PRESENT(tag)) my_tag = tag
27638
27639 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
27640 IF (msglen > 0) THEN
27641 CALL mpi_irecv(msgout(1, 1), msglen, mpi_double_complex, source, my_tag, &
27642 comm%handle, request%handle, ierr)
27643 ELSE
27644 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27645 comm%handle, request%handle, ierr)
27646 END IF
27647 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27648
27649 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27650#else
27651 mark_used(msgout)
27652 mark_used(source)
27653 mark_used(comm)
27654 mark_used(tag)
27655 request = mp_request_null
27656 cpabort("mp_irecv called in non parallel case")
27657#endif
27658 CALL mp_timestop(handle)
27659 END SUBROUTINE mp_irecv_zm2
27660
27661! **************************************************************************************************
27662!> \brief Non-blocking send of rank-3 data
27663!> \param msgout ...
27664!> \param source ...
27665!> \param comm ...
27666!> \param request ...
27667!> \param tag ...
27668!> \par History
27669!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
27670!> 2009-11-25 [UB] Made type-generic for templates
27671!> \author fawzi
27672!> \note see mp_isendrecv_zv
27673!> \note see mp_irecv_zv
27674!> \note
27675!> arrays can be pointers or assumed shape, but they must be contiguous!
27676! **************************************************************************************************
27677 SUBROUTINE mp_irecv_zm3(msgout, source, comm, request, tag)
27678 COMPLEX(kind=real_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
27679 INTEGER, INTENT(IN) :: source
27680 CLASS(mp_comm_type), INTENT(IN) :: comm
27681 TYPE(mp_request_type), INTENT(out) :: request
27682 INTEGER, INTENT(in), OPTIONAL :: tag
27683
27684 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm3'
27685
27686 INTEGER :: handle
27687#if defined(__parallel)
27688 INTEGER :: ierr, msglen, my_tag
27689 COMPLEX(kind=real_8) :: foo(1)
27690#endif
27691
27692 CALL mp_timeset(routinen, handle)
27693
27694#if defined(__parallel)
27695#if !defined(__GNUC__) || __GNUC__ >= 9
27696 cpassert(is_contiguous(msgout))
27697#endif
27698
27699 my_tag = 0
27700 IF (PRESENT(tag)) my_tag = tag
27701
27702 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
27703 IF (msglen > 0) THEN
27704 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_double_complex, source, my_tag, &
27705 comm%handle, request%handle, ierr)
27706 ELSE
27707 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27708 comm%handle, request%handle, ierr)
27709 END IF
27710 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
27711
27712 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27713#else
27714 mark_used(msgout)
27715 mark_used(source)
27716 mark_used(comm)
27717 mark_used(tag)
27718 request = mp_request_null
27719 cpabort("mp_irecv called in non parallel case")
27720#endif
27721 CALL mp_timestop(handle)
27722 END SUBROUTINE mp_irecv_zm3
27723
27724! **************************************************************************************************
27725!> \brief Non-blocking receive of rank-4 data
27726!> \param msgout the output message
27727!> \param source the source processor
27728!> \param comm the communicator object
27729!> \param request the communication request id
27730!> \param tag the message tag
27731!> \par History
27732!> 2.2016 added _zm4 subroutine [Nico Holmberg]
27733!> \author fawzi
27734!> \note see mp_irecv_zv
27735!> \note
27736!> arrays can be pointers or assumed shape, but they must be contiguous!
27737! **************************************************************************************************
27738 SUBROUTINE mp_irecv_zm4(msgout, source, comm, request, tag)
27739 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
27740 INTEGER, INTENT(IN) :: source
27741 CLASS(mp_comm_type), INTENT(IN) :: comm
27742 TYPE(mp_request_type), INTENT(out) :: request
27743 INTEGER, INTENT(in), OPTIONAL :: tag
27744
27745 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm4'
27746
27747 INTEGER :: handle
27748#if defined(__parallel)
27749 INTEGER :: ierr, msglen, my_tag
27750 COMPLEX(kind=real_8) :: foo(1)
27751#endif
27752
27753 CALL mp_timeset(routinen, handle)
27754
27755#if defined(__parallel)
27756#if !defined(__GNUC__) || __GNUC__ >= 9
27757 cpassert(is_contiguous(msgout))
27758#endif
27759
27760 my_tag = 0
27761 IF (PRESENT(tag)) my_tag = tag
27762
27763 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
27764 IF (msglen > 0) THEN
27765 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_double_complex, source, my_tag, &
27766 comm%handle, request%handle, ierr)
27767 ELSE
27768 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27769 comm%handle, request%handle, ierr)
27770 END IF
27771 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
27772
27773 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27774#else
27775 mark_used(msgout)
27776 mark_used(source)
27777 mark_used(comm)
27778 mark_used(tag)
27779 request = mp_request_null
27780 cpabort("mp_irecv called in non parallel case")
27781#endif
27782 CALL mp_timestop(handle)
27783 END SUBROUTINE mp_irecv_zm4
27784
27785! **************************************************************************************************
27786!> \brief Window initialization function for vector data
27787!> \param base ...
27788!> \param comm ...
27789!> \param win ...
27790!> \par History
27791!> 02.2015 created [Alfio Lazzaro]
27792!> \note
27793!> arrays can be pointers or assumed shape, but they must be contiguous!
27794! **************************************************************************************************
27795 SUBROUTINE mp_win_create_zv(base, comm, win)
27796 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
27797 TYPE(mp_comm_type), INTENT(IN) :: comm
27798 CLASS(mp_win_type), INTENT(INOUT) :: win
27799
27800 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_zv'
27801
27802 INTEGER :: handle
27803#if defined(__parallel)
27804 INTEGER :: ierr
27805 INTEGER(kind=mpi_address_kind) :: len
27806 COMPLEX(kind=real_8) :: foo(1)
27807#endif
27808
27809 CALL mp_timeset(routinen, handle)
27810
27811#if defined(__parallel)
27812
27813 len = SIZE(base)*(2*real_8_size)
27814 IF (len > 0) THEN
27815 CALL mpi_win_create(base(1), len, (2*real_8_size), mpi_info_null, comm%handle, win%handle, ierr)
27816 ELSE
27817 CALL mpi_win_create(foo, len, (2*real_8_size), mpi_info_null, comm%handle, win%handle, ierr)
27818 END IF
27819 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
27820
27821 CALL add_perf(perf_id=20, count=1)
27822#else
27823 mark_used(base)
27824 mark_used(comm)
27825 win%handle = mp_win_null_handle
27826#endif
27827 CALL mp_timestop(handle)
27828 END SUBROUTINE mp_win_create_zv
27829
27830! **************************************************************************************************
27831!> \brief Single-sided get function for vector data
27832!> \param base ...
27833!> \param comm ...
27834!> \param win ...
27835!> \par History
27836!> 02.2015 created [Alfio Lazzaro]
27837!> \note
27838!> arrays can be pointers or assumed shape, but they must be contiguous!
27839! **************************************************************************************************
27840 SUBROUTINE mp_rget_zv(base, source, win, win_data, myproc, disp, request, &
27841 origin_datatype, target_datatype)
27842 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
27843 INTEGER, INTENT(IN) :: source
27844 CLASS(mp_win_type), INTENT(IN) :: win
27845 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: win_data
27846 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
27847 TYPE(mp_request_type), INTENT(OUT) :: request
27848 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
27849
27850 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_zv'
27851
27852 INTEGER :: handle
27853#if defined(__parallel)
27854 INTEGER :: ierr, len, &
27855 origin_len, target_len
27856 LOGICAL :: do_local_copy
27857 INTEGER(kind=mpi_address_kind) :: disp_aint
27858 mpi_data_type :: handle_origin_datatype, handle_target_datatype
27859#endif
27860
27861 CALL mp_timeset(routinen, handle)
27862
27863#if defined(__parallel)
27864 len = SIZE(base)
27865 disp_aint = 0
27866 IF (PRESENT(disp)) THEN
27867 disp_aint = int(disp, kind=mpi_address_kind)
27868 END IF
27869 handle_origin_datatype = mpi_double_complex
27870 origin_len = len
27871 IF (PRESENT(origin_datatype)) THEN
27872 handle_origin_datatype = origin_datatype%type_handle
27873 origin_len = 1
27874 END IF
27875 handle_target_datatype = mpi_double_complex
27876 target_len = len
27877 IF (PRESENT(target_datatype)) THEN
27878 handle_target_datatype = target_datatype%type_handle
27879 target_len = 1
27880 END IF
27881 IF (len > 0) THEN
27882 do_local_copy = .false.
27883 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
27884 IF (myproc .EQ. source) do_local_copy = .true.
27885 END IF
27886 IF (do_local_copy) THEN
27887 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
27888 base(:) = win_data(disp_aint + 1:disp_aint + len)
27889 !$OMP END PARALLEL WORKSHARE
27890 request = mp_request_null
27891 ierr = 0
27892 ELSE
27893 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
27894 target_len, handle_target_datatype, win%handle, request%handle, ierr)
27895 END IF
27896 ELSE
27897 request = mp_request_null
27898 ierr = 0
27899 END IF
27900 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
27901
27902 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*(2*real_8_size))
27903#else
27904 mark_used(source)
27905 mark_used(win)
27906 mark_used(myproc)
27907 mark_used(origin_datatype)
27908 mark_used(target_datatype)
27909
27910 request = mp_request_null
27911 !
27912 IF (PRESENT(disp)) THEN
27913 base(:) = win_data(disp + 1:disp + SIZE(base))
27914 ELSE
27915 base(:) = win_data(:SIZE(base))
27916 END IF
27917
27918#endif
27919 CALL mp_timestop(handle)
27920 END SUBROUTINE mp_rget_zv
27921
27922! **************************************************************************************************
27923!> \brief ...
27924!> \param count ...
27925!> \param lengths ...
27926!> \param displs ...
27927!> \return ...
27928! ***************************************************************************
27929 FUNCTION mp_type_indexed_make_z (count, lengths, displs) &
27930 result(type_descriptor)
27931 INTEGER, INTENT(IN) :: count
27932 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
27933 TYPE(mp_type_descriptor_type) :: type_descriptor
27934
27935 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_z'
27936
27937 INTEGER :: handle
27938#if defined(__parallel)
27939 INTEGER :: ierr
27940#endif
27941
27942 CALL mp_timeset(routinen, handle)
27943
27944#if defined(__parallel)
27945 CALL mpi_type_indexed(count, lengths, displs, mpi_double_complex, &
27946 type_descriptor%type_handle, ierr)
27947 IF (ierr /= 0) &
27948 cpabort("MPI_Type_Indexed @ "//routinen)
27949 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
27950 IF (ierr /= 0) &
27951 cpabort("MPI_Type_commit @ "//routinen)
27952#else
27953 type_descriptor%type_handle = 7
27954#endif
27955 type_descriptor%length = count
27956 NULLIFY (type_descriptor%subtype)
27957 type_descriptor%vector_descriptor(1:2) = 1
27958 type_descriptor%has_indexing = .true.
27959 type_descriptor%index_descriptor%index => lengths
27960 type_descriptor%index_descriptor%chunks => displs
27961
27962 CALL mp_timestop(handle)
27963
27964 END FUNCTION mp_type_indexed_make_z
27965
27966! **************************************************************************************************
27967!> \brief Allocates special parallel memory
27968!> \param[in] DATA pointer to integer array to allocate
27969!> \param[in] len number of integers to allocate
27970!> \param[out] stat (optional) allocation status result
27971!> \author UB
27972! **************************************************************************************************
27973 SUBROUTINE mp_allocate_z (DATA, len, stat)
27974 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
27975 INTEGER, INTENT(IN) :: len
27976 INTEGER, INTENT(OUT), OPTIONAL :: stat
27977
27978 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_z'
27979
27980 INTEGER :: handle, ierr
27981
27982 CALL mp_timeset(routinen, handle)
27983
27984#if defined(__parallel)
27985 NULLIFY (data)
27986 CALL mp_alloc_mem(DATA, len, stat=ierr)
27987 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
27988 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
27989 CALL add_perf(perf_id=15, count=1)
27990#else
27991 ALLOCATE (DATA(len), stat=ierr)
27992 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
27993 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
27994#endif
27995 IF (PRESENT(stat)) stat = ierr
27996 CALL mp_timestop(handle)
27997 END SUBROUTINE mp_allocate_z
27998
27999! **************************************************************************************************
28000!> \brief Deallocates special parallel memory
28001!> \param[in] DATA pointer to special memory to deallocate
28002!> \param stat ...
28003!> \author UB
28004! **************************************************************************************************
28005 SUBROUTINE mp_deallocate_z (DATA, stat)
28006 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
28007 INTEGER, INTENT(OUT), OPTIONAL :: stat
28008
28009 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_z'
28010
28011 INTEGER :: handle
28012#if defined(__parallel)
28013 INTEGER :: ierr
28014#endif
28015
28016 CALL mp_timeset(routinen, handle)
28017
28018#if defined(__parallel)
28019 CALL mp_free_mem(DATA, ierr)
28020 IF (PRESENT(stat)) THEN
28021 stat = ierr
28022 ELSE
28023 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
28024 END IF
28025 NULLIFY (data)
28026 CALL add_perf(perf_id=15, count=1)
28027#else
28028 DEALLOCATE (data)
28029 IF (PRESENT(stat)) stat = 0
28030#endif
28031 CALL mp_timestop(handle)
28032 END SUBROUTINE mp_deallocate_z
28033
28034! **************************************************************************************************
28035!> \brief (parallel) Blocking individual file write using explicit offsets
28036!> (serial) Unformatted stream write
28037!> \param[in] fh file handle (file storage unit)
28038!> \param[in] offset file offset (position)
28039!> \param[in] msg data to be written to the file
28040!> \param msglen ...
28041!> \par MPI-I/O mapping mpi_file_write_at
28042!> \par STREAM-I/O mapping WRITE
28043!> \param[in](optional) msglen number of the elements of data
28044! **************************************************************************************************
28045 SUBROUTINE mp_file_write_at_zv(fh, offset, msg, msglen)
28046 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
28047 CLASS(mp_file_type), INTENT(IN) :: fh
28048 INTEGER, INTENT(IN), OPTIONAL :: msglen
28049 INTEGER(kind=file_offset), INTENT(IN) :: offset
28050
28051 INTEGER :: msg_len
28052#if defined(__parallel)
28053 INTEGER :: ierr
28054#endif
28055
28056 msg_len = SIZE(msg)
28057 IF (PRESENT(msglen)) msg_len = msglen
28058#if defined(__parallel)
28059 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28060 IF (ierr .NE. 0) &
28061 cpabort("mpi_file_write_at_zv @ mp_file_write_at_zv")
28062#else
28063 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28064#endif
28065 END SUBROUTINE mp_file_write_at_zv
28066
28067! **************************************************************************************************
28068!> \brief ...
28069!> \param fh ...
28070!> \param offset ...
28071!> \param msg ...
28072! **************************************************************************************************
28073 SUBROUTINE mp_file_write_at_z (fh, offset, msg)
28074 COMPLEX(kind=real_8), INTENT(IN) :: msg
28075 CLASS(mp_file_type), INTENT(IN) :: fh
28076 INTEGER(kind=file_offset), INTENT(IN) :: offset
28077
28078#if defined(__parallel)
28079 INTEGER :: ierr
28080
28081 ierr = 0
28082 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28083 IF (ierr .NE. 0) &
28084 cpabort("mpi_file_write_at_z @ mp_file_write_at_z")
28085#else
28086 WRITE (unit=fh%handle, pos=offset + 1) msg
28087#endif
28088 END SUBROUTINE mp_file_write_at_z
28089
28090! **************************************************************************************************
28091!> \brief (parallel) Blocking collective file write using explicit offsets
28092!> (serial) Unformatted stream write
28093!> \param fh ...
28094!> \param offset ...
28095!> \param msg ...
28096!> \param msglen ...
28097!> \par MPI-I/O mapping mpi_file_write_at_all
28098!> \par STREAM-I/O mapping WRITE
28099! **************************************************************************************************
28100 SUBROUTINE mp_file_write_at_all_zv(fh, offset, msg, msglen)
28101 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
28102 CLASS(mp_file_type), INTENT(IN) :: fh
28103 INTEGER, INTENT(IN), OPTIONAL :: msglen
28104 INTEGER(kind=file_offset), INTENT(IN) :: offset
28105
28106 INTEGER :: msg_len
28107#if defined(__parallel)
28108 INTEGER :: ierr
28109#endif
28110
28111 msg_len = SIZE(msg)
28112 IF (PRESENT(msglen)) msg_len = msglen
28113#if defined(__parallel)
28114 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28115 IF (ierr .NE. 0) &
28116 cpabort("mpi_file_write_at_all_zv @ mp_file_write_at_all_zv")
28117#else
28118 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28119#endif
28120 END SUBROUTINE mp_file_write_at_all_zv
28121
28122! **************************************************************************************************
28123!> \brief ...
28124!> \param fh ...
28125!> \param offset ...
28126!> \param msg ...
28127! **************************************************************************************************
28128 SUBROUTINE mp_file_write_at_all_z (fh, offset, msg)
28129 COMPLEX(kind=real_8), INTENT(IN) :: msg
28130 CLASS(mp_file_type), INTENT(IN) :: fh
28131 INTEGER(kind=file_offset), INTENT(IN) :: offset
28132
28133#if defined(__parallel)
28134 INTEGER :: ierr
28135
28136 ierr = 0
28137 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28138 IF (ierr .NE. 0) &
28139 cpabort("mpi_file_write_at_all_z @ mp_file_write_at_all_z")
28140#else
28141 WRITE (unit=fh%handle, pos=offset + 1) msg
28142#endif
28143 END SUBROUTINE mp_file_write_at_all_z
28144
28145! **************************************************************************************************
28146!> \brief (parallel) Blocking individual file read using explicit offsets
28147!> (serial) Unformatted stream read
28148!> \param[in] fh file handle (file storage unit)
28149!> \param[in] offset file offset (position)
28150!> \param[out] msg data to be read from the file
28151!> \param msglen ...
28152!> \par MPI-I/O mapping mpi_file_read_at
28153!> \par STREAM-I/O mapping READ
28154!> \param[in](optional) msglen number of elements of data
28155! **************************************************************************************************
28156 SUBROUTINE mp_file_read_at_zv(fh, offset, msg, msglen)
28157 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
28158 CLASS(mp_file_type), INTENT(IN) :: fh
28159 INTEGER, INTENT(IN), OPTIONAL :: msglen
28160 INTEGER(kind=file_offset), INTENT(IN) :: offset
28161
28162 INTEGER :: msg_len
28163#if defined(__parallel)
28164 INTEGER :: ierr
28165#endif
28166
28167 msg_len = SIZE(msg)
28168 IF (PRESENT(msglen)) msg_len = msglen
28169#if defined(__parallel)
28170 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28171 IF (ierr .NE. 0) &
28172 cpabort("mpi_file_read_at_zv @ mp_file_read_at_zv")
28173#else
28174 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28175#endif
28176 END SUBROUTINE mp_file_read_at_zv
28177
28178! **************************************************************************************************
28179!> \brief ...
28180!> \param fh ...
28181!> \param offset ...
28182!> \param msg ...
28183! **************************************************************************************************
28184 SUBROUTINE mp_file_read_at_z (fh, offset, msg)
28185 COMPLEX(kind=real_8), INTENT(OUT) :: msg
28186 CLASS(mp_file_type), INTENT(IN) :: fh
28187 INTEGER(kind=file_offset), INTENT(IN) :: offset
28188
28189#if defined(__parallel)
28190 INTEGER :: ierr
28191
28192 ierr = 0
28193 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28194 IF (ierr .NE. 0) &
28195 cpabort("mpi_file_read_at_z @ mp_file_read_at_z")
28196#else
28197 READ (unit=fh%handle, pos=offset + 1) msg
28198#endif
28199 END SUBROUTINE mp_file_read_at_z
28200
28201! **************************************************************************************************
28202!> \brief (parallel) Blocking collective file read using explicit offsets
28203!> (serial) Unformatted stream read
28204!> \param fh ...
28205!> \param offset ...
28206!> \param msg ...
28207!> \param msglen ...
28208!> \par MPI-I/O mapping mpi_file_read_at_all
28209!> \par STREAM-I/O mapping READ
28210! **************************************************************************************************
28211 SUBROUTINE mp_file_read_at_all_zv(fh, offset, msg, msglen)
28212 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
28213 CLASS(mp_file_type), INTENT(IN) :: fh
28214 INTEGER, INTENT(IN), OPTIONAL :: msglen
28215 INTEGER(kind=file_offset), INTENT(IN) :: offset
28216
28217 INTEGER :: msg_len
28218#if defined(__parallel)
28219 INTEGER :: ierr
28220#endif
28221
28222 msg_len = SIZE(msg)
28223 IF (PRESENT(msglen)) msg_len = msglen
28224#if defined(__parallel)
28225 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28226 IF (ierr .NE. 0) &
28227 cpabort("mpi_file_read_at_all_zv @ mp_file_read_at_all_zv")
28228#else
28229 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28230#endif
28231 END SUBROUTINE mp_file_read_at_all_zv
28232
28233! **************************************************************************************************
28234!> \brief ...
28235!> \param fh ...
28236!> \param offset ...
28237!> \param msg ...
28238! **************************************************************************************************
28239 SUBROUTINE mp_file_read_at_all_z (fh, offset, msg)
28240 COMPLEX(kind=real_8), INTENT(OUT) :: msg
28241 CLASS(mp_file_type), INTENT(IN) :: fh
28242 INTEGER(kind=file_offset), INTENT(IN) :: offset
28243
28244#if defined(__parallel)
28245 INTEGER :: ierr
28246
28247 ierr = 0
28248 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28249 IF (ierr .NE. 0) &
28250 cpabort("mpi_file_read_at_all_z @ mp_file_read_at_all_z")
28251#else
28252 READ (unit=fh%handle, pos=offset + 1) msg
28253#endif
28254 END SUBROUTINE mp_file_read_at_all_z
28255
28256! **************************************************************************************************
28257!> \brief ...
28258!> \param ptr ...
28259!> \param vector_descriptor ...
28260!> \param index_descriptor ...
28261!> \return ...
28262! **************************************************************************************************
28263 FUNCTION mp_type_make_z (ptr, &
28264 vector_descriptor, index_descriptor) &
28265 result(type_descriptor)
28266 COMPLEX(kind=real_8), DIMENSION(:), TARGET, asynchronous :: ptr
28267 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
28268 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
28269 TYPE(mp_type_descriptor_type) :: type_descriptor
28270
28271 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_z'
28272
28273#if defined(__parallel)
28274 INTEGER :: ierr
28275#if defined(__MPI_F08)
28276 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
28277 EXTERNAL :: mpi_get_address
28278#endif
28279#endif
28280
28281 NULLIFY (type_descriptor%subtype)
28282 type_descriptor%length = SIZE(ptr)
28283#if defined(__parallel)
28284 type_descriptor%type_handle = mpi_double_complex
28285 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
28286 IF (ierr /= 0) &
28287 cpabort("MPI_Get_address @ "//routinen)
28288#else
28289 type_descriptor%type_handle = 7
28290#endif
28291 type_descriptor%vector_descriptor(1:2) = 1
28292 type_descriptor%has_indexing = .false.
28293 type_descriptor%data_z => ptr
28294 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
28295 cpabort(routinen//": Vectors and indices NYI")
28296 END IF
28297 END FUNCTION mp_type_make_z
28298
28299! **************************************************************************************************
28300!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
28301!> as the Fortran version returns an integer, which we take to be a C_PTR
28302!> \param DATA data array to allocate
28303!> \param[in] len length (in data elements) of data array allocation
28304!> \param[out] stat (optional) allocation status result
28305! **************************************************************************************************
28306 SUBROUTINE mp_alloc_mem_z (DATA, len, stat)
28307 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: data
28308 INTEGER, INTENT(IN) :: len
28309 INTEGER, INTENT(OUT), OPTIONAL :: stat
28310
28311#if defined(__parallel)
28312 INTEGER :: size, ierr, length, &
28313 mp_res
28314 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
28315 TYPE(c_ptr) :: mp_baseptr
28316 mpi_info_type :: mp_info
28317
28318 length = max(len, 1)
28319 CALL mpi_type_size(mpi_double_complex, size, ierr)
28320 mp_size = int(length, kind=mpi_address_kind)*size
28321 IF (mp_size .GT. mp_max_memory_size) THEN
28322 cpabort("MPI cannot allocate more than 2 GiByte")
28323 END IF
28324 mp_info = mpi_info_null
28325 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
28326 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
28327 IF (PRESENT(stat)) stat = mp_res
28328#else
28329 INTEGER :: length, mystat
28330 length = max(len, 1)
28331 IF (PRESENT(stat)) THEN
28332 ALLOCATE (DATA(length), stat=mystat)
28333 stat = mystat ! show to convention checker that stat is used
28334 ELSE
28335 ALLOCATE (DATA(length))
28336 END IF
28337#endif
28338 END SUBROUTINE mp_alloc_mem_z
28339
28340! **************************************************************************************************
28341!> \brief Deallocates am array, ... this is hackish
28342!> as the Fortran version takes an integer, which we hope to get by reference
28343!> \param DATA data array to allocate
28344!> \param[out] stat (optional) allocation status result
28345! **************************************************************************************************
28346 SUBROUTINE mp_free_mem_z (DATA, stat)
28347 COMPLEX(kind=real_8), DIMENSION(:), &
28348 POINTER, asynchronous :: data
28349 INTEGER, INTENT(OUT), OPTIONAL :: stat
28350
28351#if defined(__parallel)
28352 INTEGER :: mp_res
28353 CALL mpi_free_mem(DATA, mp_res)
28354 IF (PRESENT(stat)) stat = mp_res
28355#else
28356 DEALLOCATE (data)
28357 IF (PRESENT(stat)) stat = 0
28358#endif
28359 END SUBROUTINE mp_free_mem_z
28360! **************************************************************************************************
28361!> \brief Shift around the data in msg
28362!> \param[in,out] msg Rank-2 data to shift
28363!> \param[in] comm message passing environment identifier
28364!> \param[in] displ_in displacements (?)
28365!> \par Example
28366!> msg will be moved from rank to rank+displ_in (in a circular way)
28367!> \par Limitations
28368!> * displ_in will be 1 by default (others not tested)
28369!> * the message array needs to be the same size on all processes
28370! **************************************************************************************************
28371 SUBROUTINE mp_shift_cm(msg, comm, displ_in)
28372
28373 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
28374 CLASS(mp_comm_type), INTENT(IN) :: comm
28375 INTEGER, INTENT(IN), OPTIONAL :: displ_in
28376
28377 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_cm'
28378
28379 INTEGER :: handle, ierror
28380#if defined(__parallel)
28381 INTEGER :: displ, left, &
28382 msglen, myrank, nprocs, &
28383 right, tag
28384#endif
28385
28386 ierror = 0
28387 CALL mp_timeset(routinen, handle)
28388
28389#if defined(__parallel)
28390 CALL mpi_comm_rank(comm%handle, myrank, ierror)
28391 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
28392 CALL mpi_comm_size(comm%handle, nprocs, ierror)
28393 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
28394 IF (PRESENT(displ_in)) THEN
28395 displ = displ_in
28396 ELSE
28397 displ = 1
28398 END IF
28399 right = modulo(myrank + displ, nprocs)
28400 left = modulo(myrank - displ, nprocs)
28401 tag = 17
28402 msglen = SIZE(msg)
28403 CALL mpi_sendrecv_replace(msg, msglen, mpi_complex, right, tag, left, tag, &
28404 comm%handle, mpi_status_ignore, ierror)
28405 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
28406 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_4_size))
28407#else
28408 mark_used(msg)
28409 mark_used(comm)
28410 mark_used(displ_in)
28411#endif
28412 CALL mp_timestop(handle)
28413
28414 END SUBROUTINE mp_shift_cm
28415
28416! **************************************************************************************************
28417!> \brief Shift around the data in msg
28418!> \param[in,out] msg Data to shift
28419!> \param[in] comm message passing environment identifier
28420!> \param[in] displ_in displacements (?)
28421!> \par Example
28422!> msg will be moved from rank to rank+displ_in (in a circular way)
28423!> \par Limitations
28424!> * displ_in will be 1 by default (others not tested)
28425!> * the message array needs to be the same size on all processes
28426! **************************************************************************************************
28427 SUBROUTINE mp_shift_c (msg, comm, displ_in)
28428
28429 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
28430 CLASS(mp_comm_type), INTENT(IN) :: comm
28431 INTEGER, INTENT(IN), OPTIONAL :: displ_in
28432
28433 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_c'
28434
28435 INTEGER :: handle, ierror
28436#if defined(__parallel)
28437 INTEGER :: displ, left, &
28438 msglen, myrank, nprocs, &
28439 right, tag
28440#endif
28441
28442 ierror = 0
28443 CALL mp_timeset(routinen, handle)
28444
28445#if defined(__parallel)
28446 CALL mpi_comm_rank(comm%handle, myrank, ierror)
28447 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
28448 CALL mpi_comm_size(comm%handle, nprocs, ierror)
28449 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
28450 IF (PRESENT(displ_in)) THEN
28451 displ = displ_in
28452 ELSE
28453 displ = 1
28454 END IF
28455 right = modulo(myrank + displ, nprocs)
28456 left = modulo(myrank - displ, nprocs)
28457 tag = 19
28458 msglen = SIZE(msg)
28459 CALL mpi_sendrecv_replace(msg, msglen, mpi_complex, right, tag, left, &
28460 tag, comm%handle, mpi_status_ignore, ierror)
28461 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
28462 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_4_size))
28463#else
28464 mark_used(msg)
28465 mark_used(comm)
28466 mark_used(displ_in)
28467#endif
28468 CALL mp_timestop(handle)
28469
28470 END SUBROUTINE mp_shift_c
28471
28472! **************************************************************************************************
28473!> \brief All-to-all data exchange, rank-1 data of different sizes
28474!> \param[in] sb Data to send
28475!> \param[in] scount Data counts for data sent to other processes
28476!> \param[in] sdispl Respective data offsets for data sent to process
28477!> \param[in,out] rb Buffer into which to receive data
28478!> \param[in] rcount Data counts for data received from other
28479!> processes
28480!> \param[in] rdispl Respective data offsets for data received from
28481!> other processes
28482!> \param[in] comm Message passing environment identifier
28483!> \par MPI mapping
28484!> mpi_alltoallv
28485!> \par Array sizes
28486!> The scount, rcount, and the sdispl and rdispl arrays have a
28487!> size equal to the number of processes.
28488!> \par Offsets
28489!> Values in sdispl and rdispl start with 0.
28490! **************************************************************************************************
28491 SUBROUTINE mp_alltoall_c11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
28492
28493 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
28494 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
28495 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
28496 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
28497 CLASS(mp_comm_type), INTENT(IN) :: comm
28498
28499 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c11v'
28500
28501 INTEGER :: handle
28502#if defined(__parallel)
28503 INTEGER :: ierr, msglen
28504#else
28505 INTEGER :: i
28506#endif
28507
28508 CALL mp_timeset(routinen, handle)
28509
28510#if defined(__parallel)
28511 CALL mpi_alltoallv(sb, scount, sdispl, mpi_complex, &
28512 rb, rcount, rdispl, mpi_complex, comm%handle, ierr)
28513 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
28514 msglen = sum(scount) + sum(rcount)
28515 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28516#else
28517 mark_used(comm)
28518 mark_used(scount)
28519 mark_used(sdispl)
28520 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
28521 DO i = 1, rcount(1)
28522 rb(rdispl(1) + i) = sb(sdispl(1) + i)
28523 END DO
28524#endif
28525 CALL mp_timestop(handle)
28526
28527 END SUBROUTINE mp_alltoall_c11v
28528
28529! **************************************************************************************************
28530!> \brief All-to-all data exchange, rank-2 data of different sizes
28531!> \param sb ...
28532!> \param scount ...
28533!> \param sdispl ...
28534!> \param rb ...
28535!> \param rcount ...
28536!> \param rdispl ...
28537!> \param comm ...
28538!> \par MPI mapping
28539!> mpi_alltoallv
28540!> \note see mp_alltoall_c11v
28541! **************************************************************************************************
28542 SUBROUTINE mp_alltoall_c22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
28543
28544 COMPLEX(kind=real_4), DIMENSION(:, :), &
28545 INTENT(IN), CONTIGUOUS :: sb
28546 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
28547 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, &
28548 INTENT(INOUT) :: rb
28549 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
28550 CLASS(mp_comm_type), INTENT(IN) :: comm
28551
28552 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c22v'
28553
28554 INTEGER :: handle
28555#if defined(__parallel)
28556 INTEGER :: ierr, msglen
28557#endif
28558
28559 CALL mp_timeset(routinen, handle)
28560
28561#if defined(__parallel)
28562 CALL mpi_alltoallv(sb, scount, sdispl, mpi_complex, &
28563 rb, rcount, rdispl, mpi_complex, comm%handle, ierr)
28564 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
28565 msglen = sum(scount) + sum(rcount)
28566 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*(2*real_4_size))
28567#else
28568 mark_used(comm)
28569 mark_used(scount)
28570 mark_used(sdispl)
28571 mark_used(rcount)
28572 mark_used(rdispl)
28573 rb = sb
28574#endif
28575 CALL mp_timestop(handle)
28576
28577 END SUBROUTINE mp_alltoall_c22v
28578
28579! **************************************************************************************************
28580!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
28581!> \param[in] sb array with data to send
28582!> \param[out] rb array into which data is received
28583!> \param[in] count number of elements to send/receive (product of the
28584!> extents of the first two dimensions)
28585!> \param[in] comm Message passing environment identifier
28586!> \par Index meaning
28587!> \par The first two indices specify the data while the last index counts
28588!> the processes
28589!> \par Sizes of ranks
28590!> All processes have the same data size.
28591!> \par MPI mapping
28592!> mpi_alltoall
28593! **************************************************************************************************
28594 SUBROUTINE mp_alltoall_c (sb, rb, count, comm)
28595
28596 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
28597 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
28598 INTEGER, INTENT(IN) :: count
28599 CLASS(mp_comm_type), INTENT(IN) :: comm
28600
28601 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c'
28602
28603 INTEGER :: handle
28604#if defined(__parallel)
28605 INTEGER :: ierr, msglen, np
28606#endif
28607
28608 CALL mp_timeset(routinen, handle)
28609
28610#if defined(__parallel)
28611 CALL mpi_alltoall(sb, count, mpi_complex, &
28612 rb, count, mpi_complex, comm%handle, ierr)
28613 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28614 CALL mpi_comm_size(comm%handle, np, ierr)
28615 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28616 msglen = 2*count*np
28617 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28618#else
28619 mark_used(count)
28620 mark_used(comm)
28621 rb = sb
28622#endif
28623 CALL mp_timestop(handle)
28624
28625 END SUBROUTINE mp_alltoall_c
28626
28627! **************************************************************************************************
28628!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
28629!> \param sb ...
28630!> \param rb ...
28631!> \param count ...
28632!> \param commp ...
28633!> \note see mp_alltoall_c
28634! **************************************************************************************************
28635 SUBROUTINE mp_alltoall_c22(sb, rb, count, comm)
28636
28637 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
28638 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
28639 INTEGER, INTENT(IN) :: count
28640 CLASS(mp_comm_type), INTENT(IN) :: comm
28641
28642 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c22'
28643
28644 INTEGER :: handle
28645#if defined(__parallel)
28646 INTEGER :: ierr, msglen, np
28647#endif
28648
28649 CALL mp_timeset(routinen, handle)
28650
28651#if defined(__parallel)
28652 CALL mpi_alltoall(sb, count, mpi_complex, &
28653 rb, count, mpi_complex, comm%handle, ierr)
28654 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28655 CALL mpi_comm_size(comm%handle, np, ierr)
28656 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28657 msglen = 2*SIZE(sb)*np
28658 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28659#else
28660 mark_used(count)
28661 mark_used(comm)
28662 rb = sb
28663#endif
28664 CALL mp_timestop(handle)
28665
28666 END SUBROUTINE mp_alltoall_c22
28667
28668! **************************************************************************************************
28669!> \brief All-to-all data exchange, rank-3 data with equal sizes
28670!> \param sb ...
28671!> \param rb ...
28672!> \param count ...
28673!> \param comm ...
28674!> \note see mp_alltoall_c
28675! **************************************************************************************************
28676 SUBROUTINE mp_alltoall_c33(sb, rb, count, comm)
28677
28678 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
28679 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
28680 INTEGER, INTENT(IN) :: count
28681 CLASS(mp_comm_type), INTENT(IN) :: comm
28682
28683 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c33'
28684
28685 INTEGER :: handle
28686#if defined(__parallel)
28687 INTEGER :: ierr, msglen, np
28688#endif
28689
28690 CALL mp_timeset(routinen, handle)
28691
28692#if defined(__parallel)
28693 CALL mpi_alltoall(sb, count, mpi_complex, &
28694 rb, count, mpi_complex, comm%handle, ierr)
28695 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28696 CALL mpi_comm_size(comm%handle, np, ierr)
28697 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28698 msglen = 2*count*np
28699 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28700#else
28701 mark_used(count)
28702 mark_used(comm)
28703 rb = sb
28704#endif
28705 CALL mp_timestop(handle)
28706
28707 END SUBROUTINE mp_alltoall_c33
28708
28709! **************************************************************************************************
28710!> \brief All-to-all data exchange, rank 4 data, equal sizes
28711!> \param sb ...
28712!> \param rb ...
28713!> \param count ...
28714!> \param comm ...
28715!> \note see mp_alltoall_c
28716! **************************************************************************************************
28717 SUBROUTINE mp_alltoall_c44(sb, rb, count, comm)
28718
28719 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28720 INTENT(IN) :: sb
28721 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28722 INTENT(OUT) :: rb
28723 INTEGER, INTENT(IN) :: count
28724 CLASS(mp_comm_type), INTENT(IN) :: comm
28725
28726 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c44'
28727
28728 INTEGER :: handle
28729#if defined(__parallel)
28730 INTEGER :: ierr, msglen, np
28731#endif
28732
28733 CALL mp_timeset(routinen, handle)
28734
28735#if defined(__parallel)
28736 CALL mpi_alltoall(sb, count, mpi_complex, &
28737 rb, count, mpi_complex, comm%handle, ierr)
28738 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28739 CALL mpi_comm_size(comm%handle, np, ierr)
28740 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28741 msglen = 2*count*np
28742 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28743#else
28744 mark_used(count)
28745 mark_used(comm)
28746 rb = sb
28747#endif
28748 CALL mp_timestop(handle)
28749
28750 END SUBROUTINE mp_alltoall_c44
28751
28752! **************************************************************************************************
28753!> \brief All-to-all data exchange, rank 5 data, equal sizes
28754!> \param sb ...
28755!> \param rb ...
28756!> \param count ...
28757!> \param comm ...
28758!> \note see mp_alltoall_c
28759! **************************************************************************************************
28760 SUBROUTINE mp_alltoall_c55(sb, rb, count, comm)
28761
28762 COMPLEX(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
28763 INTENT(IN) :: sb
28764 COMPLEX(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
28765 INTENT(OUT) :: rb
28766 INTEGER, INTENT(IN) :: count
28767 CLASS(mp_comm_type), INTENT(IN) :: comm
28768
28769 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c55'
28770
28771 INTEGER :: handle
28772#if defined(__parallel)
28773 INTEGER :: ierr, msglen, np
28774#endif
28775
28776 CALL mp_timeset(routinen, handle)
28777
28778#if defined(__parallel)
28779 CALL mpi_alltoall(sb, count, mpi_complex, &
28780 rb, count, mpi_complex, comm%handle, ierr)
28781 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28782 CALL mpi_comm_size(comm%handle, np, ierr)
28783 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28784 msglen = 2*count*np
28785 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28786#else
28787 mark_used(count)
28788 mark_used(comm)
28789 rb = sb
28790#endif
28791 CALL mp_timestop(handle)
28792
28793 END SUBROUTINE mp_alltoall_c55
28794
28795! **************************************************************************************************
28796!> \brief All-to-all data exchange, rank-4 data to rank-5 data
28797!> \param sb ...
28798!> \param rb ...
28799!> \param count ...
28800!> \param comm ...
28801!> \note see mp_alltoall_c
28802!> \note User must ensure size consistency.
28803! **************************************************************************************************
28804 SUBROUTINE mp_alltoall_c45(sb, rb, count, comm)
28805
28806 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28807 INTENT(IN) :: sb
28808 COMPLEX(kind=real_4), &
28809 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
28810 INTEGER, INTENT(IN) :: count
28811 CLASS(mp_comm_type), INTENT(IN) :: comm
28812
28813 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c45'
28814
28815 INTEGER :: handle
28816#if defined(__parallel)
28817 INTEGER :: ierr, msglen, np
28818#endif
28819
28820 CALL mp_timeset(routinen, handle)
28821
28822#if defined(__parallel)
28823 CALL mpi_alltoall(sb, count, mpi_complex, &
28824 rb, count, mpi_complex, comm%handle, ierr)
28825 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28826 CALL mpi_comm_size(comm%handle, np, ierr)
28827 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28828 msglen = 2*count*np
28829 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28830#else
28831 mark_used(count)
28832 mark_used(comm)
28833 rb = reshape(sb, shape(rb))
28834#endif
28835 CALL mp_timestop(handle)
28836
28837 END SUBROUTINE mp_alltoall_c45
28838
28839! **************************************************************************************************
28840!> \brief All-to-all data exchange, rank-3 data to rank-4 data
28841!> \param sb ...
28842!> \param rb ...
28843!> \param count ...
28844!> \param comm ...
28845!> \note see mp_alltoall_c
28846!> \note User must ensure size consistency.
28847! **************************************************************************************************
28848 SUBROUTINE mp_alltoall_c34(sb, rb, count, comm)
28849
28850 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, &
28851 INTENT(IN) :: sb
28852 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28853 INTENT(OUT) :: rb
28854 INTEGER, INTENT(IN) :: count
28855 CLASS(mp_comm_type), INTENT(IN) :: comm
28856
28857 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c34'
28858
28859 INTEGER :: handle
28860#if defined(__parallel)
28861 INTEGER :: ierr, msglen, np
28862#endif
28863
28864 CALL mp_timeset(routinen, handle)
28865
28866#if defined(__parallel)
28867 CALL mpi_alltoall(sb, count, mpi_complex, &
28868 rb, count, mpi_complex, comm%handle, ierr)
28869 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28870 CALL mpi_comm_size(comm%handle, np, ierr)
28871 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28872 msglen = 2*count*np
28873 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28874#else
28875 mark_used(count)
28876 mark_used(comm)
28877 rb = reshape(sb, shape(rb))
28878#endif
28879 CALL mp_timestop(handle)
28880
28881 END SUBROUTINE mp_alltoall_c34
28882
28883! **************************************************************************************************
28884!> \brief All-to-all data exchange, rank-5 data to rank-4 data
28885!> \param sb ...
28886!> \param rb ...
28887!> \param count ...
28888!> \param comm ...
28889!> \note see mp_alltoall_c
28890!> \note User must ensure size consistency.
28891! **************************************************************************************************
28892 SUBROUTINE mp_alltoall_c54(sb, rb, count, comm)
28893
28894 COMPLEX(kind=real_4), &
28895 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
28896 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28897 INTENT(OUT) :: rb
28898 INTEGER, INTENT(IN) :: count
28899 CLASS(mp_comm_type), INTENT(IN) :: comm
28900
28901 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c54'
28902
28903 INTEGER :: handle
28904#if defined(__parallel)
28905 INTEGER :: ierr, msglen, np
28906#endif
28907
28908 CALL mp_timeset(routinen, handle)
28909
28910#if defined(__parallel)
28911 CALL mpi_alltoall(sb, count, mpi_complex, &
28912 rb, count, mpi_complex, comm%handle, ierr)
28913 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28914 CALL mpi_comm_size(comm%handle, np, ierr)
28915 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28916 msglen = 2*count*np
28917 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28918#else
28919 mark_used(count)
28920 mark_used(comm)
28921 rb = reshape(sb, shape(rb))
28922#endif
28923 CALL mp_timestop(handle)
28924
28925 END SUBROUTINE mp_alltoall_c54
28926
28927! **************************************************************************************************
28928!> \brief Send one datum to another process
28929!> \param[in] msg Scalar to send
28930!> \param[in] dest Destination process
28931!> \param[in] tag Transfer identifier
28932!> \param[in] comm Message passing environment identifier
28933!> \par MPI mapping
28934!> mpi_send
28935! **************************************************************************************************
28936 SUBROUTINE mp_send_c (msg, dest, tag, comm)
28937 COMPLEX(kind=real_4), INTENT(IN) :: msg
28938 INTEGER, INTENT(IN) :: dest, tag
28939 CLASS(mp_comm_type), INTENT(IN) :: comm
28940
28941 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_c'
28942
28943 INTEGER :: handle
28944#if defined(__parallel)
28945 INTEGER :: ierr, msglen
28946#endif
28947
28948 CALL mp_timeset(routinen, handle)
28949
28950#if defined(__parallel)
28951 msglen = 1
28952 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
28953 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
28954 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
28955#else
28956 mark_used(msg)
28957 mark_used(dest)
28958 mark_used(tag)
28959 mark_used(comm)
28960 ! only defined in parallel
28961 cpabort("not in parallel mode")
28962#endif
28963 CALL mp_timestop(handle)
28964 END SUBROUTINE mp_send_c
28965
28966! **************************************************************************************************
28967!> \brief Send rank-1 data to another process
28968!> \param[in] msg Rank-1 data to send
28969!> \param dest ...
28970!> \param tag ...
28971!> \param comm ...
28972!> \note see mp_send_c
28973! **************************************************************************************************
28974 SUBROUTINE mp_send_cv(msg, dest, tag, comm)
28975 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
28976 INTEGER, INTENT(IN) :: dest, tag
28977 CLASS(mp_comm_type), INTENT(IN) :: comm
28978
28979 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_cv'
28980
28981 INTEGER :: handle
28982#if defined(__parallel)
28983 INTEGER :: ierr, msglen
28984#endif
28985
28986 CALL mp_timeset(routinen, handle)
28987
28988#if defined(__parallel)
28989 msglen = SIZE(msg)
28990 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
28991 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
28992 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
28993#else
28994 mark_used(msg)
28995 mark_used(dest)
28996 mark_used(tag)
28997 mark_used(comm)
28998 ! only defined in parallel
28999 cpabort("not in parallel mode")
29000#endif
29001 CALL mp_timestop(handle)
29002 END SUBROUTINE mp_send_cv
29003
29004! **************************************************************************************************
29005!> \brief Send rank-2 data to another process
29006!> \param[in] msg Rank-2 data to send
29007!> \param dest ...
29008!> \param tag ...
29009!> \param comm ...
29010!> \note see mp_send_c
29011! **************************************************************************************************
29012 SUBROUTINE mp_send_cm2(msg, dest, tag, comm)
29013 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
29014 INTEGER, INTENT(IN) :: dest, tag
29015 CLASS(mp_comm_type), INTENT(IN) :: comm
29016
29017 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_cm2'
29018
29019 INTEGER :: handle
29020#if defined(__parallel)
29021 INTEGER :: ierr, msglen
29022#endif
29023
29024 CALL mp_timeset(routinen, handle)
29025
29026#if defined(__parallel)
29027 msglen = SIZE(msg)
29028 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29029 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29030 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29031#else
29032 mark_used(msg)
29033 mark_used(dest)
29034 mark_used(tag)
29035 mark_used(comm)
29036 ! only defined in parallel
29037 cpabort("not in parallel mode")
29038#endif
29039 CALL mp_timestop(handle)
29040 END SUBROUTINE mp_send_cm2
29041
29042! **************************************************************************************************
29043!> \brief Send rank-3 data to another process
29044!> \param[in] msg Rank-3 data to send
29045!> \param dest ...
29046!> \param tag ...
29047!> \param comm ...
29048!> \note see mp_send_c
29049! **************************************************************************************************
29050 SUBROUTINE mp_send_cm3(msg, dest, tag, comm)
29051 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
29052 INTEGER, INTENT(IN) :: dest, tag
29053 CLASS(mp_comm_type), INTENT(IN) :: comm
29054
29055 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
29056
29057 INTEGER :: handle
29058#if defined(__parallel)
29059 INTEGER :: ierr, msglen
29060#endif
29061
29062 CALL mp_timeset(routinen, handle)
29063
29064#if defined(__parallel)
29065 msglen = SIZE(msg)
29066 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29067 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29068 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29069#else
29070 mark_used(msg)
29071 mark_used(dest)
29072 mark_used(tag)
29073 mark_used(comm)
29074 ! only defined in parallel
29075 cpabort("not in parallel mode")
29076#endif
29077 CALL mp_timestop(handle)
29078 END SUBROUTINE mp_send_cm3
29079
29080! **************************************************************************************************
29081!> \brief Receive one datum from another process
29082!> \param[in,out] msg Place received data into this variable
29083!> \param[in,out] source Process to receive from
29084!> \param[in,out] tag Transfer identifier
29085!> \param[in] comm Message passing environment identifier
29086!> \par MPI mapping
29087!> mpi_send
29088! **************************************************************************************************
29089 SUBROUTINE mp_recv_c (msg, source, tag, comm)
29090 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29091 INTEGER, INTENT(INOUT) :: source, tag
29092 CLASS(mp_comm_type), INTENT(IN) :: comm
29093
29094 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_c'
29095
29096 INTEGER :: handle
29097#if defined(__parallel)
29098 INTEGER :: ierr, msglen
29099 mpi_status_type :: status
29100#endif
29101
29102 CALL mp_timeset(routinen, handle)
29103
29104#if defined(__parallel)
29105 msglen = 1
29106 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29107 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29108 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29109 ELSE
29110 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29111 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29112 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29113 source = status mpi_status_extract(mpi_source)
29114 tag = status mpi_status_extract(mpi_tag)
29115 END IF
29116#else
29117 mark_used(msg)
29118 mark_used(source)
29119 mark_used(tag)
29120 mark_used(comm)
29121 ! only defined in parallel
29122 cpabort("not in parallel mode")
29123#endif
29124 CALL mp_timestop(handle)
29125 END SUBROUTINE mp_recv_c
29126
29127! **************************************************************************************************
29128!> \brief Receive rank-1 data from another process
29129!> \param[in,out] msg Place received data into this rank-1 array
29130!> \param source ...
29131!> \param tag ...
29132!> \param comm ...
29133!> \note see mp_recv_c
29134! **************************************************************************************************
29135 SUBROUTINE mp_recv_cv(msg, source, tag, comm)
29136 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29137 INTEGER, INTENT(INOUT) :: source, tag
29138 CLASS(mp_comm_type), INTENT(IN) :: comm
29139
29140 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cv'
29141
29142 INTEGER :: handle
29143#if defined(__parallel)
29144 INTEGER :: ierr, msglen
29145 mpi_status_type :: status
29146#endif
29147
29148 CALL mp_timeset(routinen, handle)
29149
29150#if defined(__parallel)
29151 msglen = SIZE(msg)
29152 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29153 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29154 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29155 ELSE
29156 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29157 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29158 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29159 source = status mpi_status_extract(mpi_source)
29160 tag = status mpi_status_extract(mpi_tag)
29161 END IF
29162#else
29163 mark_used(msg)
29164 mark_used(source)
29165 mark_used(tag)
29166 mark_used(comm)
29167 ! only defined in parallel
29168 cpabort("not in parallel mode")
29169#endif
29170 CALL mp_timestop(handle)
29171 END SUBROUTINE mp_recv_cv
29172
29173! **************************************************************************************************
29174!> \brief Receive rank-2 data from another process
29175!> \param[in,out] msg Place received data into this rank-2 array
29176!> \param source ...
29177!> \param tag ...
29178!> \param comm ...
29179!> \note see mp_recv_c
29180! **************************************************************************************************
29181 SUBROUTINE mp_recv_cm2(msg, source, tag, comm)
29182 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29183 INTEGER, INTENT(INOUT) :: source, tag
29184 CLASS(mp_comm_type), INTENT(IN) :: comm
29185
29186 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cm2'
29187
29188 INTEGER :: handle
29189#if defined(__parallel)
29190 INTEGER :: ierr, msglen
29191 mpi_status_type :: status
29192#endif
29193
29194 CALL mp_timeset(routinen, handle)
29195
29196#if defined(__parallel)
29197 msglen = SIZE(msg)
29198 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29199 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29200 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29201 ELSE
29202 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29203 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29204 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29205 source = status mpi_status_extract(mpi_source)
29206 tag = status mpi_status_extract(mpi_tag)
29207 END IF
29208#else
29209 mark_used(msg)
29210 mark_used(source)
29211 mark_used(tag)
29212 mark_used(comm)
29213 ! only defined in parallel
29214 cpabort("not in parallel mode")
29215#endif
29216 CALL mp_timestop(handle)
29217 END SUBROUTINE mp_recv_cm2
29218
29219! **************************************************************************************************
29220!> \brief Receive rank-3 data from another process
29221!> \param[in,out] msg Place received data into this rank-3 array
29222!> \param source ...
29223!> \param tag ...
29224!> \param comm ...
29225!> \note see mp_recv_c
29226! **************************************************************************************************
29227 SUBROUTINE mp_recv_cm3(msg, source, tag, comm)
29228 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
29229 INTEGER, INTENT(INOUT) :: source, tag
29230 CLASS(mp_comm_type), INTENT(IN) :: comm
29231
29232 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cm3'
29233
29234 INTEGER :: handle
29235#if defined(__parallel)
29236 INTEGER :: ierr, msglen
29237 mpi_status_type :: status
29238#endif
29239
29240 CALL mp_timeset(routinen, handle)
29241
29242#if defined(__parallel)
29243 msglen = SIZE(msg)
29244 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29245 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29246 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29247 ELSE
29248 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29249 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29250 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29251 source = status mpi_status_extract(mpi_source)
29252 tag = status mpi_status_extract(mpi_tag)
29253 END IF
29254#else
29255 mark_used(msg)
29256 mark_used(source)
29257 mark_used(tag)
29258 mark_used(comm)
29259 ! only defined in parallel
29260 cpabort("not in parallel mode")
29261#endif
29262 CALL mp_timestop(handle)
29263 END SUBROUTINE mp_recv_cm3
29264
29265! **************************************************************************************************
29266!> \brief Broadcasts a datum to all processes.
29267!> \param[in] msg Datum to broadcast
29268!> \param[in] source Processes which broadcasts
29269!> \param[in] comm Message passing environment identifier
29270!> \par MPI mapping
29271!> mpi_bcast
29272! **************************************************************************************************
29273 SUBROUTINE mp_bcast_c (msg, source, comm)
29274 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29275 INTEGER, INTENT(IN) :: source
29276 CLASS(mp_comm_type), INTENT(IN) :: comm
29277
29278 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c'
29279
29280 INTEGER :: handle
29281#if defined(__parallel)
29282 INTEGER :: ierr, msglen
29283#endif
29284
29285 CALL mp_timeset(routinen, handle)
29286
29287#if defined(__parallel)
29288 msglen = 1
29289 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29290 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29291 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29292#else
29293 mark_used(msg)
29294 mark_used(source)
29295 mark_used(comm)
29296#endif
29297 CALL mp_timestop(handle)
29298 END SUBROUTINE mp_bcast_c
29299
29300! **************************************************************************************************
29301!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
29302!> \param[in] msg Datum to broadcast
29303!> \param[in] comm Message passing environment identifier
29304!> \par MPI mapping
29305!> mpi_bcast
29306! **************************************************************************************************
29307 SUBROUTINE mp_bcast_c_src(msg, comm)
29308 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29309 CLASS(mp_comm_type), INTENT(IN) :: comm
29310
29311 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c_src'
29312
29313 INTEGER :: handle
29314#if defined(__parallel)
29315 INTEGER :: ierr, msglen
29316#endif
29317
29318 CALL mp_timeset(routinen, handle)
29319
29320#if defined(__parallel)
29321 msglen = 1
29322 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29323 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29324 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29325#else
29326 mark_used(msg)
29327 mark_used(comm)
29328#endif
29329 CALL mp_timestop(handle)
29330 END SUBROUTINE mp_bcast_c_src
29331
29332! **************************************************************************************************
29333!> \brief Broadcasts a datum to all processes.
29334!> \param[in] msg Datum to broadcast
29335!> \param[in] source Processes which broadcasts
29336!> \param[in] comm Message passing environment identifier
29337!> \par MPI mapping
29338!> mpi_bcast
29339! **************************************************************************************************
29340 SUBROUTINE mp_ibcast_c (msg, source, comm, request)
29341 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29342 INTEGER, INTENT(IN) :: source
29343 CLASS(mp_comm_type), INTENT(IN) :: comm
29344 TYPE(mp_request_type), INTENT(OUT) :: request
29345
29346 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_c'
29347
29348 INTEGER :: handle
29349#if defined(__parallel)
29350 INTEGER :: ierr, msglen
29351#endif
29352
29353 CALL mp_timeset(routinen, handle)
29354
29355#if defined(__parallel)
29356 msglen = 1
29357 CALL mpi_ibcast(msg, msglen, mpi_complex, source, comm%handle, request%handle, ierr)
29358 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
29359 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_4_size))
29360#else
29361 mark_used(msg)
29362 mark_used(source)
29363 mark_used(comm)
29364 request = mp_request_null
29365#endif
29366 CALL mp_timestop(handle)
29367 END SUBROUTINE mp_ibcast_c
29368
29369! **************************************************************************************************
29370!> \brief Broadcasts rank-1 data to all processes
29371!> \param[in] msg Data to broadcast
29372!> \param source ...
29373!> \param comm ...
29374!> \note see mp_bcast_c1
29375! **************************************************************************************************
29376 SUBROUTINE mp_bcast_cv(msg, source, comm)
29377 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29378 INTEGER, INTENT(IN) :: source
29379 CLASS(mp_comm_type), INTENT(IN) :: comm
29380
29381 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cv'
29382
29383 INTEGER :: handle
29384#if defined(__parallel)
29385 INTEGER :: ierr, msglen
29386#endif
29387
29388 CALL mp_timeset(routinen, handle)
29389
29390#if defined(__parallel)
29391 msglen = SIZE(msg)
29392 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29393 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29394 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29395#else
29396 mark_used(msg)
29397 mark_used(source)
29398 mark_used(comm)
29399#endif
29400 CALL mp_timestop(handle)
29401 END SUBROUTINE mp_bcast_cv
29402
29403! **************************************************************************************************
29404!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
29405!> \param[in] msg Data to broadcast
29406!> \param comm ...
29407!> \note see mp_bcast_c1
29408! **************************************************************************************************
29409 SUBROUTINE mp_bcast_cv_src(msg, comm)
29410 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29411 CLASS(mp_comm_type), INTENT(IN) :: comm
29412
29413 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cv_src'
29414
29415 INTEGER :: handle
29416#if defined(__parallel)
29417 INTEGER :: ierr, msglen
29418#endif
29419
29420 CALL mp_timeset(routinen, handle)
29421
29422#if defined(__parallel)
29423 msglen = SIZE(msg)
29424 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29425 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29426 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29427#else
29428 mark_used(msg)
29429 mark_used(comm)
29430#endif
29431 CALL mp_timestop(handle)
29432 END SUBROUTINE mp_bcast_cv_src
29433
29434! **************************************************************************************************
29435!> \brief Broadcasts rank-1 data to all processes
29436!> \param[in] msg Data to broadcast
29437!> \param source ...
29438!> \param comm ...
29439!> \note see mp_bcast_c1
29440! **************************************************************************************************
29441 SUBROUTINE mp_ibcast_cv(msg, source, comm, request)
29442 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
29443 INTEGER, INTENT(IN) :: source
29444 CLASS(mp_comm_type), INTENT(IN) :: comm
29445 TYPE(mp_request_type) :: request
29446
29447 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_cv'
29448
29449 INTEGER :: handle
29450#if defined(__parallel)
29451 INTEGER :: ierr, msglen
29452#endif
29453
29454 CALL mp_timeset(routinen, handle)
29455
29456#if defined(__parallel)
29457#if !defined(__GNUC__) || __GNUC__ >= 9
29458 cpassert(is_contiguous(msg))
29459#endif
29460 msglen = SIZE(msg)
29461 CALL mpi_ibcast(msg, msglen, mpi_complex, source, comm%handle, request%handle, ierr)
29462 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
29463 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_4_size))
29464#else
29465 mark_used(msg)
29466 mark_used(source)
29467 mark_used(comm)
29468 request = mp_request_null
29469#endif
29470 CALL mp_timestop(handle)
29471 END SUBROUTINE mp_ibcast_cv
29472
29473! **************************************************************************************************
29474!> \brief Broadcasts rank-2 data to all processes
29475!> \param[in] msg Data to broadcast
29476!> \param source ...
29477!> \param comm ...
29478!> \note see mp_bcast_c1
29479! **************************************************************************************************
29480 SUBROUTINE mp_bcast_cm(msg, source, comm)
29481 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29482 INTEGER, INTENT(IN) :: source
29483 CLASS(mp_comm_type), INTENT(IN) :: comm
29484
29485 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cm'
29486
29487 INTEGER :: handle
29488#if defined(__parallel)
29489 INTEGER :: ierr, msglen
29490#endif
29491
29492 CALL mp_timeset(routinen, handle)
29493
29494#if defined(__parallel)
29495 msglen = SIZE(msg)
29496 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29497 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29498 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29499#else
29500 mark_used(msg)
29501 mark_used(source)
29502 mark_used(comm)
29503#endif
29504 CALL mp_timestop(handle)
29505 END SUBROUTINE mp_bcast_cm
29506
29507! **************************************************************************************************
29508!> \brief Broadcasts rank-2 data to all processes
29509!> \param[in] msg Data to broadcast
29510!> \param source ...
29511!> \param comm ...
29512!> \note see mp_bcast_c1
29513! **************************************************************************************************
29514 SUBROUTINE mp_bcast_cm_src(msg, comm)
29515 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29516 CLASS(mp_comm_type), INTENT(IN) :: comm
29517
29518 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cm_src'
29519
29520 INTEGER :: handle
29521#if defined(__parallel)
29522 INTEGER :: ierr, msglen
29523#endif
29524
29525 CALL mp_timeset(routinen, handle)
29526
29527#if defined(__parallel)
29528 msglen = SIZE(msg)
29529 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29530 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29531 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29532#else
29533 mark_used(msg)
29534 mark_used(comm)
29535#endif
29536 CALL mp_timestop(handle)
29537 END SUBROUTINE mp_bcast_cm_src
29538
29539! **************************************************************************************************
29540!> \brief Broadcasts rank-3 data to all processes
29541!> \param[in] msg Data to broadcast
29542!> \param source ...
29543!> \param comm ...
29544!> \note see mp_bcast_c1
29545! **************************************************************************************************
29546 SUBROUTINE mp_bcast_c3(msg, source, comm)
29547 COMPLEX(kind=real_4), CONTIGUOUS :: msg(:, :, :)
29548 INTEGER, INTENT(IN) :: source
29549 CLASS(mp_comm_type), INTENT(IN) :: comm
29550
29551 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c3'
29552
29553 INTEGER :: handle
29554#if defined(__parallel)
29555 INTEGER :: ierr, msglen
29556#endif
29557
29558 CALL mp_timeset(routinen, handle)
29559
29560#if defined(__parallel)
29561 msglen = SIZE(msg)
29562 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29563 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29564 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29565#else
29566 mark_used(msg)
29567 mark_used(source)
29568 mark_used(comm)
29569#endif
29570 CALL mp_timestop(handle)
29571 END SUBROUTINE mp_bcast_c3
29572
29573! **************************************************************************************************
29574!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
29575!> \param[in] msg Data to broadcast
29576!> \param source ...
29577!> \param comm ...
29578!> \note see mp_bcast_c1
29579! **************************************************************************************************
29580 SUBROUTINE mp_bcast_c3_src(msg, comm)
29581 COMPLEX(kind=real_4), CONTIGUOUS :: msg(:, :, :)
29582 CLASS(mp_comm_type), INTENT(IN) :: comm
29583
29584 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c3_src'
29585
29586 INTEGER :: handle
29587#if defined(__parallel)
29588 INTEGER :: ierr, msglen
29589#endif
29590
29591 CALL mp_timeset(routinen, handle)
29592
29593#if defined(__parallel)
29594 msglen = SIZE(msg)
29595 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29596 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29597 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29598#else
29599 mark_used(msg)
29600 mark_used(comm)
29601#endif
29602 CALL mp_timestop(handle)
29603 END SUBROUTINE mp_bcast_c3_src
29604
29605! **************************************************************************************************
29606!> \brief Sums a datum from all processes with result left on all processes.
29607!> \param[in,out] msg Datum to sum (input) and result (output)
29608!> \param[in] comm Message passing environment identifier
29609!> \par MPI mapping
29610!> mpi_allreduce
29611! **************************************************************************************************
29612 SUBROUTINE mp_sum_c (msg, comm)
29613 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29614 CLASS(mp_comm_type), INTENT(IN) :: comm
29615
29616 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_c'
29617
29618 INTEGER :: handle
29619#if defined(__parallel)
29620 INTEGER :: ierr, msglen
29621#endif
29622
29623 CALL mp_timeset(routinen, handle)
29624
29625#if defined(__parallel)
29626 msglen = 1
29627 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29628 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29629 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29630#else
29631 mark_used(msg)
29632 mark_used(comm)
29633#endif
29634 CALL mp_timestop(handle)
29635 END SUBROUTINE mp_sum_c
29636
29637! **************************************************************************************************
29638!> \brief Element-wise sum of a rank-1 array on all processes.
29639!> \param[in,out] msg Vector to sum and result
29640!> \param comm ...
29641!> \note see mp_sum_c
29642! **************************************************************************************************
29643 SUBROUTINE mp_sum_cv(msg, comm)
29644 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29645 CLASS(mp_comm_type), INTENT(IN) :: comm
29646
29647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cv'
29648
29649 INTEGER :: handle
29650#if defined(__parallel)
29651 INTEGER :: ierr, msglen
29652#endif
29653
29654 CALL mp_timeset(routinen, handle)
29655
29656#if defined(__parallel)
29657 msglen = SIZE(msg)
29658 IF (msglen > 0) THEN
29659 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29660 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29661 END IF
29662 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29663#else
29664 mark_used(msg)
29665 mark_used(comm)
29666#endif
29667 CALL mp_timestop(handle)
29668 END SUBROUTINE mp_sum_cv
29669
29670! **************************************************************************************************
29671!> \brief Element-wise sum of a rank-1 array on all processes.
29672!> \param[in,out] msg Vector to sum and result
29673!> \param comm ...
29674!> \note see mp_sum_c
29675! **************************************************************************************************
29676 SUBROUTINE mp_isum_cv(msg, comm, request)
29677 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
29678 CLASS(mp_comm_type), INTENT(IN) :: comm
29679 TYPE(mp_request_type), INTENT(OUT) :: request
29680
29681 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_cv'
29682
29683 INTEGER :: handle
29684#if defined(__parallel)
29685 INTEGER :: ierr, msglen
29686#endif
29687
29688 CALL mp_timeset(routinen, handle)
29689
29690#if defined(__parallel)
29691#if !defined(__GNUC__) || __GNUC__ >= 9
29692 cpassert(is_contiguous(msg))
29693#endif
29694 msglen = SIZE(msg)
29695 IF (msglen > 0) THEN
29696 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, request%handle, ierr)
29697 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
29698 ELSE
29699 request = mp_request_null
29700 END IF
29701 CALL add_perf(perf_id=23, count=1, msg_size=msglen*(2*real_4_size))
29702#else
29703 mark_used(msg)
29704 mark_used(comm)
29705 request = mp_request_null
29706#endif
29707 CALL mp_timestop(handle)
29708 END SUBROUTINE mp_isum_cv
29709
29710! **************************************************************************************************
29711!> \brief Element-wise sum of a rank-2 array on all processes.
29712!> \param[in] msg Matrix to sum and result
29713!> \param comm ...
29714!> \note see mp_sum_c
29715! **************************************************************************************************
29716 SUBROUTINE mp_sum_cm(msg, comm)
29717 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29718 CLASS(mp_comm_type), INTENT(IN) :: comm
29719
29720 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm'
29721
29722 INTEGER :: handle
29723#if defined(__parallel)
29724 INTEGER, PARAMETER :: max_msg = 2**25
29725 INTEGER :: ierr, m1, msglen, step, msglensum
29726#endif
29727
29728 CALL mp_timeset(routinen, handle)
29729
29730#if defined(__parallel)
29731 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
29732 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
29733 msglensum = 0
29734 DO m1 = lbound(msg, 2), ubound(msg, 2), step
29735 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
29736 msglensum = msglensum + msglen
29737 IF (msglen > 0) THEN
29738 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29739 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29740 END IF
29741 END DO
29742 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_4_size))
29743#else
29744 mark_used(msg)
29745 mark_used(comm)
29746#endif
29747 CALL mp_timestop(handle)
29748 END SUBROUTINE mp_sum_cm
29749
29750! **************************************************************************************************
29751!> \brief Element-wise sum of a rank-3 array on all processes.
29752!> \param[in] msg Array to sum and result
29753!> \param comm ...
29754!> \note see mp_sum_c
29755! **************************************************************************************************
29756 SUBROUTINE mp_sum_cm3(msg, comm)
29757 COMPLEX(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
29758 CLASS(mp_comm_type), INTENT(IN) :: comm
29759
29760 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm3'
29761
29762 INTEGER :: handle
29763#if defined(__parallel)
29764 INTEGER :: ierr, msglen
29765#endif
29766
29767 CALL mp_timeset(routinen, handle)
29768
29769#if defined(__parallel)
29770 msglen = SIZE(msg)
29771 IF (msglen > 0) THEN
29772 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29773 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29774 END IF
29775 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29776#else
29777 mark_used(msg)
29778 mark_used(comm)
29779#endif
29780 CALL mp_timestop(handle)
29781 END SUBROUTINE mp_sum_cm3
29782
29783! **************************************************************************************************
29784!> \brief Element-wise sum of a rank-4 array on all processes.
29785!> \param[in] msg Array to sum and result
29786!> \param comm ...
29787!> \note see mp_sum_c
29788! **************************************************************************************************
29789 SUBROUTINE mp_sum_cm4(msg, comm)
29790 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
29791 CLASS(mp_comm_type), INTENT(IN) :: comm
29792
29793 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm4'
29794
29795 INTEGER :: handle
29796#if defined(__parallel)
29797 INTEGER :: ierr, msglen
29798#endif
29799
29800 CALL mp_timeset(routinen, handle)
29801
29802#if defined(__parallel)
29803 msglen = SIZE(msg)
29804 IF (msglen > 0) THEN
29805 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29806 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29807 END IF
29808 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29809#else
29810 mark_used(msg)
29811 mark_used(comm)
29812#endif
29813 CALL mp_timestop(handle)
29814 END SUBROUTINE mp_sum_cm4
29815
29816! **************************************************************************************************
29817!> \brief Element-wise sum of data from all processes with result left only on
29818!> one.
29819!> \param[in,out] msg Vector to sum (input) and (only on process root)
29820!> result (output)
29821!> \param root ...
29822!> \param[in] comm Message passing environment identifier
29823!> \par MPI mapping
29824!> mpi_reduce
29825! **************************************************************************************************
29826 SUBROUTINE mp_sum_root_cv(msg, root, comm)
29827 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29828 INTEGER, INTENT(IN) :: root
29829 CLASS(mp_comm_type), INTENT(IN) :: comm
29830
29831 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_cv'
29832
29833 INTEGER :: handle
29834#if defined(__parallel)
29835 INTEGER :: ierr, m1, msglen, taskid
29836 COMPLEX(kind=real_4), ALLOCATABLE :: res(:)
29837#endif
29838
29839 CALL mp_timeset(routinen, handle)
29840
29841#if defined(__parallel)
29842 msglen = SIZE(msg)
29843 CALL mpi_comm_rank(comm%handle, taskid, ierr)
29844 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
29845 IF (msglen > 0) THEN
29846 m1 = SIZE(msg, 1)
29847 ALLOCATE (res(m1))
29848 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_sum, &
29849 root, comm%handle, ierr)
29850 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
29851 IF (taskid == root) THEN
29852 msg = res
29853 END IF
29854 DEALLOCATE (res)
29855 END IF
29856 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29857#else
29858 mark_used(msg)
29859 mark_used(root)
29860 mark_used(comm)
29861#endif
29862 CALL mp_timestop(handle)
29863 END SUBROUTINE mp_sum_root_cv
29864
29865! **************************************************************************************************
29866!> \brief Element-wise sum of data from all processes with result left only on
29867!> one.
29868!> \param[in,out] msg Matrix to sum (input) and (only on process root)
29869!> result (output)
29870!> \param root ...
29871!> \param comm ...
29872!> \note see mp_sum_root_cv
29873! **************************************************************************************************
29874 SUBROUTINE mp_sum_root_cm(msg, root, comm)
29875 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29876 INTEGER, INTENT(IN) :: root
29877 CLASS(mp_comm_type), INTENT(IN) :: comm
29878
29879 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
29880
29881 INTEGER :: handle
29882#if defined(__parallel)
29883 INTEGER :: ierr, m1, m2, msglen, taskid
29884 COMPLEX(kind=real_4), ALLOCATABLE :: res(:, :)
29885#endif
29886
29887 CALL mp_timeset(routinen, handle)
29888
29889#if defined(__parallel)
29890 msglen = SIZE(msg)
29891 CALL mpi_comm_rank(comm%handle, taskid, ierr)
29892 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
29893 IF (msglen > 0) THEN
29894 m1 = SIZE(msg, 1)
29895 m2 = SIZE(msg, 2)
29896 ALLOCATE (res(m1, m2))
29897 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_sum, root, comm%handle, ierr)
29898 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
29899 IF (taskid == root) THEN
29900 msg = res
29901 END IF
29902 DEALLOCATE (res)
29903 END IF
29904 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29905#else
29906 mark_used(root)
29907 mark_used(msg)
29908 mark_used(comm)
29909#endif
29910 CALL mp_timestop(handle)
29911 END SUBROUTINE mp_sum_root_cm
29912
29913! **************************************************************************************************
29914!> \brief Partial sum of data from all processes with result on each process.
29915!> \param[in] msg Matrix to sum (input)
29916!> \param[out] res Matrix containing result (output)
29917!> \param[in] comm Message passing environment identifier
29918! **************************************************************************************************
29919 SUBROUTINE mp_sum_partial_cm(msg, res, comm)
29920 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
29921 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
29922 CLASS(mp_comm_type), INTENT(IN) :: comm
29923
29924 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_cm'
29925
29926 INTEGER :: handle
29927#if defined(__parallel)
29928 INTEGER :: ierr, msglen, taskid
29929#endif
29930
29931 CALL mp_timeset(routinen, handle)
29932
29933#if defined(__parallel)
29934 msglen = SIZE(msg)
29935 CALL mpi_comm_rank(comm%handle, taskid, ierr)
29936 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
29937 IF (msglen > 0) THEN
29938 CALL mpi_scan(msg, res, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29939 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
29940 END IF
29941 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29942 ! perf_id is same as for other summation routines
29943#else
29944 res = msg
29945 mark_used(comm)
29946#endif
29947 CALL mp_timestop(handle)
29948 END SUBROUTINE mp_sum_partial_cm
29949
29950! **************************************************************************************************
29951!> \brief Finds the maximum of a datum with the result left on all processes.
29952!> \param[in,out] msg Find maximum among these data (input) and
29953!> maximum (output)
29954!> \param[in] comm Message passing environment identifier
29955!> \par MPI mapping
29956!> mpi_allreduce
29957! **************************************************************************************************
29958 SUBROUTINE mp_max_c (msg, comm)
29959 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29960 CLASS(mp_comm_type), INTENT(IN) :: comm
29961
29962 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_c'
29963
29964 INTEGER :: handle
29965#if defined(__parallel)
29966 INTEGER :: ierr, msglen
29967#endif
29968
29969 CALL mp_timeset(routinen, handle)
29970
29971#if defined(__parallel)
29972 msglen = 1
29973 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_max, comm%handle, ierr)
29974 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29975 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29976#else
29977 mark_used(msg)
29978 mark_used(comm)
29979#endif
29980 CALL mp_timestop(handle)
29981 END SUBROUTINE mp_max_c
29982
29983! **************************************************************************************************
29984!> \brief Finds the maximum of a datum with the result left on all processes.
29985!> \param[in,out] msg Find maximum among these data (input) and
29986!> maximum (output)
29987!> \param[in] comm Message passing environment identifier
29988!> \par MPI mapping
29989!> mpi_allreduce
29990! **************************************************************************************************
29991 SUBROUTINE mp_max_root_c (msg, root, comm)
29992 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29993 INTEGER, INTENT(IN) :: root
29994 CLASS(mp_comm_type), INTENT(IN) :: comm
29995
29996 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_c'
29997
29998 INTEGER :: handle
29999#if defined(__parallel)
30000 INTEGER :: ierr, msglen
30001 COMPLEX(kind=real_4) :: res
30002#endif
30003
30004 CALL mp_timeset(routinen, handle)
30005
30006#if defined(__parallel)
30007 msglen = 1
30008 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_max, root, comm%handle, ierr)
30009 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30010 IF (root == comm%mepos) msg = res
30011 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30012#else
30013 mark_used(msg)
30014 mark_used(comm)
30015 mark_used(root)
30016#endif
30017 CALL mp_timestop(handle)
30018 END SUBROUTINE mp_max_root_c
30019
30020! **************************************************************************************************
30021!> \brief Finds the element-wise maximum of a vector with the result left on
30022!> all processes.
30023!> \param[in,out] msg Find maximum among these data (input) and
30024!> maximum (output)
30025!> \param comm ...
30026!> \note see mp_max_c
30027! **************************************************************************************************
30028 SUBROUTINE mp_max_cv(msg, comm)
30029 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30030 CLASS(mp_comm_type), INTENT(IN) :: comm
30031
30032 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_cv'
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 = SIZE(msg)
30043 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_max, comm%handle, ierr)
30044 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30045 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30046#else
30047 mark_used(msg)
30048 mark_used(comm)
30049#endif
30050 CALL mp_timestop(handle)
30051 END SUBROUTINE mp_max_cv
30052
30053! **************************************************************************************************
30054!> \brief Finds the element-wise maximum of a vector with the result left on
30055!> all processes.
30056!> \param[in,out] msg Find maximum among these data (input) and
30057!> maximum (output)
30058!> \param comm ...
30059!> \note see mp_max_c
30060! **************************************************************************************************
30061 SUBROUTINE mp_max_root_cm(msg, root, comm)
30062 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30063 INTEGER :: root
30064 CLASS(mp_comm_type), INTENT(IN) :: comm
30065
30066 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_cm'
30067
30068 INTEGER :: handle
30069#if defined(__parallel)
30070 INTEGER :: ierr, msglen
30071 COMPLEX(kind=real_4) :: res(size(msg, 1), size(msg, 2))
30072#endif
30073
30074 CALL mp_timeset(routinen, handle)
30075
30076#if defined(__parallel)
30077 msglen = SIZE(msg)
30078 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_max, root, comm%handle, ierr)
30079 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30080 IF (root == comm%mepos) msg = res
30081 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30082#else
30083 mark_used(msg)
30084 mark_used(comm)
30085 mark_used(root)
30086#endif
30087 CALL mp_timestop(handle)
30088 END SUBROUTINE mp_max_root_cm
30089
30090! **************************************************************************************************
30091!> \brief Finds the minimum of a datum with the result left on all processes.
30092!> \param[in,out] msg Find minimum among these data (input) and
30093!> maximum (output)
30094!> \param[in] comm Message passing environment identifier
30095!> \par MPI mapping
30096!> mpi_allreduce
30097! **************************************************************************************************
30098 SUBROUTINE mp_min_c (msg, comm)
30099 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30100 CLASS(mp_comm_type), INTENT(IN) :: comm
30101
30102 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_c'
30103
30104 INTEGER :: handle
30105#if defined(__parallel)
30106 INTEGER :: ierr, msglen
30107#endif
30108
30109 CALL mp_timeset(routinen, handle)
30110
30111#if defined(__parallel)
30112 msglen = 1
30113 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30114 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30115 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30116#else
30117 mark_used(msg)
30118 mark_used(comm)
30119#endif
30120 CALL mp_timestop(handle)
30121 END SUBROUTINE mp_min_c
30122
30123! **************************************************************************************************
30124!> \brief Finds the element-wise minimum of vector with the result left on
30125!> all processes.
30126!> \param[in,out] msg Find minimum among these data (input) and
30127!> maximum (output)
30128!> \param comm ...
30129!> \par MPI mapping
30130!> mpi_allreduce
30131!> \note see mp_min_c
30132! **************************************************************************************************
30133 SUBROUTINE mp_min_cv(msg, comm)
30134 COMPLEX(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
30135 CLASS(mp_comm_type), INTENT(IN) :: comm
30136
30137 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_cv'
30138
30139 INTEGER :: handle
30140#if defined(__parallel)
30141 INTEGER :: ierr, msglen
30142#endif
30143
30144 CALL mp_timeset(routinen, handle)
30145
30146#if defined(__parallel)
30147 msglen = SIZE(msg)
30148 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30149 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30150 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30151#else
30152 mark_used(msg)
30153 mark_used(comm)
30154#endif
30155 CALL mp_timestop(handle)
30156 END SUBROUTINE mp_min_cv
30157
30158! **************************************************************************************************
30159!> \brief Multiplies a set of numbers scattered across a number of processes,
30160!> then replicates the result.
30161!> \param[in,out] msg a number to multiply (input) and result (output)
30162!> \param[in] comm message passing environment identifier
30163!> \par MPI mapping
30164!> mpi_allreduce
30165! **************************************************************************************************
30166 SUBROUTINE mp_prod_c (msg, comm)
30167 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30168 CLASS(mp_comm_type), INTENT(IN) :: comm
30169
30170 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_c'
30171
30172 INTEGER :: handle
30173#if defined(__parallel)
30174 INTEGER :: ierr, msglen
30175#endif
30176
30177 CALL mp_timeset(routinen, handle)
30178
30179#if defined(__parallel)
30180 msglen = 1
30181 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_prod, comm%handle, ierr)
30182 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30183 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30184#else
30185 mark_used(msg)
30186 mark_used(comm)
30187#endif
30188 CALL mp_timestop(handle)
30189 END SUBROUTINE mp_prod_c
30190
30191! **************************************************************************************************
30192!> \brief Scatters data from one processes to all others
30193!> \param[in] msg_scatter Data to scatter (for root process)
30194!> \param[out] msg Received data
30195!> \param[in] root Process which scatters data
30196!> \param[in] comm Message passing environment identifier
30197!> \par MPI mapping
30198!> mpi_scatter
30199! **************************************************************************************************
30200 SUBROUTINE mp_scatter_cv(msg_scatter, msg, root, comm)
30201 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
30202 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
30203 INTEGER, INTENT(IN) :: root
30204 CLASS(mp_comm_type), INTENT(IN) :: comm
30205
30206 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_cv'
30207
30208 INTEGER :: handle
30209#if defined(__parallel)
30210 INTEGER :: ierr, msglen
30211#endif
30212
30213 CALL mp_timeset(routinen, handle)
30214
30215#if defined(__parallel)
30216 msglen = SIZE(msg)
30217 CALL mpi_scatter(msg_scatter, msglen, mpi_complex, msg, &
30218 msglen, mpi_complex, root, comm%handle, ierr)
30219 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
30220 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30221#else
30222 mark_used(root)
30223 mark_used(comm)
30224 msg = msg_scatter
30225#endif
30226 CALL mp_timestop(handle)
30227 END SUBROUTINE mp_scatter_cv
30228
30229! **************************************************************************************************
30230!> \brief Scatters data from one processes to all others
30231!> \param[in] msg_scatter Data to scatter (for root process)
30232!> \param[in] root Process which scatters data
30233!> \param[in] comm Message passing environment identifier
30234!> \par MPI mapping
30235!> mpi_scatter
30236! **************************************************************************************************
30237 SUBROUTINE mp_iscatter_c (msg_scatter, msg, root, comm, request)
30238 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:)
30239 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30240 INTEGER, INTENT(IN) :: root
30241 CLASS(mp_comm_type), INTENT(IN) :: comm
30242 TYPE(mp_request_type), INTENT(OUT) :: request
30243
30244 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_c'
30245
30246 INTEGER :: handle
30247#if defined(__parallel)
30248 INTEGER :: ierr, msglen
30249#endif
30250
30251 CALL mp_timeset(routinen, handle)
30252
30253#if defined(__parallel)
30254#if !defined(__GNUC__) || __GNUC__ >= 9
30255 cpassert(is_contiguous(msg_scatter))
30256#endif
30257 msglen = 1
30258 CALL mpi_iscatter(msg_scatter, msglen, mpi_complex, msg, &
30259 msglen, mpi_complex, root, comm%handle, request%handle, ierr)
30260 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
30261 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30262#else
30263 mark_used(root)
30264 mark_used(comm)
30265 msg = msg_scatter(1)
30266 request = mp_request_null
30267#endif
30268 CALL mp_timestop(handle)
30269 END SUBROUTINE mp_iscatter_c
30270
30271! **************************************************************************************************
30272!> \brief Scatters data from one processes to all others
30273!> \param[in] msg_scatter Data to scatter (for root process)
30274!> \param[in] root Process which scatters data
30275!> \param[in] comm Message passing environment identifier
30276!> \par MPI mapping
30277!> mpi_scatter
30278! **************************************************************************************************
30279 SUBROUTINE mp_iscatter_cv2(msg_scatter, msg, root, comm, request)
30280 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:, :)
30281 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
30282 INTEGER, INTENT(IN) :: root
30283 CLASS(mp_comm_type), INTENT(IN) :: comm
30284 TYPE(mp_request_type), INTENT(OUT) :: request
30285
30286 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_cv2'
30287
30288 INTEGER :: handle
30289#if defined(__parallel)
30290 INTEGER :: ierr, msglen
30291#endif
30292
30293 CALL mp_timeset(routinen, handle)
30294
30295#if defined(__parallel)
30296#if !defined(__GNUC__) || __GNUC__ >= 9
30297 cpassert(is_contiguous(msg_scatter))
30298#endif
30299 msglen = SIZE(msg)
30300 CALL mpi_iscatter(msg_scatter, msglen, mpi_complex, msg, &
30301 msglen, mpi_complex, root, comm%handle, request%handle, ierr)
30302 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
30303 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30304#else
30305 mark_used(root)
30306 mark_used(comm)
30307 msg(:) = msg_scatter(:, 1)
30308 request = mp_request_null
30309#endif
30310 CALL mp_timestop(handle)
30311 END SUBROUTINE mp_iscatter_cv2
30312
30313! **************************************************************************************************
30314!> \brief Scatters data from one processes to all others
30315!> \param[in] msg_scatter Data to scatter (for root process)
30316!> \param[in] root Process which scatters data
30317!> \param[in] comm Message passing environment identifier
30318!> \par MPI mapping
30319!> mpi_scatter
30320! **************************************************************************************************
30321 SUBROUTINE mp_iscatterv_cv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
30322 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:)
30323 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
30324 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
30325 INTEGER, INTENT(IN) :: recvcount, root
30326 CLASS(mp_comm_type), INTENT(IN) :: comm
30327 TYPE(mp_request_type), INTENT(OUT) :: request
30328
30329 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_cv'
30330
30331 INTEGER :: handle
30332#if defined(__parallel)
30333 INTEGER :: ierr
30334#endif
30335
30336 CALL mp_timeset(routinen, handle)
30337
30338#if defined(__parallel)
30339#if !defined(__GNUC__) || __GNUC__ >= 9
30340 cpassert(is_contiguous(msg_scatter))
30341 cpassert(is_contiguous(msg))
30342 cpassert(is_contiguous(sendcounts))
30343 cpassert(is_contiguous(displs))
30344#endif
30345 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_complex, msg, &
30346 recvcount, mpi_complex, root, comm%handle, request%handle, ierr)
30347 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
30348 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30349#else
30350 mark_used(sendcounts)
30351 mark_used(displs)
30352 mark_used(recvcount)
30353 mark_used(root)
30354 mark_used(comm)
30355 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
30356 request = mp_request_null
30357#endif
30358 CALL mp_timestop(handle)
30359 END SUBROUTINE mp_iscatterv_cv
30360
30361! **************************************************************************************************
30362!> \brief Gathers a datum from all processes to one
30363!> \param[in] msg Datum to send to root
30364!> \param[out] msg_gather Received data (on root)
30365!> \param[in] root Process which gathers the data
30366!> \param[in] comm Message passing environment identifier
30367!> \par MPI mapping
30368!> mpi_gather
30369! **************************************************************************************************
30370 SUBROUTINE mp_gather_c (msg, msg_gather, root, comm)
30371 COMPLEX(kind=real_4), INTENT(IN) :: msg
30372 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30373 INTEGER, INTENT(IN) :: root
30374 CLASS(mp_comm_type), INTENT(IN) :: comm
30375
30376 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_c'
30377
30378 INTEGER :: handle
30379#if defined(__parallel)
30380 INTEGER :: ierr, msglen
30381#endif
30382
30383 CALL mp_timeset(routinen, handle)
30384
30385#if defined(__parallel)
30386 msglen = 1
30387 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30388 msglen, mpi_complex, root, comm%handle, ierr)
30389 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30390 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30391#else
30392 mark_used(root)
30393 mark_used(comm)
30394 msg_gather(1) = msg
30395#endif
30396 CALL mp_timestop(handle)
30397 END SUBROUTINE mp_gather_c
30398
30399! **************************************************************************************************
30400!> \brief Gathers a datum from all processes to one, uses the source process of comm
30401!> \param[in] msg Datum to send to root
30402!> \param[out] msg_gather Received data (on root)
30403!> \param[in] comm Message passing environment identifier
30404!> \par MPI mapping
30405!> mpi_gather
30406! **************************************************************************************************
30407 SUBROUTINE mp_gather_c_src(msg, msg_gather, comm)
30408 COMPLEX(kind=real_4), INTENT(IN) :: msg
30409 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30410 CLASS(mp_comm_type), INTENT(IN) :: comm
30411
30412 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_c_src'
30413
30414 INTEGER :: handle
30415#if defined(__parallel)
30416 INTEGER :: ierr, msglen
30417#endif
30418
30419 CALL mp_timeset(routinen, handle)
30420
30421#if defined(__parallel)
30422 msglen = 1
30423 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30424 msglen, mpi_complex, comm%source, comm%handle, ierr)
30425 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30426 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30427#else
30428 mark_used(comm)
30429 msg_gather(1) = msg
30430#endif
30431 CALL mp_timestop(handle)
30432 END SUBROUTINE mp_gather_c_src
30433
30434! **************************************************************************************************
30435!> \brief Gathers data from all processes to one
30436!> \param[in] msg Datum to send to root
30437!> \param msg_gather ...
30438!> \param root ...
30439!> \param comm ...
30440!> \par Data length
30441!> All data (msg) is equal-sized
30442!> \par MPI mapping
30443!> mpi_gather
30444!> \note see mp_gather_c
30445! **************************************************************************************************
30446 SUBROUTINE mp_gather_cv(msg, msg_gather, root, comm)
30447 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
30448 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30449 INTEGER, INTENT(IN) :: root
30450 CLASS(mp_comm_type), INTENT(IN) :: comm
30451
30452 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cv'
30453
30454 INTEGER :: handle
30455#if defined(__parallel)
30456 INTEGER :: ierr, msglen
30457#endif
30458
30459 CALL mp_timeset(routinen, handle)
30460
30461#if defined(__parallel)
30462 msglen = SIZE(msg)
30463 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30464 msglen, mpi_complex, root, comm%handle, ierr)
30465 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30466 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30467#else
30468 mark_used(root)
30469 mark_used(comm)
30470 msg_gather = msg
30471#endif
30472 CALL mp_timestop(handle)
30473 END SUBROUTINE mp_gather_cv
30474
30475! **************************************************************************************************
30476!> \brief Gathers data from all processes to one. Gathers from comm%source
30477!> \param[in] msg Datum to send to root
30478!> \param msg_gather ...
30479!> \param comm ...
30480!> \par Data length
30481!> All data (msg) is equal-sized
30482!> \par MPI mapping
30483!> mpi_gather
30484!> \note see mp_gather_c
30485! **************************************************************************************************
30486 SUBROUTINE mp_gather_cv_src(msg, msg_gather, comm)
30487 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
30488 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30489 CLASS(mp_comm_type), INTENT(IN) :: comm
30490
30491 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cv_src'
30492
30493 INTEGER :: handle
30494#if defined(__parallel)
30495 INTEGER :: ierr, msglen
30496#endif
30497
30498 CALL mp_timeset(routinen, handle)
30499
30500#if defined(__parallel)
30501 msglen = SIZE(msg)
30502 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30503 msglen, mpi_complex, comm%source, comm%handle, ierr)
30504 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30505 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30506#else
30507 mark_used(comm)
30508 msg_gather = msg
30509#endif
30510 CALL mp_timestop(handle)
30511 END SUBROUTINE mp_gather_cv_src
30512
30513! **************************************************************************************************
30514!> \brief Gathers data from all processes to one
30515!> \param[in] msg Datum to send to root
30516!> \param msg_gather ...
30517!> \param root ...
30518!> \param comm ...
30519!> \par Data length
30520!> All data (msg) is equal-sized
30521!> \par MPI mapping
30522!> mpi_gather
30523!> \note see mp_gather_c
30524! **************************************************************************************************
30525 SUBROUTINE mp_gather_cm(msg, msg_gather, root, comm)
30526 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30527 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
30528 INTEGER, INTENT(IN) :: root
30529 CLASS(mp_comm_type), INTENT(IN) :: comm
30530
30531 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cm'
30532
30533 INTEGER :: handle
30534#if defined(__parallel)
30535 INTEGER :: ierr, msglen
30536#endif
30537
30538 CALL mp_timeset(routinen, handle)
30539
30540#if defined(__parallel)
30541 msglen = SIZE(msg)
30542 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30543 msglen, mpi_complex, root, comm%handle, ierr)
30544 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30545 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30546#else
30547 mark_used(root)
30548 mark_used(comm)
30549 msg_gather = msg
30550#endif
30551 CALL mp_timestop(handle)
30552 END SUBROUTINE mp_gather_cm
30553
30554! **************************************************************************************************
30555!> \brief Gathers data from all processes to one. Gathers from comm%source
30556!> \param[in] msg Datum to send to root
30557!> \param msg_gather ...
30558!> \param comm ...
30559!> \par Data length
30560!> All data (msg) is equal-sized
30561!> \par MPI mapping
30562!> mpi_gather
30563!> \note see mp_gather_c
30564! **************************************************************************************************
30565 SUBROUTINE mp_gather_cm_src(msg, msg_gather, comm)
30566 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30567 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
30568 CLASS(mp_comm_type), INTENT(IN) :: comm
30569
30570 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cm_src'
30571
30572 INTEGER :: handle
30573#if defined(__parallel)
30574 INTEGER :: ierr, msglen
30575#endif
30576
30577 CALL mp_timeset(routinen, handle)
30578
30579#if defined(__parallel)
30580 msglen = SIZE(msg)
30581 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30582 msglen, mpi_complex, comm%source, comm%handle, ierr)
30583 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30584 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30585#else
30586 mark_used(comm)
30587 msg_gather = msg
30588#endif
30589 CALL mp_timestop(handle)
30590 END SUBROUTINE mp_gather_cm_src
30591
30592! **************************************************************************************************
30593!> \brief Gathers data from all processes to one.
30594!> \param[in] sendbuf Data to send to root
30595!> \param[out] recvbuf Received data (on root)
30596!> \param[in] recvcounts Sizes of data received from processes
30597!> \param[in] displs Offsets of data received from processes
30598!> \param[in] root Process which gathers the data
30599!> \param[in] comm Message passing environment identifier
30600!> \par Data length
30601!> Data can have different lengths
30602!> \par Offsets
30603!> Offsets start at 0
30604!> \par MPI mapping
30605!> mpi_gather
30606! **************************************************************************************************
30607 SUBROUTINE mp_gatherv_cv(sendbuf, recvbuf, recvcounts, displs, root, comm)
30608
30609 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
30610 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
30611 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30612 INTEGER, INTENT(IN) :: root
30613 CLASS(mp_comm_type), INTENT(IN) :: comm
30614
30615 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cv'
30616
30617 INTEGER :: handle
30618#if defined(__parallel)
30619 INTEGER :: ierr, sendcount
30620#endif
30621
30622 CALL mp_timeset(routinen, handle)
30623
30624#if defined(__parallel)
30625 sendcount = SIZE(sendbuf)
30626 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30627 recvbuf, recvcounts, displs, mpi_complex, &
30628 root, comm%handle, ierr)
30629 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30630 CALL add_perf(perf_id=4, &
30631 count=1, &
30632 msg_size=sendcount*(2*real_4_size))
30633#else
30634 mark_used(recvcounts)
30635 mark_used(root)
30636 mark_used(comm)
30637 recvbuf(1 + displs(1):) = sendbuf
30638#endif
30639 CALL mp_timestop(handle)
30640 END SUBROUTINE mp_gatherv_cv
30641
30642! **************************************************************************************************
30643!> \brief Gathers data from all processes to one. Gathers from comm%source
30644!> \param[in] sendbuf Data to send to root
30645!> \param[out] recvbuf Received data (on root)
30646!> \param[in] recvcounts Sizes of data received from processes
30647!> \param[in] displs Offsets of data received from processes
30648!> \param[in] comm Message passing environment identifier
30649!> \par Data length
30650!> Data can have different lengths
30651!> \par Offsets
30652!> Offsets start at 0
30653!> \par MPI mapping
30654!> mpi_gather
30655! **************************************************************************************************
30656 SUBROUTINE mp_gatherv_cv_src(sendbuf, recvbuf, recvcounts, displs, comm)
30657
30658 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
30659 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
30660 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30661 CLASS(mp_comm_type), INTENT(IN) :: comm
30662
30663 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cv_src'
30664
30665 INTEGER :: handle
30666#if defined(__parallel)
30667 INTEGER :: ierr, sendcount
30668#endif
30669
30670 CALL mp_timeset(routinen, handle)
30671
30672#if defined(__parallel)
30673 sendcount = SIZE(sendbuf)
30674 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30675 recvbuf, recvcounts, displs, mpi_complex, &
30676 comm%source, comm%handle, ierr)
30677 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30678 CALL add_perf(perf_id=4, &
30679 count=1, &
30680 msg_size=sendcount*(2*real_4_size))
30681#else
30682 mark_used(recvcounts)
30683 mark_used(comm)
30684 recvbuf(1 + displs(1):) = sendbuf
30685#endif
30686 CALL mp_timestop(handle)
30687 END SUBROUTINE mp_gatherv_cv_src
30688
30689! **************************************************************************************************
30690!> \brief Gathers data from all processes to one.
30691!> \param[in] sendbuf Data to send to root
30692!> \param[out] recvbuf Received data (on root)
30693!> \param[in] recvcounts Sizes of data received from processes
30694!> \param[in] displs Offsets of data received from processes
30695!> \param[in] root Process which gathers the data
30696!> \param[in] comm Message passing environment identifier
30697!> \par Data length
30698!> Data can have different lengths
30699!> \par Offsets
30700!> Offsets start at 0
30701!> \par MPI mapping
30702!> mpi_gather
30703! **************************************************************************************************
30704 SUBROUTINE mp_gatherv_cm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
30705
30706 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
30707 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
30708 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30709 INTEGER, INTENT(IN) :: root
30710 CLASS(mp_comm_type), INTENT(IN) :: comm
30711
30712 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cm2'
30713
30714 INTEGER :: handle
30715#if defined(__parallel)
30716 INTEGER :: ierr, sendcount
30717#endif
30718
30719 CALL mp_timeset(routinen, handle)
30720
30721#if defined(__parallel)
30722 sendcount = SIZE(sendbuf)
30723 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30724 recvbuf, recvcounts, displs, mpi_complex, &
30725 root, comm%handle, ierr)
30726 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30727 CALL add_perf(perf_id=4, &
30728 count=1, &
30729 msg_size=sendcount*(2*real_4_size))
30730#else
30731 mark_used(recvcounts)
30732 mark_used(root)
30733 mark_used(comm)
30734 recvbuf(:, 1 + displs(1):) = sendbuf
30735#endif
30736 CALL mp_timestop(handle)
30737 END SUBROUTINE mp_gatherv_cm2
30738
30739! **************************************************************************************************
30740!> \brief Gathers data from all processes to one.
30741!> \param[in] sendbuf Data to send to root
30742!> \param[out] recvbuf Received data (on root)
30743!> \param[in] recvcounts Sizes of data received from processes
30744!> \param[in] displs Offsets of data received from processes
30745!> \param[in] comm Message passing environment identifier
30746!> \par Data length
30747!> Data can have different lengths
30748!> \par Offsets
30749!> Offsets start at 0
30750!> \par MPI mapping
30751!> mpi_gather
30752! **************************************************************************************************
30753 SUBROUTINE mp_gatherv_cm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
30754
30755 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
30756 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
30757 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30758 CLASS(mp_comm_type), INTENT(IN) :: comm
30759
30760 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cm2_src'
30761
30762 INTEGER :: handle
30763#if defined(__parallel)
30764 INTEGER :: ierr, sendcount
30765#endif
30766
30767 CALL mp_timeset(routinen, handle)
30768
30769#if defined(__parallel)
30770 sendcount = SIZE(sendbuf)
30771 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30772 recvbuf, recvcounts, displs, mpi_complex, &
30773 comm%source, comm%handle, ierr)
30774 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30775 CALL add_perf(perf_id=4, &
30776 count=1, &
30777 msg_size=sendcount*(2*real_4_size))
30778#else
30779 mark_used(recvcounts)
30780 mark_used(comm)
30781 recvbuf(:, 1 + displs(1):) = sendbuf
30782#endif
30783 CALL mp_timestop(handle)
30784 END SUBROUTINE mp_gatherv_cm2_src
30785
30786! **************************************************************************************************
30787!> \brief Gathers data from all processes to one.
30788!> \param[in] sendbuf Data to send to root
30789!> \param[out] recvbuf Received data (on root)
30790!> \param[in] recvcounts Sizes of data received from processes
30791!> \param[in] displs Offsets of data received from processes
30792!> \param[in] root Process which gathers the data
30793!> \param[in] comm Message passing environment identifier
30794!> \par Data length
30795!> Data can have different lengths
30796!> \par Offsets
30797!> Offsets start at 0
30798!> \par MPI mapping
30799!> mpi_gather
30800! **************************************************************************************************
30801 SUBROUTINE mp_igatherv_cv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
30802 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: sendbuf
30803 COMPLEX(kind=real_4), DIMENSION(:), INTENT(OUT) :: recvbuf
30804 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30805 INTEGER, INTENT(IN) :: sendcount, root
30806 CLASS(mp_comm_type), INTENT(IN) :: comm
30807 TYPE(mp_request_type), INTENT(OUT) :: request
30808
30809 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_cv'
30810
30811 INTEGER :: handle
30812#if defined(__parallel)
30813 INTEGER :: ierr
30814#endif
30815
30816 CALL mp_timeset(routinen, handle)
30817
30818#if defined(__parallel)
30819#if !defined(__GNUC__) || __GNUC__ >= 9
30820 cpassert(is_contiguous(sendbuf))
30821 cpassert(is_contiguous(recvbuf))
30822 cpassert(is_contiguous(recvcounts))
30823 cpassert(is_contiguous(displs))
30824#endif
30825 CALL mpi_igatherv(sendbuf, sendcount, mpi_complex, &
30826 recvbuf, recvcounts, displs, mpi_complex, &
30827 root, comm%handle, request%handle, ierr)
30828 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30829 CALL add_perf(perf_id=24, &
30830 count=1, &
30831 msg_size=sendcount*(2*real_4_size))
30832#else
30833 mark_used(sendcount)
30834 mark_used(recvcounts)
30835 mark_used(root)
30836 mark_used(comm)
30837 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
30838 request = mp_request_null
30839#endif
30840 CALL mp_timestop(handle)
30841 END SUBROUTINE mp_igatherv_cv
30842
30843! **************************************************************************************************
30844!> \brief Gathers a datum from all processes and all processes receive the
30845!> same data
30846!> \param[in] msgout Datum to send
30847!> \param[out] msgin Received data
30848!> \param[in] comm Message passing environment identifier
30849!> \par Data size
30850!> All processes send equal-sized data
30851!> \par MPI mapping
30852!> mpi_allgather
30853! **************************************************************************************************
30854 SUBROUTINE mp_allgather_c (msgout, msgin, comm)
30855 COMPLEX(kind=real_4), INTENT(IN) :: msgout
30856 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
30857 CLASS(mp_comm_type), INTENT(IN) :: comm
30858
30859 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c'
30860
30861 INTEGER :: handle
30862#if defined(__parallel)
30863 INTEGER :: ierr, rcount, scount
30864#endif
30865
30866 CALL mp_timeset(routinen, handle)
30867
30868#if defined(__parallel)
30869 scount = 1
30870 rcount = 1
30871 CALL mpi_allgather(msgout, scount, mpi_complex, &
30872 msgin, rcount, mpi_complex, &
30873 comm%handle, ierr)
30874 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
30875#else
30876 mark_used(comm)
30877 msgin = msgout
30878#endif
30879 CALL mp_timestop(handle)
30880 END SUBROUTINE mp_allgather_c
30881
30882! **************************************************************************************************
30883!> \brief Gathers a datum from all processes and all processes receive the
30884!> same data
30885!> \param[in] msgout Datum to send
30886!> \param[out] msgin Received data
30887!> \param[in] comm Message passing environment identifier
30888!> \par Data size
30889!> All processes send equal-sized data
30890!> \par MPI mapping
30891!> mpi_allgather
30892! **************************************************************************************************
30893 SUBROUTINE mp_allgather_c2(msgout, msgin, comm)
30894 COMPLEX(kind=real_4), INTENT(IN) :: msgout
30895 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
30896 CLASS(mp_comm_type), INTENT(IN) :: comm
30897
30898 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c2'
30899
30900 INTEGER :: handle
30901#if defined(__parallel)
30902 INTEGER :: ierr, rcount, scount
30903#endif
30904
30905 CALL mp_timeset(routinen, handle)
30906
30907#if defined(__parallel)
30908 scount = 1
30909 rcount = 1
30910 CALL mpi_allgather(msgout, scount, mpi_complex, &
30911 msgin, rcount, mpi_complex, &
30912 comm%handle, ierr)
30913 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
30914#else
30915 mark_used(comm)
30916 msgin = msgout
30917#endif
30918 CALL mp_timestop(handle)
30919 END SUBROUTINE mp_allgather_c2
30920
30921! **************************************************************************************************
30922!> \brief Gathers a datum from all processes and all processes receive the
30923!> same data
30924!> \param[in] msgout Datum to send
30925!> \param[out] msgin Received data
30926!> \param[in] comm Message passing environment identifier
30927!> \par Data size
30928!> All processes send equal-sized data
30929!> \par MPI mapping
30930!> mpi_allgather
30931! **************************************************************************************************
30932 SUBROUTINE mp_iallgather_c (msgout, msgin, comm, request)
30933 COMPLEX(kind=real_4), INTENT(IN) :: msgout
30934 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
30935 CLASS(mp_comm_type), INTENT(IN) :: comm
30936 TYPE(mp_request_type), INTENT(OUT) :: request
30937
30938 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c'
30939
30940 INTEGER :: handle
30941#if defined(__parallel)
30942 INTEGER :: ierr, rcount, scount
30943#endif
30944
30945 CALL mp_timeset(routinen, handle)
30946
30947#if defined(__parallel)
30948#if !defined(__GNUC__) || __GNUC__ >= 9
30949 cpassert(is_contiguous(msgin))
30950#endif
30951 scount = 1
30952 rcount = 1
30953 CALL mpi_iallgather(msgout, scount, mpi_complex, &
30954 msgin, rcount, mpi_complex, &
30955 comm%handle, request%handle, ierr)
30956 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
30957#else
30958 mark_used(comm)
30959 msgin = msgout
30960 request = mp_request_null
30961#endif
30962 CALL mp_timestop(handle)
30963 END SUBROUTINE mp_iallgather_c
30964
30965! **************************************************************************************************
30966!> \brief Gathers vector data from all processes and all processes receive the
30967!> same data
30968!> \param[in] msgout Rank-1 data to send
30969!> \param[out] msgin Received data
30970!> \param[in] comm Message passing environment identifier
30971!> \par Data size
30972!> All processes send equal-sized data
30973!> \par Ranks
30974!> The last rank counts the processes
30975!> \par MPI mapping
30976!> mpi_allgather
30977! **************************************************************************************************
30978 SUBROUTINE mp_allgather_c12(msgout, msgin, comm)
30979 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:)
30980 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
30981 CLASS(mp_comm_type), INTENT(IN) :: comm
30982
30983 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c12'
30984
30985 INTEGER :: handle
30986#if defined(__parallel)
30987 INTEGER :: ierr, rcount, scount
30988#endif
30989
30990 CALL mp_timeset(routinen, handle)
30991
30992#if defined(__parallel)
30993 scount = SIZE(msgout(:))
30994 rcount = scount
30995 CALL mpi_allgather(msgout, scount, mpi_complex, &
30996 msgin, rcount, mpi_complex, &
30997 comm%handle, ierr)
30998 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
30999#else
31000 mark_used(comm)
31001 msgin(:, 1) = msgout(:)
31002#endif
31003 CALL mp_timestop(handle)
31004 END SUBROUTINE mp_allgather_c12
31005
31006! **************************************************************************************************
31007!> \brief Gathers matrix data from all processes and all processes receive the
31008!> same data
31009!> \param[in] msgout Rank-2 data to send
31010!> \param msgin ...
31011!> \param comm ...
31012!> \note see mp_allgather_c12
31013! **************************************************************************************************
31014 SUBROUTINE mp_allgather_c23(msgout, msgin, comm)
31015 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
31016 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
31017 CLASS(mp_comm_type), INTENT(IN) :: comm
31018
31019 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c23'
31020
31021 INTEGER :: handle
31022#if defined(__parallel)
31023 INTEGER :: ierr, rcount, scount
31024#endif
31025
31026 CALL mp_timeset(routinen, handle)
31027
31028#if defined(__parallel)
31029 scount = SIZE(msgout(:, :))
31030 rcount = scount
31031 CALL mpi_allgather(msgout, scount, mpi_complex, &
31032 msgin, rcount, mpi_complex, &
31033 comm%handle, ierr)
31034 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31035#else
31036 mark_used(comm)
31037 msgin(:, :, 1) = msgout(:, :)
31038#endif
31039 CALL mp_timestop(handle)
31040 END SUBROUTINE mp_allgather_c23
31041
31042! **************************************************************************************************
31043!> \brief Gathers rank-3 data from all processes and all processes receive the
31044!> same data
31045!> \param[in] msgout Rank-3 data to send
31046!> \param msgin ...
31047!> \param comm ...
31048!> \note see mp_allgather_c12
31049! **************************************************************************************************
31050 SUBROUTINE mp_allgather_c34(msgout, msgin, comm)
31051 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
31052 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
31053 CLASS(mp_comm_type), INTENT(IN) :: comm
31054
31055 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c34'
31056
31057 INTEGER :: handle
31058#if defined(__parallel)
31059 INTEGER :: ierr, rcount, scount
31060#endif
31061
31062 CALL mp_timeset(routinen, handle)
31063
31064#if defined(__parallel)
31065 scount = SIZE(msgout(:, :, :))
31066 rcount = scount
31067 CALL mpi_allgather(msgout, scount, mpi_complex, &
31068 msgin, rcount, mpi_complex, &
31069 comm%handle, ierr)
31070 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31071#else
31072 mark_used(comm)
31073 msgin(:, :, :, 1) = msgout(:, :, :)
31074#endif
31075 CALL mp_timestop(handle)
31076 END SUBROUTINE mp_allgather_c34
31077
31078! **************************************************************************************************
31079!> \brief Gathers rank-2 data from all processes and all processes receive the
31080!> same data
31081!> \param[in] msgout Rank-2 data to send
31082!> \param msgin ...
31083!> \param comm ...
31084!> \note see mp_allgather_c12
31085! **************************************************************************************************
31086 SUBROUTINE mp_allgather_c22(msgout, msgin, comm)
31087 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
31088 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31089 CLASS(mp_comm_type), INTENT(IN) :: comm
31090
31091 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c22'
31092
31093 INTEGER :: handle
31094#if defined(__parallel)
31095 INTEGER :: ierr, rcount, scount
31096#endif
31097
31098 CALL mp_timeset(routinen, handle)
31099
31100#if defined(__parallel)
31101 scount = SIZE(msgout(:, :))
31102 rcount = scount
31103 CALL mpi_allgather(msgout, scount, mpi_complex, &
31104 msgin, rcount, mpi_complex, &
31105 comm%handle, ierr)
31106 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31107#else
31108 mark_used(comm)
31109 msgin(:, :) = msgout(:, :)
31110#endif
31111 CALL mp_timestop(handle)
31112 END SUBROUTINE mp_allgather_c22
31113
31114! **************************************************************************************************
31115!> \brief Gathers rank-1 data from all processes and all processes receive the
31116!> same data
31117!> \param[in] msgout Rank-1 data to send
31118!> \param msgin ...
31119!> \param comm ...
31120!> \param request ...
31121!> \note see mp_allgather_c11
31122! **************************************************************************************************
31123 SUBROUTINE mp_iallgather_c11(msgout, msgin, comm, request)
31124 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31125 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31126 CLASS(mp_comm_type), INTENT(IN) :: comm
31127 TYPE(mp_request_type), INTENT(OUT) :: request
31128
31129 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c11'
31130
31131 INTEGER :: handle
31132#if defined(__parallel)
31133 INTEGER :: ierr, rcount, scount
31134#endif
31135
31136 CALL mp_timeset(routinen, handle)
31137
31138#if defined(__parallel)
31139#if !defined(__GNUC__) || __GNUC__ >= 9
31140 cpassert(is_contiguous(msgout))
31141 cpassert(is_contiguous(msgin))
31142#endif
31143 scount = SIZE(msgout(:))
31144 rcount = scount
31145 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31146 msgin, rcount, mpi_complex, &
31147 comm%handle, request%handle, ierr)
31148 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31149#else
31150 mark_used(comm)
31151 msgin = msgout
31152 request = mp_request_null
31153#endif
31154 CALL mp_timestop(handle)
31155 END SUBROUTINE mp_iallgather_c11
31156
31157! **************************************************************************************************
31158!> \brief Gathers rank-2 data from all processes and all processes receive the
31159!> same data
31160!> \param[in] msgout Rank-2 data to send
31161!> \param msgin ...
31162!> \param comm ...
31163!> \param request ...
31164!> \note see mp_allgather_c12
31165! **************************************************************************************************
31166 SUBROUTINE mp_iallgather_c13(msgout, msgin, comm, request)
31167 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31168 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
31169 CLASS(mp_comm_type), INTENT(IN) :: comm
31170 TYPE(mp_request_type), INTENT(OUT) :: request
31171
31172 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c13'
31173
31174 INTEGER :: handle
31175#if defined(__parallel)
31176 INTEGER :: ierr, rcount, scount
31177#endif
31178
31179 CALL mp_timeset(routinen, handle)
31180
31181#if defined(__parallel)
31182#if !defined(__GNUC__) || __GNUC__ >= 9
31183 cpassert(is_contiguous(msgout))
31184 cpassert(is_contiguous(msgin))
31185#endif
31186
31187 scount = SIZE(msgout(:))
31188 rcount = scount
31189 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31190 msgin, rcount, mpi_complex, &
31191 comm%handle, request%handle, ierr)
31192 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31193#else
31194 mark_used(comm)
31195 msgin(:, 1, 1) = msgout(:)
31196 request = mp_request_null
31197#endif
31198 CALL mp_timestop(handle)
31199 END SUBROUTINE mp_iallgather_c13
31200
31201! **************************************************************************************************
31202!> \brief Gathers rank-2 data from all processes and all processes receive the
31203!> same data
31204!> \param[in] msgout Rank-2 data to send
31205!> \param msgin ...
31206!> \param comm ...
31207!> \param request ...
31208!> \note see mp_allgather_c12
31209! **************************************************************************************************
31210 SUBROUTINE mp_iallgather_c22(msgout, msgin, comm, request)
31211 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :)
31212 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :)
31213 CLASS(mp_comm_type), INTENT(IN) :: comm
31214 TYPE(mp_request_type), INTENT(OUT) :: request
31215
31216 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c22'
31217
31218 INTEGER :: handle
31219#if defined(__parallel)
31220 INTEGER :: ierr, rcount, scount
31221#endif
31222
31223 CALL mp_timeset(routinen, handle)
31224
31225#if defined(__parallel)
31226#if !defined(__GNUC__) || __GNUC__ >= 9
31227 cpassert(is_contiguous(msgout))
31228 cpassert(is_contiguous(msgin))
31229#endif
31230
31231 scount = SIZE(msgout(:, :))
31232 rcount = scount
31233 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31234 msgin, rcount, mpi_complex, &
31235 comm%handle, request%handle, ierr)
31236 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31237#else
31238 mark_used(comm)
31239 msgin(:, :) = msgout(:, :)
31240 request = mp_request_null
31241#endif
31242 CALL mp_timestop(handle)
31243 END SUBROUTINE mp_iallgather_c22
31244
31245! **************************************************************************************************
31246!> \brief Gathers rank-2 data from all processes and all processes receive the
31247!> same data
31248!> \param[in] msgout Rank-2 data to send
31249!> \param msgin ...
31250!> \param comm ...
31251!> \param request ...
31252!> \note see mp_allgather_c12
31253! **************************************************************************************************
31254 SUBROUTINE mp_iallgather_c24(msgout, msgin, comm, request)
31255 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :)
31256 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :, :)
31257 CLASS(mp_comm_type), INTENT(IN) :: comm
31258 TYPE(mp_request_type), INTENT(OUT) :: request
31259
31260 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c24'
31261
31262 INTEGER :: handle
31263#if defined(__parallel)
31264 INTEGER :: ierr, rcount, scount
31265#endif
31266
31267 CALL mp_timeset(routinen, handle)
31268
31269#if defined(__parallel)
31270#if !defined(__GNUC__) || __GNUC__ >= 9
31271 cpassert(is_contiguous(msgout))
31272 cpassert(is_contiguous(msgin))
31273#endif
31274
31275 scount = SIZE(msgout(:, :))
31276 rcount = scount
31277 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31278 msgin, rcount, mpi_complex, &
31279 comm%handle, request%handle, ierr)
31280 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31281#else
31282 mark_used(comm)
31283 msgin(:, :, 1, 1) = msgout(:, :)
31284 request = mp_request_null
31285#endif
31286 CALL mp_timestop(handle)
31287 END SUBROUTINE mp_iallgather_c24
31288
31289! **************************************************************************************************
31290!> \brief Gathers rank-3 data from all processes and all processes receive the
31291!> same data
31292!> \param[in] msgout Rank-3 data to send
31293!> \param msgin ...
31294!> \param comm ...
31295!> \param request ...
31296!> \note see mp_allgather_c12
31297! **************************************************************************************************
31298 SUBROUTINE mp_iallgather_c33(msgout, msgin, comm, request)
31299 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :, :)
31300 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
31301 CLASS(mp_comm_type), INTENT(IN) :: comm
31302 TYPE(mp_request_type), INTENT(OUT) :: request
31303
31304 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c33'
31305
31306 INTEGER :: handle
31307#if defined(__parallel)
31308 INTEGER :: ierr, rcount, scount
31309#endif
31310
31311 CALL mp_timeset(routinen, handle)
31312
31313#if defined(__parallel)
31314#if !defined(__GNUC__) || __GNUC__ >= 9
31315 cpassert(is_contiguous(msgout))
31316 cpassert(is_contiguous(msgin))
31317#endif
31318
31319 scount = SIZE(msgout(:, :, :))
31320 rcount = scount
31321 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31322 msgin, rcount, mpi_complex, &
31323 comm%handle, request%handle, ierr)
31324 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31325#else
31326 mark_used(comm)
31327 msgin(:, :, :) = msgout(:, :, :)
31328 request = mp_request_null
31329#endif
31330 CALL mp_timestop(handle)
31331 END SUBROUTINE mp_iallgather_c33
31332
31333! **************************************************************************************************
31334!> \brief Gathers vector data from all processes and all processes receive the
31335!> same data
31336!> \param[in] msgout Rank-1 data to send
31337!> \param[out] msgin Received data
31338!> \param[in] rcount Size of sent data for every process
31339!> \param[in] rdispl Offset of sent data for every process
31340!> \param[in] comm Message passing environment identifier
31341!> \par Data size
31342!> Processes can send different-sized data
31343!> \par Ranks
31344!> The last rank counts the processes
31345!> \par Offsets
31346!> Offsets are from 0
31347!> \par MPI mapping
31348!> mpi_allgather
31349! **************************************************************************************************
31350 SUBROUTINE mp_allgatherv_cv(msgout, msgin, rcount, rdispl, comm)
31351 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
31352 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31353 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31354 CLASS(mp_comm_type), INTENT(IN) :: comm
31355
31356 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_cv'
31357
31358 INTEGER :: handle
31359#if defined(__parallel)
31360 INTEGER :: ierr, scount
31361#endif
31362
31363 CALL mp_timeset(routinen, handle)
31364
31365#if defined(__parallel)
31366 scount = SIZE(msgout)
31367 CALL mpi_allgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31368 rdispl, mpi_complex, comm%handle, ierr)
31369 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
31370#else
31371 mark_used(rcount)
31372 mark_used(rdispl)
31373 mark_used(comm)
31374 msgin = msgout
31375#endif
31376 CALL mp_timestop(handle)
31377 END SUBROUTINE mp_allgatherv_cv
31378
31379! **************************************************************************************************
31380!> \brief Gathers vector data from all processes and all processes receive the
31381!> same data
31382!> \param[in] msgout Rank-1 data to send
31383!> \param[out] msgin Received data
31384!> \param[in] rcount Size of sent data for every process
31385!> \param[in] rdispl Offset of sent data for every process
31386!> \param[in] comm Message passing environment identifier
31387!> \par Data size
31388!> Processes can send different-sized data
31389!> \par Ranks
31390!> The last rank counts the processes
31391!> \par Offsets
31392!> Offsets are from 0
31393!> \par MPI mapping
31394!> mpi_allgather
31395! **************************************************************************************************
31396 SUBROUTINE mp_allgatherv_cm2(msgout, msgin, rcount, rdispl, comm)
31397 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
31398 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
31399 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31400 CLASS(mp_comm_type), INTENT(IN) :: comm
31401
31402 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_cv'
31403
31404 INTEGER :: handle
31405#if defined(__parallel)
31406 INTEGER :: ierr, scount
31407#endif
31408
31409 CALL mp_timeset(routinen, handle)
31410
31411#if defined(__parallel)
31412 scount = SIZE(msgout)
31413 CALL mpi_allgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31414 rdispl, mpi_complex, comm%handle, ierr)
31415 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
31416#else
31417 mark_used(rcount)
31418 mark_used(rdispl)
31419 mark_used(comm)
31420 msgin = msgout
31421#endif
31422 CALL mp_timestop(handle)
31423 END SUBROUTINE mp_allgatherv_cm2
31424
31425! **************************************************************************************************
31426!> \brief Gathers vector data from all processes and all processes receive the
31427!> same data
31428!> \param[in] msgout Rank-1 data to send
31429!> \param[out] msgin Received data
31430!> \param[in] rcount Size of sent data for every process
31431!> \param[in] rdispl Offset of sent data for every process
31432!> \param[in] comm Message passing environment identifier
31433!> \par Data size
31434!> Processes can send different-sized data
31435!> \par Ranks
31436!> The last rank counts the processes
31437!> \par Offsets
31438!> Offsets are from 0
31439!> \par MPI mapping
31440!> mpi_allgather
31441! **************************************************************************************************
31442 SUBROUTINE mp_iallgatherv_cv(msgout, msgin, rcount, rdispl, comm, request)
31443 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31444 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31445 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31446 CLASS(mp_comm_type), INTENT(IN) :: comm
31447 TYPE(mp_request_type), INTENT(OUT) :: request
31448
31449 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_cv'
31450
31451 INTEGER :: handle
31452#if defined(__parallel)
31453 INTEGER :: ierr, scount, rsize
31454#endif
31455
31456 CALL mp_timeset(routinen, handle)
31457
31458#if defined(__parallel)
31459#if !defined(__GNUC__) || __GNUC__ >= 9
31460 cpassert(is_contiguous(msgout))
31461 cpassert(is_contiguous(msgin))
31462 cpassert(is_contiguous(rcount))
31463 cpassert(is_contiguous(rdispl))
31464#endif
31465
31466 scount = SIZE(msgout)
31467 rsize = SIZE(rcount)
31468 CALL mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, &
31469 rdispl, comm, request, ierr)
31470 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
31471#else
31472 mark_used(rcount)
31473 mark_used(rdispl)
31474 mark_used(comm)
31475 msgin = msgout
31476 request = mp_request_null
31477#endif
31478 CALL mp_timestop(handle)
31479 END SUBROUTINE mp_iallgatherv_cv
31480
31481! **************************************************************************************************
31482!> \brief Gathers vector data from all processes and all processes receive the
31483!> same data
31484!> \param[in] msgout Rank-1 data to send
31485!> \param[out] msgin Received data
31486!> \param[in] rcount Size of sent data for every process
31487!> \param[in] rdispl Offset of sent data for every process
31488!> \param[in] comm Message passing environment identifier
31489!> \par Data size
31490!> Processes can send different-sized data
31491!> \par Ranks
31492!> The last rank counts the processes
31493!> \par Offsets
31494!> Offsets are from 0
31495!> \par MPI mapping
31496!> mpi_allgather
31497! **************************************************************************************************
31498 SUBROUTINE mp_iallgatherv_cv2(msgout, msgin, rcount, rdispl, comm, request)
31499 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31500 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31501 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
31502 CLASS(mp_comm_type), INTENT(IN) :: comm
31503 TYPE(mp_request_type), INTENT(OUT) :: request
31504
31505 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_cv2'
31506
31507 INTEGER :: handle
31508#if defined(__parallel)
31509 INTEGER :: ierr, scount, rsize
31510#endif
31511
31512 CALL mp_timeset(routinen, handle)
31513
31514#if defined(__parallel)
31515#if !defined(__GNUC__) || __GNUC__ >= 9
31516 cpassert(is_contiguous(msgout))
31517 cpassert(is_contiguous(msgin))
31518 cpassert(is_contiguous(rcount))
31519 cpassert(is_contiguous(rdispl))
31520#endif
31521
31522 scount = SIZE(msgout)
31523 rsize = SIZE(rcount)
31524 CALL mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, &
31525 rdispl, comm, request, ierr)
31526 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
31527#else
31528 mark_used(rcount)
31529 mark_used(rdispl)
31530 mark_used(comm)
31531 msgin = msgout
31532 request = mp_request_null
31533#endif
31534 CALL mp_timestop(handle)
31535 END SUBROUTINE mp_iallgatherv_cv2
31536
31537! **************************************************************************************************
31538!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
31539!> the issue is with the rank of rcount and rdispl
31540!> \param count ...
31541!> \param array_of_requests ...
31542!> \param array_of_statuses ...
31543!> \param ierr ...
31544!> \author Alfio Lazzaro
31545! **************************************************************************************************
31546#if defined(__parallel)
31547 SUBROUTINE mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
31548 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
31549 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31550 INTEGER, INTENT(IN) :: rsize
31551 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
31552 CLASS(mp_comm_type), INTENT(IN) :: comm
31553 TYPE(mp_request_type), INTENT(OUT) :: request
31554 INTEGER, INTENT(INOUT) :: ierr
31555
31556 CALL mpi_iallgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31557 rdispl, mpi_complex, comm%handle, request%handle, ierr)
31558
31559 END SUBROUTINE mp_iallgatherv_cv_internal
31560#endif
31561
31562! **************************************************************************************************
31563!> \brief Sums a vector and partitions the result among processes
31564!> \param[in] msgout Data to sum
31565!> \param[out] msgin Received portion of summed data
31566!> \param[in] rcount Partition sizes of the summed data for
31567!> every process
31568!> \param[in] comm Message passing environment identifier
31569! **************************************************************************************************
31570 SUBROUTINE mp_sum_scatter_cv(msgout, msgin, rcount, comm)
31571 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
31572 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31573 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
31574 CLASS(mp_comm_type), INTENT(IN) :: comm
31575
31576 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_cv'
31577
31578 INTEGER :: handle
31579#if defined(__parallel)
31580 INTEGER :: ierr
31581#endif
31582
31583 CALL mp_timeset(routinen, handle)
31584
31585#if defined(__parallel)
31586 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_complex, mpi_sum, &
31587 comm%handle, ierr)
31588 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
31589
31590 CALL add_perf(perf_id=3, count=1, &
31591 msg_size=rcount(1)*2*(2*real_4_size))
31592#else
31593 mark_used(rcount)
31594 mark_used(comm)
31595 msgin = msgout(:, 1)
31596#endif
31597 CALL mp_timestop(handle)
31598 END SUBROUTINE mp_sum_scatter_cv
31599
31600! **************************************************************************************************
31601!> \brief Sends and receives vector data
31602!> \param[in] msgin Data to send
31603!> \param[in] dest Process to send data to
31604!> \param[out] msgout Received data
31605!> \param[in] source Process from which to receive
31606!> \param[in] comm Message passing environment identifier
31607!> \param[in] tag Send and recv tag (default: 0)
31608! **************************************************************************************************
31609 SUBROUTINE mp_sendrecv_c (msgin, dest, msgout, source, comm, tag)
31610 COMPLEX(kind=real_4), INTENT(IN) :: msgin
31611 INTEGER, INTENT(IN) :: dest
31612 COMPLEX(kind=real_4), INTENT(OUT) :: msgout
31613 INTEGER, INTENT(IN) :: source
31614 CLASS(mp_comm_type), INTENT(IN) :: comm
31615 INTEGER, INTENT(IN), OPTIONAL :: tag
31616
31617 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_c'
31618
31619 INTEGER :: handle
31620#if defined(__parallel)
31621 INTEGER :: ierr, msglen_in, msglen_out, &
31622 recv_tag, send_tag
31623#endif
31624
31625 CALL mp_timeset(routinen, handle)
31626
31627#if defined(__parallel)
31628 msglen_in = 1
31629 msglen_out = 1
31630 send_tag = 0 ! cannot think of something better here, this might be dangerous
31631 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31632 IF (PRESENT(tag)) THEN
31633 send_tag = tag
31634 recv_tag = tag
31635 END IF
31636 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31637 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31638 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31639 CALL add_perf(perf_id=7, count=1, &
31640 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31641#else
31642 mark_used(dest)
31643 mark_used(source)
31644 mark_used(comm)
31645 mark_used(tag)
31646 msgout = msgin
31647#endif
31648 CALL mp_timestop(handle)
31649 END SUBROUTINE mp_sendrecv_c
31650
31651! **************************************************************************************************
31652!> \brief Sends and receives vector data
31653!> \param[in] msgin Data to send
31654!> \param[in] dest Process to send data to
31655!> \param[out] msgout Received data
31656!> \param[in] source Process from which to receive
31657!> \param[in] comm Message passing environment identifier
31658!> \param[in] tag Send and recv tag (default: 0)
31659! **************************************************************************************************
31660 SUBROUTINE mp_sendrecv_cv(msgin, dest, msgout, source, comm, tag)
31661 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
31662 INTEGER, INTENT(IN) :: dest
31663 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
31664 INTEGER, INTENT(IN) :: source
31665 CLASS(mp_comm_type), INTENT(IN) :: comm
31666 INTEGER, INTENT(IN), OPTIONAL :: tag
31667
31668 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cv'
31669
31670 INTEGER :: handle
31671#if defined(__parallel)
31672 INTEGER :: ierr, msglen_in, msglen_out, &
31673 recv_tag, send_tag
31674#endif
31675
31676 CALL mp_timeset(routinen, handle)
31677
31678#if defined(__parallel)
31679 msglen_in = SIZE(msgin)
31680 msglen_out = SIZE(msgout)
31681 send_tag = 0 ! cannot think of something better here, this might be dangerous
31682 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31683 IF (PRESENT(tag)) THEN
31684 send_tag = tag
31685 recv_tag = tag
31686 END IF
31687 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31688 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31689 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31690 CALL add_perf(perf_id=7, count=1, &
31691 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31692#else
31693 mark_used(dest)
31694 mark_used(source)
31695 mark_used(comm)
31696 mark_used(tag)
31697 msgout = msgin
31698#endif
31699 CALL mp_timestop(handle)
31700 END SUBROUTINE mp_sendrecv_cv
31701
31702! **************************************************************************************************
31703!> \brief Sends and receives matrix data
31704!> \param msgin ...
31705!> \param dest ...
31706!> \param msgout ...
31707!> \param source ...
31708!> \param comm ...
31709!> \param tag ...
31710!> \note see mp_sendrecv_cv
31711! **************************************************************************************************
31712 SUBROUTINE mp_sendrecv_cm2(msgin, dest, msgout, source, comm, tag)
31713 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
31714 INTEGER, INTENT(IN) :: dest
31715 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
31716 INTEGER, INTENT(IN) :: source
31717 CLASS(mp_comm_type), INTENT(IN) :: comm
31718 INTEGER, INTENT(IN), OPTIONAL :: tag
31719
31720 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm2'
31721
31722 INTEGER :: handle
31723#if defined(__parallel)
31724 INTEGER :: ierr, msglen_in, msglen_out, &
31725 recv_tag, send_tag
31726#endif
31727
31728 CALL mp_timeset(routinen, handle)
31729
31730#if defined(__parallel)
31731 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
31732 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
31733 send_tag = 0 ! cannot think of something better here, this might be dangerous
31734 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31735 IF (PRESENT(tag)) THEN
31736 send_tag = tag
31737 recv_tag = tag
31738 END IF
31739 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31740 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31741 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31742 CALL add_perf(perf_id=7, count=1, &
31743 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31744#else
31745 mark_used(dest)
31746 mark_used(source)
31747 mark_used(comm)
31748 mark_used(tag)
31749 msgout = msgin
31750#endif
31751 CALL mp_timestop(handle)
31752 END SUBROUTINE mp_sendrecv_cm2
31753
31754! **************************************************************************************************
31755!> \brief Sends and receives rank-3 data
31756!> \param msgin ...
31757!> \param dest ...
31758!> \param msgout ...
31759!> \param source ...
31760!> \param comm ...
31761!> \note see mp_sendrecv_cv
31762! **************************************************************************************************
31763 SUBROUTINE mp_sendrecv_cm3(msgin, dest, msgout, source, comm, tag)
31764 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
31765 INTEGER, INTENT(IN) :: dest
31766 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
31767 INTEGER, INTENT(IN) :: source
31768 CLASS(mp_comm_type), INTENT(IN) :: comm
31769 INTEGER, INTENT(IN), OPTIONAL :: tag
31770
31771 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm3'
31772
31773 INTEGER :: handle
31774#if defined(__parallel)
31775 INTEGER :: ierr, msglen_in, msglen_out, &
31776 recv_tag, send_tag
31777#endif
31778
31779 CALL mp_timeset(routinen, handle)
31780
31781#if defined(__parallel)
31782 msglen_in = SIZE(msgin)
31783 msglen_out = SIZE(msgout)
31784 send_tag = 0 ! cannot think of something better here, this might be dangerous
31785 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31786 IF (PRESENT(tag)) THEN
31787 send_tag = tag
31788 recv_tag = tag
31789 END IF
31790 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31791 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31792 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31793 CALL add_perf(perf_id=7, count=1, &
31794 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31795#else
31796 mark_used(dest)
31797 mark_used(source)
31798 mark_used(comm)
31799 mark_used(tag)
31800 msgout = msgin
31801#endif
31802 CALL mp_timestop(handle)
31803 END SUBROUTINE mp_sendrecv_cm3
31804
31805! **************************************************************************************************
31806!> \brief Sends and receives rank-4 data
31807!> \param msgin ...
31808!> \param dest ...
31809!> \param msgout ...
31810!> \param source ...
31811!> \param comm ...
31812!> \note see mp_sendrecv_cv
31813! **************************************************************************************************
31814 SUBROUTINE mp_sendrecv_cm4(msgin, dest, msgout, source, comm, tag)
31815 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
31816 INTEGER, INTENT(IN) :: dest
31817 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
31818 INTEGER, INTENT(IN) :: source
31819 CLASS(mp_comm_type), INTENT(IN) :: comm
31820 INTEGER, INTENT(IN), OPTIONAL :: tag
31821
31822 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm4'
31823
31824 INTEGER :: handle
31825#if defined(__parallel)
31826 INTEGER :: ierr, msglen_in, msglen_out, &
31827 recv_tag, send_tag
31828#endif
31829
31830 CALL mp_timeset(routinen, handle)
31831
31832#if defined(__parallel)
31833 msglen_in = SIZE(msgin)
31834 msglen_out = SIZE(msgout)
31835 send_tag = 0 ! cannot think of something better here, this might be dangerous
31836 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31837 IF (PRESENT(tag)) THEN
31838 send_tag = tag
31839 recv_tag = tag
31840 END IF
31841 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31842 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31843 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31844 CALL add_perf(perf_id=7, count=1, &
31845 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31846#else
31847 mark_used(dest)
31848 mark_used(source)
31849 mark_used(comm)
31850 mark_used(tag)
31851 msgout = msgin
31852#endif
31853 CALL mp_timestop(handle)
31854 END SUBROUTINE mp_sendrecv_cm4
31855
31856! **************************************************************************************************
31857!> \brief Non-blocking send and receive of a scalar
31858!> \param[in] msgin Scalar data to send
31859!> \param[in] dest Which process to send to
31860!> \param[out] msgout Receive data into this pointer
31861!> \param[in] source Process to receive from
31862!> \param[in] comm Message passing environment identifier
31863!> \param[out] send_request Request handle for the send
31864!> \param[out] recv_request Request handle for the receive
31865!> \param[in] tag (optional) tag to differentiate requests
31866!> \par Implementation
31867!> Calls mpi_isend and mpi_irecv.
31868!> \par History
31869!> 02.2005 created [Alfio Lazzaro]
31870! **************************************************************************************************
31871 SUBROUTINE mp_isendrecv_c (msgin, dest, msgout, source, comm, send_request, &
31872 recv_request, tag)
31873 COMPLEX(kind=real_4), INTENT(IN) :: msgin
31874 INTEGER, INTENT(IN) :: dest
31875 COMPLEX(kind=real_4), INTENT(INOUT) :: msgout
31876 INTEGER, INTENT(IN) :: source
31877 CLASS(mp_comm_type), INTENT(IN) :: comm
31878 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
31879 INTEGER, INTENT(in), OPTIONAL :: tag
31880
31881 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_c'
31882
31883 INTEGER :: handle
31884#if defined(__parallel)
31885 INTEGER :: ierr, my_tag
31886#endif
31887
31888 CALL mp_timeset(routinen, handle)
31889
31890#if defined(__parallel)
31891 my_tag = 0
31892 IF (PRESENT(tag)) my_tag = tag
31893
31894 CALL mpi_irecv(msgout, 1, mpi_complex, source, my_tag, &
31895 comm%handle, recv_request%handle, ierr)
31896 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
31897
31898 CALL mpi_isend(msgin, 1, mpi_complex, dest, my_tag, &
31899 comm%handle, send_request%handle, ierr)
31900 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
31901
31902 CALL add_perf(perf_id=8, count=1, msg_size=2*(2*real_4_size))
31903#else
31904 mark_used(dest)
31905 mark_used(source)
31906 mark_used(comm)
31907 mark_used(tag)
31908 send_request = mp_request_null
31909 recv_request = mp_request_null
31910 msgout = msgin
31911#endif
31912 CALL mp_timestop(handle)
31913 END SUBROUTINE mp_isendrecv_c
31914
31915! **************************************************************************************************
31916!> \brief Non-blocking send and receive of a vector
31917!> \param[in] msgin Vector data to send
31918!> \param[in] dest Which process to send to
31919!> \param[out] msgout Receive data into this pointer
31920!> \param[in] source Process to receive from
31921!> \param[in] comm Message passing environment identifier
31922!> \param[out] send_request Request handle for the send
31923!> \param[out] recv_request Request handle for the receive
31924!> \param[in] tag (optional) tag to differentiate requests
31925!> \par Implementation
31926!> Calls mpi_isend and mpi_irecv.
31927!> \par History
31928!> 11.2004 created [Joost VandeVondele]
31929!> \note
31930!> arrays can be pointers or assumed shape, but they must be contiguous!
31931! **************************************************************************************************
31932 SUBROUTINE mp_isendrecv_cv(msgin, dest, msgout, source, comm, send_request, &
31933 recv_request, tag)
31934 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
31935 INTEGER, INTENT(IN) :: dest
31936 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
31937 INTEGER, INTENT(IN) :: source
31938 CLASS(mp_comm_type), INTENT(IN) :: comm
31939 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
31940 INTEGER, INTENT(in), OPTIONAL :: tag
31941
31942 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_cv'
31943
31944 INTEGER :: handle
31945#if defined(__parallel)
31946 INTEGER :: ierr, msglen, my_tag
31947 COMPLEX(kind=real_4) :: foo
31948#endif
31949
31950 CALL mp_timeset(routinen, handle)
31951
31952#if defined(__parallel)
31953#if !defined(__GNUC__) || __GNUC__ >= 9
31954 cpassert(is_contiguous(msgout))
31955 cpassert(is_contiguous(msgin))
31956#endif
31957
31958 my_tag = 0
31959 IF (PRESENT(tag)) my_tag = tag
31960
31961 msglen = SIZE(msgout, 1)
31962 IF (msglen > 0) THEN
31963 CALL mpi_irecv(msgout(1), msglen, mpi_complex, source, my_tag, &
31964 comm%handle, recv_request%handle, ierr)
31965 ELSE
31966 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
31967 comm%handle, recv_request%handle, ierr)
31968 END IF
31969 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
31970
31971 msglen = SIZE(msgin, 1)
31972 IF (msglen > 0) THEN
31973 CALL mpi_isend(msgin(1), msglen, mpi_complex, dest, my_tag, &
31974 comm%handle, send_request%handle, ierr)
31975 ELSE
31976 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
31977 comm%handle, send_request%handle, ierr)
31978 END IF
31979 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
31980
31981 msglen = (msglen + SIZE(msgout, 1) + 1)/2
31982 CALL add_perf(perf_id=8, count=1, msg_size=msglen*(2*real_4_size))
31983#else
31984 mark_used(dest)
31985 mark_used(source)
31986 mark_used(comm)
31987 mark_used(tag)
31988 send_request = mp_request_null
31989 recv_request = mp_request_null
31990 msgout = msgin
31991#endif
31992 CALL mp_timestop(handle)
31993 END SUBROUTINE mp_isendrecv_cv
31994
31995! **************************************************************************************************
31996!> \brief Non-blocking send of vector data
31997!> \param msgin ...
31998!> \param dest ...
31999!> \param comm ...
32000!> \param request ...
32001!> \param tag ...
32002!> \par History
32003!> 08.2003 created [f&j]
32004!> \note see mp_isendrecv_cv
32005!> \note
32006!> arrays can be pointers or assumed shape, but they must be contiguous!
32007! **************************************************************************************************
32008 SUBROUTINE mp_isend_cv(msgin, dest, comm, request, tag)
32009 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
32010 INTEGER, INTENT(IN) :: dest
32011 CLASS(mp_comm_type), INTENT(IN) :: comm
32012 TYPE(mp_request_type), INTENT(out) :: request
32013 INTEGER, INTENT(in), OPTIONAL :: tag
32014
32015 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cv'
32016
32017 INTEGER :: handle, ierr
32018#if defined(__parallel)
32019 INTEGER :: msglen, my_tag
32020 COMPLEX(kind=real_4) :: foo(1)
32021#endif
32022
32023 CALL mp_timeset(routinen, handle)
32024
32025#if defined(__parallel)
32026#if !defined(__GNUC__) || __GNUC__ >= 9
32027 cpassert(is_contiguous(msgin))
32028#endif
32029 my_tag = 0
32030 IF (PRESENT(tag)) my_tag = tag
32031
32032 msglen = SIZE(msgin)
32033 IF (msglen > 0) THEN
32034 CALL mpi_isend(msgin(1), msglen, mpi_complex, dest, my_tag, &
32035 comm%handle, request%handle, ierr)
32036 ELSE
32037 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32038 comm%handle, request%handle, ierr)
32039 END IF
32040 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32041
32042 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32043#else
32044 mark_used(msgin)
32045 mark_used(dest)
32046 mark_used(comm)
32047 mark_used(request)
32048 mark_used(tag)
32049 ierr = 1
32050 request = mp_request_null
32051 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32052#endif
32053 CALL mp_timestop(handle)
32054 END SUBROUTINE mp_isend_cv
32055
32056! **************************************************************************************************
32057!> \brief Non-blocking send of matrix data
32058!> \param msgin ...
32059!> \param dest ...
32060!> \param comm ...
32061!> \param request ...
32062!> \param tag ...
32063!> \par History
32064!> 2009-11-25 [UB] Made type-generic for templates
32065!> \author fawzi
32066!> \note see mp_isendrecv_cv
32067!> \note see mp_isend_cv
32068!> \note
32069!> arrays can be pointers or assumed shape, but they must be contiguous!
32070! **************************************************************************************************
32071 SUBROUTINE mp_isend_cm2(msgin, dest, comm, request, tag)
32072 COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(IN) :: msgin
32073 INTEGER, INTENT(IN) :: dest
32074 CLASS(mp_comm_type), INTENT(IN) :: comm
32075 TYPE(mp_request_type), INTENT(out) :: request
32076 INTEGER, INTENT(in), OPTIONAL :: tag
32077
32078 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm2'
32079
32080 INTEGER :: handle, ierr
32081#if defined(__parallel)
32082 INTEGER :: msglen, my_tag
32083 COMPLEX(kind=real_4) :: foo(1)
32084#endif
32085
32086 CALL mp_timeset(routinen, handle)
32087
32088#if defined(__parallel)
32089#if !defined(__GNUC__) || __GNUC__ >= 9
32090 cpassert(is_contiguous(msgin))
32091#endif
32092
32093 my_tag = 0
32094 IF (PRESENT(tag)) my_tag = tag
32095
32096 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
32097 IF (msglen > 0) THEN
32098 CALL mpi_isend(msgin(1, 1), msglen, mpi_complex, dest, my_tag, &
32099 comm%handle, request%handle, ierr)
32100 ELSE
32101 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32102 comm%handle, request%handle, ierr)
32103 END IF
32104 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32105
32106 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32107#else
32108 mark_used(msgin)
32109 mark_used(dest)
32110 mark_used(comm)
32111 mark_used(request)
32112 mark_used(tag)
32113 ierr = 1
32114 request = mp_request_null
32115 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32116#endif
32117 CALL mp_timestop(handle)
32118 END SUBROUTINE mp_isend_cm2
32119
32120! **************************************************************************************************
32121!> \brief Non-blocking send of rank-3 data
32122!> \param msgin ...
32123!> \param dest ...
32124!> \param comm ...
32125!> \param request ...
32126!> \param tag ...
32127!> \par History
32128!> 9.2008 added _rm3 subroutine [Iain Bethune]
32129!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
32130!> 2009-11-25 [UB] Made type-generic for templates
32131!> \author fawzi
32132!> \note see mp_isendrecv_cv
32133!> \note see mp_isend_cv
32134!> \note
32135!> arrays can be pointers or assumed shape, but they must be contiguous!
32136! **************************************************************************************************
32137 SUBROUTINE mp_isend_cm3(msgin, dest, comm, request, tag)
32138 COMPLEX(kind=real_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
32139 INTEGER, INTENT(IN) :: dest
32140 CLASS(mp_comm_type), INTENT(IN) :: comm
32141 TYPE(mp_request_type), INTENT(out) :: request
32142 INTEGER, INTENT(in), OPTIONAL :: tag
32143
32144 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm3'
32145
32146 INTEGER :: handle, ierr
32147#if defined(__parallel)
32148 INTEGER :: msglen, my_tag
32149 COMPLEX(kind=real_4) :: foo(1)
32150#endif
32151
32152 CALL mp_timeset(routinen, handle)
32153
32154#if defined(__parallel)
32155#if !defined(__GNUC__) || __GNUC__ >= 9
32156 cpassert(is_contiguous(msgin))
32157#endif
32158
32159 my_tag = 0
32160 IF (PRESENT(tag)) my_tag = tag
32161
32162 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
32163 IF (msglen > 0) THEN
32164 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_complex, dest, my_tag, &
32165 comm%handle, request%handle, ierr)
32166 ELSE
32167 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32168 comm%handle, request%handle, ierr)
32169 END IF
32170 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32171
32172 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32173#else
32174 mark_used(msgin)
32175 mark_used(dest)
32176 mark_used(comm)
32177 mark_used(request)
32178 mark_used(tag)
32179 ierr = 1
32180 request = mp_request_null
32181 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32182#endif
32183 CALL mp_timestop(handle)
32184 END SUBROUTINE mp_isend_cm3
32185
32186! **************************************************************************************************
32187!> \brief Non-blocking send of rank-4 data
32188!> \param msgin the input message
32189!> \param dest the destination processor
32190!> \param comm the communicator object
32191!> \param request the communication request id
32192!> \param tag the message tag
32193!> \par History
32194!> 2.2016 added _cm4 subroutine [Nico Holmberg]
32195!> \author fawzi
32196!> \note see mp_isend_cv
32197!> \note
32198!> arrays can be pointers or assumed shape, but they must be contiguous!
32199! **************************************************************************************************
32200 SUBROUTINE mp_isend_cm4(msgin, dest, comm, request, tag)
32201 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
32202 INTEGER, INTENT(IN) :: dest
32203 CLASS(mp_comm_type), INTENT(IN) :: comm
32204 TYPE(mp_request_type), INTENT(out) :: request
32205 INTEGER, INTENT(in), OPTIONAL :: tag
32206
32207 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm4'
32208
32209 INTEGER :: handle, ierr
32210#if defined(__parallel)
32211 INTEGER :: msglen, my_tag
32212 COMPLEX(kind=real_4) :: foo(1)
32213#endif
32214
32215 CALL mp_timeset(routinen, handle)
32216
32217#if defined(__parallel)
32218#if !defined(__GNUC__) || __GNUC__ >= 9
32219 cpassert(is_contiguous(msgin))
32220#endif
32221
32222 my_tag = 0
32223 IF (PRESENT(tag)) my_tag = tag
32224
32225 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
32226 IF (msglen > 0) THEN
32227 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_complex, dest, my_tag, &
32228 comm%handle, request%handle, ierr)
32229 ELSE
32230 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32231 comm%handle, request%handle, ierr)
32232 END IF
32233 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32234
32235 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32236#else
32237 mark_used(msgin)
32238 mark_used(dest)
32239 mark_used(comm)
32240 mark_used(request)
32241 mark_used(tag)
32242 ierr = 1
32243 request = mp_request_null
32244 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32245#endif
32246 CALL mp_timestop(handle)
32247 END SUBROUTINE mp_isend_cm4
32248
32249! **************************************************************************************************
32250!> \brief Non-blocking receive of vector data
32251!> \param msgout ...
32252!> \param source ...
32253!> \param comm ...
32254!> \param request ...
32255!> \param tag ...
32256!> \par History
32257!> 08.2003 created [f&j]
32258!> 2009-11-25 [UB] Made type-generic for templates
32259!> \note see mp_isendrecv_cv
32260!> \note
32261!> arrays can be pointers or assumed shape, but they must be contiguous!
32262! **************************************************************************************************
32263 SUBROUTINE mp_irecv_cv(msgout, source, comm, request, tag)
32264 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
32265 INTEGER, INTENT(IN) :: source
32266 CLASS(mp_comm_type), INTENT(IN) :: comm
32267 TYPE(mp_request_type), INTENT(out) :: request
32268 INTEGER, INTENT(in), OPTIONAL :: tag
32269
32270 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cv'
32271
32272 INTEGER :: handle
32273#if defined(__parallel)
32274 INTEGER :: ierr, msglen, my_tag
32275 COMPLEX(kind=real_4) :: foo(1)
32276#endif
32277
32278 CALL mp_timeset(routinen, handle)
32279
32280#if defined(__parallel)
32281#if !defined(__GNUC__) || __GNUC__ >= 9
32282 cpassert(is_contiguous(msgout))
32283#endif
32284
32285 my_tag = 0
32286 IF (PRESENT(tag)) my_tag = tag
32287
32288 msglen = SIZE(msgout)
32289 IF (msglen > 0) THEN
32290 CALL mpi_irecv(msgout(1), msglen, mpi_complex, source, my_tag, &
32291 comm%handle, request%handle, ierr)
32292 ELSE
32293 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32294 comm%handle, request%handle, ierr)
32295 END IF
32296 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32297
32298 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32299#else
32300 cpabort("mp_irecv called in non parallel case")
32301 mark_used(msgout)
32302 mark_used(source)
32303 mark_used(comm)
32304 mark_used(tag)
32305 request = mp_request_null
32306#endif
32307 CALL mp_timestop(handle)
32308 END SUBROUTINE mp_irecv_cv
32309
32310! **************************************************************************************************
32311!> \brief Non-blocking receive of matrix data
32312!> \param msgout ...
32313!> \param source ...
32314!> \param comm ...
32315!> \param request ...
32316!> \param tag ...
32317!> \par History
32318!> 2009-11-25 [UB] Made type-generic for templates
32319!> \author fawzi
32320!> \note see mp_isendrecv_cv
32321!> \note see mp_irecv_cv
32322!> \note
32323!> arrays can be pointers or assumed shape, but they must be contiguous!
32324! **************************************************************************************************
32325 SUBROUTINE mp_irecv_cm2(msgout, source, comm, request, tag)
32326 COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
32327 INTEGER, INTENT(IN) :: source
32328 CLASS(mp_comm_type), INTENT(IN) :: comm
32329 TYPE(mp_request_type), INTENT(out) :: request
32330 INTEGER, INTENT(in), OPTIONAL :: tag
32331
32332 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm2'
32333
32334 INTEGER :: handle
32335#if defined(__parallel)
32336 INTEGER :: ierr, msglen, my_tag
32337 COMPLEX(kind=real_4) :: foo(1)
32338#endif
32339
32340 CALL mp_timeset(routinen, handle)
32341
32342#if defined(__parallel)
32343#if !defined(__GNUC__) || __GNUC__ >= 9
32344 cpassert(is_contiguous(msgout))
32345#endif
32346
32347 my_tag = 0
32348 IF (PRESENT(tag)) my_tag = tag
32349
32350 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
32351 IF (msglen > 0) THEN
32352 CALL mpi_irecv(msgout(1, 1), msglen, mpi_complex, source, my_tag, &
32353 comm%handle, request%handle, ierr)
32354 ELSE
32355 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32356 comm%handle, request%handle, ierr)
32357 END IF
32358 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32359
32360 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32361#else
32362 mark_used(msgout)
32363 mark_used(source)
32364 mark_used(comm)
32365 mark_used(tag)
32366 request = mp_request_null
32367 cpabort("mp_irecv called in non parallel case")
32368#endif
32369 CALL mp_timestop(handle)
32370 END SUBROUTINE mp_irecv_cm2
32371
32372! **************************************************************************************************
32373!> \brief Non-blocking send of rank-3 data
32374!> \param msgout ...
32375!> \param source ...
32376!> \param comm ...
32377!> \param request ...
32378!> \param tag ...
32379!> \par History
32380!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
32381!> 2009-11-25 [UB] Made type-generic for templates
32382!> \author fawzi
32383!> \note see mp_isendrecv_cv
32384!> \note see mp_irecv_cv
32385!> \note
32386!> arrays can be pointers or assumed shape, but they must be contiguous!
32387! **************************************************************************************************
32388 SUBROUTINE mp_irecv_cm3(msgout, source, comm, request, tag)
32389 COMPLEX(kind=real_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
32390 INTEGER, INTENT(IN) :: source
32391 CLASS(mp_comm_type), INTENT(IN) :: comm
32392 TYPE(mp_request_type), INTENT(out) :: request
32393 INTEGER, INTENT(in), OPTIONAL :: tag
32394
32395 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm3'
32396
32397 INTEGER :: handle
32398#if defined(__parallel)
32399 INTEGER :: ierr, msglen, my_tag
32400 COMPLEX(kind=real_4) :: foo(1)
32401#endif
32402
32403 CALL mp_timeset(routinen, handle)
32404
32405#if defined(__parallel)
32406#if !defined(__GNUC__) || __GNUC__ >= 9
32407 cpassert(is_contiguous(msgout))
32408#endif
32409
32410 my_tag = 0
32411 IF (PRESENT(tag)) my_tag = tag
32412
32413 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
32414 IF (msglen > 0) THEN
32415 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_complex, source, my_tag, &
32416 comm%handle, request%handle, ierr)
32417 ELSE
32418 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32419 comm%handle, request%handle, ierr)
32420 END IF
32421 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
32422
32423 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32424#else
32425 mark_used(msgout)
32426 mark_used(source)
32427 mark_used(comm)
32428 mark_used(tag)
32429 request = mp_request_null
32430 cpabort("mp_irecv called in non parallel case")
32431#endif
32432 CALL mp_timestop(handle)
32433 END SUBROUTINE mp_irecv_cm3
32434
32435! **************************************************************************************************
32436!> \brief Non-blocking receive of rank-4 data
32437!> \param msgout the output message
32438!> \param source the source processor
32439!> \param comm the communicator object
32440!> \param request the communication request id
32441!> \param tag the message tag
32442!> \par History
32443!> 2.2016 added _cm4 subroutine [Nico Holmberg]
32444!> \author fawzi
32445!> \note see mp_irecv_cv
32446!> \note
32447!> arrays can be pointers or assumed shape, but they must be contiguous!
32448! **************************************************************************************************
32449 SUBROUTINE mp_irecv_cm4(msgout, source, comm, request, tag)
32450 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
32451 INTEGER, INTENT(IN) :: source
32452 CLASS(mp_comm_type), INTENT(IN) :: comm
32453 TYPE(mp_request_type), INTENT(out) :: request
32454 INTEGER, INTENT(in), OPTIONAL :: tag
32455
32456 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm4'
32457
32458 INTEGER :: handle
32459#if defined(__parallel)
32460 INTEGER :: ierr, msglen, my_tag
32461 COMPLEX(kind=real_4) :: foo(1)
32462#endif
32463
32464 CALL mp_timeset(routinen, handle)
32465
32466#if defined(__parallel)
32467#if !defined(__GNUC__) || __GNUC__ >= 9
32468 cpassert(is_contiguous(msgout))
32469#endif
32470
32471 my_tag = 0
32472 IF (PRESENT(tag)) my_tag = tag
32473
32474 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
32475 IF (msglen > 0) THEN
32476 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_complex, source, my_tag, &
32477 comm%handle, request%handle, ierr)
32478 ELSE
32479 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32480 comm%handle, request%handle, ierr)
32481 END IF
32482 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
32483
32484 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32485#else
32486 mark_used(msgout)
32487 mark_used(source)
32488 mark_used(comm)
32489 mark_used(tag)
32490 request = mp_request_null
32491 cpabort("mp_irecv called in non parallel case")
32492#endif
32493 CALL mp_timestop(handle)
32494 END SUBROUTINE mp_irecv_cm4
32495
32496! **************************************************************************************************
32497!> \brief Window initialization function for vector data
32498!> \param base ...
32499!> \param comm ...
32500!> \param win ...
32501!> \par History
32502!> 02.2015 created [Alfio Lazzaro]
32503!> \note
32504!> arrays can be pointers or assumed shape, but they must be contiguous!
32505! **************************************************************************************************
32506 SUBROUTINE mp_win_create_cv(base, comm, win)
32507 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
32508 TYPE(mp_comm_type), INTENT(IN) :: comm
32509 CLASS(mp_win_type), INTENT(INOUT) :: win
32510
32511 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_cv'
32512
32513 INTEGER :: handle
32514#if defined(__parallel)
32515 INTEGER :: ierr
32516 INTEGER(kind=mpi_address_kind) :: len
32517 COMPLEX(kind=real_4) :: foo(1)
32518#endif
32519
32520 CALL mp_timeset(routinen, handle)
32521
32522#if defined(__parallel)
32523
32524 len = SIZE(base)*(2*real_4_size)
32525 IF (len > 0) THEN
32526 CALL mpi_win_create(base(1), len, (2*real_4_size), mpi_info_null, comm%handle, win%handle, ierr)
32527 ELSE
32528 CALL mpi_win_create(foo, len, (2*real_4_size), mpi_info_null, comm%handle, win%handle, ierr)
32529 END IF
32530 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
32531
32532 CALL add_perf(perf_id=20, count=1)
32533#else
32534 mark_used(base)
32535 mark_used(comm)
32536 win%handle = mp_win_null_handle
32537#endif
32538 CALL mp_timestop(handle)
32539 END SUBROUTINE mp_win_create_cv
32540
32541! **************************************************************************************************
32542!> \brief Single-sided get function for vector data
32543!> \param base ...
32544!> \param comm ...
32545!> \param win ...
32546!> \par History
32547!> 02.2015 created [Alfio Lazzaro]
32548!> \note
32549!> arrays can be pointers or assumed shape, but they must be contiguous!
32550! **************************************************************************************************
32551 SUBROUTINE mp_rget_cv(base, source, win, win_data, myproc, disp, request, &
32552 origin_datatype, target_datatype)
32553 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
32554 INTEGER, INTENT(IN) :: source
32555 CLASS(mp_win_type), INTENT(IN) :: win
32556 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: win_data
32557 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
32558 TYPE(mp_request_type), INTENT(OUT) :: request
32559 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
32560
32561 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_cv'
32562
32563 INTEGER :: handle
32564#if defined(__parallel)
32565 INTEGER :: ierr, len, &
32566 origin_len, target_len
32567 LOGICAL :: do_local_copy
32568 INTEGER(kind=mpi_address_kind) :: disp_aint
32569 mpi_data_type :: handle_origin_datatype, handle_target_datatype
32570#endif
32571
32572 CALL mp_timeset(routinen, handle)
32573
32574#if defined(__parallel)
32575 len = SIZE(base)
32576 disp_aint = 0
32577 IF (PRESENT(disp)) THEN
32578 disp_aint = int(disp, kind=mpi_address_kind)
32579 END IF
32580 handle_origin_datatype = mpi_complex
32581 origin_len = len
32582 IF (PRESENT(origin_datatype)) THEN
32583 handle_origin_datatype = origin_datatype%type_handle
32584 origin_len = 1
32585 END IF
32586 handle_target_datatype = mpi_complex
32587 target_len = len
32588 IF (PRESENT(target_datatype)) THEN
32589 handle_target_datatype = target_datatype%type_handle
32590 target_len = 1
32591 END IF
32592 IF (len > 0) THEN
32593 do_local_copy = .false.
32594 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
32595 IF (myproc .EQ. source) do_local_copy = .true.
32596 END IF
32597 IF (do_local_copy) THEN
32598 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
32599 base(:) = win_data(disp_aint + 1:disp_aint + len)
32600 !$OMP END PARALLEL WORKSHARE
32601 request = mp_request_null
32602 ierr = 0
32603 ELSE
32604 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
32605 target_len, handle_target_datatype, win%handle, request%handle, ierr)
32606 END IF
32607 ELSE
32608 request = mp_request_null
32609 ierr = 0
32610 END IF
32611 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
32612
32613 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*(2*real_4_size))
32614#else
32615 mark_used(source)
32616 mark_used(win)
32617 mark_used(myproc)
32618 mark_used(origin_datatype)
32619 mark_used(target_datatype)
32620
32621 request = mp_request_null
32622 !
32623 IF (PRESENT(disp)) THEN
32624 base(:) = win_data(disp + 1:disp + SIZE(base))
32625 ELSE
32626 base(:) = win_data(:SIZE(base))
32627 END IF
32628
32629#endif
32630 CALL mp_timestop(handle)
32631 END SUBROUTINE mp_rget_cv
32632
32633! **************************************************************************************************
32634!> \brief ...
32635!> \param count ...
32636!> \param lengths ...
32637!> \param displs ...
32638!> \return ...
32639! ***************************************************************************
32640 FUNCTION mp_type_indexed_make_c (count, lengths, displs) &
32641 result(type_descriptor)
32642 INTEGER, INTENT(IN) :: count
32643 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
32644 TYPE(mp_type_descriptor_type) :: type_descriptor
32645
32646 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_c'
32647
32648 INTEGER :: handle
32649#if defined(__parallel)
32650 INTEGER :: ierr
32651#endif
32652
32653 CALL mp_timeset(routinen, handle)
32654
32655#if defined(__parallel)
32656 CALL mpi_type_indexed(count, lengths, displs, mpi_complex, &
32657 type_descriptor%type_handle, ierr)
32658 IF (ierr /= 0) &
32659 cpabort("MPI_Type_Indexed @ "//routinen)
32660 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
32661 IF (ierr /= 0) &
32662 cpabort("MPI_Type_commit @ "//routinen)
32663#else
32664 type_descriptor%type_handle = 5
32665#endif
32666 type_descriptor%length = count
32667 NULLIFY (type_descriptor%subtype)
32668 type_descriptor%vector_descriptor(1:2) = 1
32669 type_descriptor%has_indexing = .true.
32670 type_descriptor%index_descriptor%index => lengths
32671 type_descriptor%index_descriptor%chunks => displs
32672
32673 CALL mp_timestop(handle)
32674
32675 END FUNCTION mp_type_indexed_make_c
32676
32677! **************************************************************************************************
32678!> \brief Allocates special parallel memory
32679!> \param[in] DATA pointer to integer array to allocate
32680!> \param[in] len number of integers to allocate
32681!> \param[out] stat (optional) allocation status result
32682!> \author UB
32683! **************************************************************************************************
32684 SUBROUTINE mp_allocate_c (DATA, len, stat)
32685 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
32686 INTEGER, INTENT(IN) :: len
32687 INTEGER, INTENT(OUT), OPTIONAL :: stat
32688
32689 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_c'
32690
32691 INTEGER :: handle, ierr
32692
32693 CALL mp_timeset(routinen, handle)
32694
32695#if defined(__parallel)
32696 NULLIFY (data)
32697 CALL mp_alloc_mem(DATA, len, stat=ierr)
32698 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
32699 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
32700 CALL add_perf(perf_id=15, count=1)
32701#else
32702 ALLOCATE (DATA(len), stat=ierr)
32703 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
32704 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
32705#endif
32706 IF (PRESENT(stat)) stat = ierr
32707 CALL mp_timestop(handle)
32708 END SUBROUTINE mp_allocate_c
32709
32710! **************************************************************************************************
32711!> \brief Deallocates special parallel memory
32712!> \param[in] DATA pointer to special memory to deallocate
32713!> \param stat ...
32714!> \author UB
32715! **************************************************************************************************
32716 SUBROUTINE mp_deallocate_c (DATA, stat)
32717 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
32718 INTEGER, INTENT(OUT), OPTIONAL :: stat
32719
32720 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_c'
32721
32722 INTEGER :: handle
32723#if defined(__parallel)
32724 INTEGER :: ierr
32725#endif
32726
32727 CALL mp_timeset(routinen, handle)
32728
32729#if defined(__parallel)
32730 CALL mp_free_mem(DATA, ierr)
32731 IF (PRESENT(stat)) THEN
32732 stat = ierr
32733 ELSE
32734 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
32735 END IF
32736 NULLIFY (data)
32737 CALL add_perf(perf_id=15, count=1)
32738#else
32739 DEALLOCATE (data)
32740 IF (PRESENT(stat)) stat = 0
32741#endif
32742 CALL mp_timestop(handle)
32743 END SUBROUTINE mp_deallocate_c
32744
32745! **************************************************************************************************
32746!> \brief (parallel) Blocking individual file write using explicit offsets
32747!> (serial) Unformatted stream write
32748!> \param[in] fh file handle (file storage unit)
32749!> \param[in] offset file offset (position)
32750!> \param[in] msg data to be written to the file
32751!> \param msglen ...
32752!> \par MPI-I/O mapping mpi_file_write_at
32753!> \par STREAM-I/O mapping WRITE
32754!> \param[in](optional) msglen number of the elements of data
32755! **************************************************************************************************
32756 SUBROUTINE mp_file_write_at_cv(fh, offset, msg, msglen)
32757 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
32758 CLASS(mp_file_type), INTENT(IN) :: fh
32759 INTEGER, INTENT(IN), OPTIONAL :: msglen
32760 INTEGER(kind=file_offset), INTENT(IN) :: offset
32761
32762 INTEGER :: msg_len
32763#if defined(__parallel)
32764 INTEGER :: ierr
32765#endif
32766
32767 msg_len = SIZE(msg)
32768 IF (PRESENT(msglen)) msg_len = msglen
32769#if defined(__parallel)
32770 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
32771 IF (ierr .NE. 0) &
32772 cpabort("mpi_file_write_at_cv @ mp_file_write_at_cv")
32773#else
32774 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
32775#endif
32776 END SUBROUTINE mp_file_write_at_cv
32777
32778! **************************************************************************************************
32779!> \brief ...
32780!> \param fh ...
32781!> \param offset ...
32782!> \param msg ...
32783! **************************************************************************************************
32784 SUBROUTINE mp_file_write_at_c (fh, offset, msg)
32785 COMPLEX(kind=real_4), INTENT(IN) :: msg
32786 CLASS(mp_file_type), INTENT(IN) :: fh
32787 INTEGER(kind=file_offset), INTENT(IN) :: offset
32788
32789#if defined(__parallel)
32790 INTEGER :: ierr
32791
32792 ierr = 0
32793 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
32794 IF (ierr .NE. 0) &
32795 cpabort("mpi_file_write_at_c @ mp_file_write_at_c")
32796#else
32797 WRITE (unit=fh%handle, pos=offset + 1) msg
32798#endif
32799 END SUBROUTINE mp_file_write_at_c
32800
32801! **************************************************************************************************
32802!> \brief (parallel) Blocking collective file write using explicit offsets
32803!> (serial) Unformatted stream write
32804!> \param fh ...
32805!> \param offset ...
32806!> \param msg ...
32807!> \param msglen ...
32808!> \par MPI-I/O mapping mpi_file_write_at_all
32809!> \par STREAM-I/O mapping WRITE
32810! **************************************************************************************************
32811 SUBROUTINE mp_file_write_at_all_cv(fh, offset, msg, msglen)
32812 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
32813 CLASS(mp_file_type), INTENT(IN) :: fh
32814 INTEGER, INTENT(IN), OPTIONAL :: msglen
32815 INTEGER(kind=file_offset), INTENT(IN) :: offset
32816
32817 INTEGER :: msg_len
32818#if defined(__parallel)
32819 INTEGER :: ierr
32820#endif
32821
32822 msg_len = SIZE(msg)
32823 IF (PRESENT(msglen)) msg_len = msglen
32824#if defined(__parallel)
32825 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
32826 IF (ierr .NE. 0) &
32827 cpabort("mpi_file_write_at_all_cv @ mp_file_write_at_all_cv")
32828#else
32829 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
32830#endif
32831 END SUBROUTINE mp_file_write_at_all_cv
32832
32833! **************************************************************************************************
32834!> \brief ...
32835!> \param fh ...
32836!> \param offset ...
32837!> \param msg ...
32838! **************************************************************************************************
32839 SUBROUTINE mp_file_write_at_all_c (fh, offset, msg)
32840 COMPLEX(kind=real_4), INTENT(IN) :: msg
32841 CLASS(mp_file_type), INTENT(IN) :: fh
32842 INTEGER(kind=file_offset), INTENT(IN) :: offset
32843
32844#if defined(__parallel)
32845 INTEGER :: ierr
32846
32847 ierr = 0
32848 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
32849 IF (ierr .NE. 0) &
32850 cpabort("mpi_file_write_at_all_c @ mp_file_write_at_all_c")
32851#else
32852 WRITE (unit=fh%handle, pos=offset + 1) msg
32853#endif
32854 END SUBROUTINE mp_file_write_at_all_c
32855
32856! **************************************************************************************************
32857!> \brief (parallel) Blocking individual file read using explicit offsets
32858!> (serial) Unformatted stream read
32859!> \param[in] fh file handle (file storage unit)
32860!> \param[in] offset file offset (position)
32861!> \param[out] msg data to be read from the file
32862!> \param msglen ...
32863!> \par MPI-I/O mapping mpi_file_read_at
32864!> \par STREAM-I/O mapping READ
32865!> \param[in](optional) msglen number of elements of data
32866! **************************************************************************************************
32867 SUBROUTINE mp_file_read_at_cv(fh, offset, msg, msglen)
32868 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
32869 CLASS(mp_file_type), INTENT(IN) :: fh
32870 INTEGER, INTENT(IN), OPTIONAL :: msglen
32871 INTEGER(kind=file_offset), INTENT(IN) :: offset
32872
32873 INTEGER :: msg_len
32874#if defined(__parallel)
32875 INTEGER :: ierr
32876#endif
32877
32878 msg_len = SIZE(msg)
32879 IF (PRESENT(msglen)) msg_len = msglen
32880#if defined(__parallel)
32881 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
32882 IF (ierr .NE. 0) &
32883 cpabort("mpi_file_read_at_cv @ mp_file_read_at_cv")
32884#else
32885 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
32886#endif
32887 END SUBROUTINE mp_file_read_at_cv
32888
32889! **************************************************************************************************
32890!> \brief ...
32891!> \param fh ...
32892!> \param offset ...
32893!> \param msg ...
32894! **************************************************************************************************
32895 SUBROUTINE mp_file_read_at_c (fh, offset, msg)
32896 COMPLEX(kind=real_4), INTENT(OUT) :: msg
32897 CLASS(mp_file_type), INTENT(IN) :: fh
32898 INTEGER(kind=file_offset), INTENT(IN) :: offset
32899
32900#if defined(__parallel)
32901 INTEGER :: ierr
32902
32903 ierr = 0
32904 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
32905 IF (ierr .NE. 0) &
32906 cpabort("mpi_file_read_at_c @ mp_file_read_at_c")
32907#else
32908 READ (unit=fh%handle, pos=offset + 1) msg
32909#endif
32910 END SUBROUTINE mp_file_read_at_c
32911
32912! **************************************************************************************************
32913!> \brief (parallel) Blocking collective file read using explicit offsets
32914!> (serial) Unformatted stream read
32915!> \param fh ...
32916!> \param offset ...
32917!> \param msg ...
32918!> \param msglen ...
32919!> \par MPI-I/O mapping mpi_file_read_at_all
32920!> \par STREAM-I/O mapping READ
32921! **************************************************************************************************
32922 SUBROUTINE mp_file_read_at_all_cv(fh, offset, msg, msglen)
32923 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
32924 CLASS(mp_file_type), INTENT(IN) :: fh
32925 INTEGER, INTENT(IN), OPTIONAL :: msglen
32926 INTEGER(kind=file_offset), INTENT(IN) :: offset
32927
32928 INTEGER :: msg_len
32929#if defined(__parallel)
32930 INTEGER :: ierr
32931#endif
32932
32933 msg_len = SIZE(msg)
32934 IF (PRESENT(msglen)) msg_len = msglen
32935#if defined(__parallel)
32936 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
32937 IF (ierr .NE. 0) &
32938 cpabort("mpi_file_read_at_all_cv @ mp_file_read_at_all_cv")
32939#else
32940 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
32941#endif
32942 END SUBROUTINE mp_file_read_at_all_cv
32943
32944! **************************************************************************************************
32945!> \brief ...
32946!> \param fh ...
32947!> \param offset ...
32948!> \param msg ...
32949! **************************************************************************************************
32950 SUBROUTINE mp_file_read_at_all_c (fh, offset, msg)
32951 COMPLEX(kind=real_4), INTENT(OUT) :: msg
32952 CLASS(mp_file_type), INTENT(IN) :: fh
32953 INTEGER(kind=file_offset), INTENT(IN) :: offset
32954
32955#if defined(__parallel)
32956 INTEGER :: ierr
32957
32958 ierr = 0
32959 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
32960 IF (ierr .NE. 0) &
32961 cpabort("mpi_file_read_at_all_c @ mp_file_read_at_all_c")
32962#else
32963 READ (unit=fh%handle, pos=offset + 1) msg
32964#endif
32965 END SUBROUTINE mp_file_read_at_all_c
32966
32967! **************************************************************************************************
32968!> \brief ...
32969!> \param ptr ...
32970!> \param vector_descriptor ...
32971!> \param index_descriptor ...
32972!> \return ...
32973! **************************************************************************************************
32974 FUNCTION mp_type_make_c (ptr, &
32975 vector_descriptor, index_descriptor) &
32976 result(type_descriptor)
32977 COMPLEX(kind=real_4), DIMENSION(:), TARGET, asynchronous :: ptr
32978 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
32979 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
32980 TYPE(mp_type_descriptor_type) :: type_descriptor
32981
32982 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_c'
32983
32984#if defined(__parallel)
32985 INTEGER :: ierr
32986#if defined(__MPI_F08)
32987 ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
32988 EXTERNAL :: mpi_get_address
32989#endif
32990#endif
32991
32992 NULLIFY (type_descriptor%subtype)
32993 type_descriptor%length = SIZE(ptr)
32994#if defined(__parallel)
32995 type_descriptor%type_handle = mpi_complex
32996 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
32997 IF (ierr /= 0) &
32998 cpabort("MPI_Get_address @ "//routinen)
32999#else
33000 type_descriptor%type_handle = 5
33001#endif
33002 type_descriptor%vector_descriptor(1:2) = 1
33003 type_descriptor%has_indexing = .false.
33004 type_descriptor%data_c => ptr
33005 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
33006 cpabort(routinen//": Vectors and indices NYI")
33007 END IF
33008 END FUNCTION mp_type_make_c
33009
33010! **************************************************************************************************
33011!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
33012!> as the Fortran version returns an integer, which we take to be a C_PTR
33013!> \param DATA data array to allocate
33014!> \param[in] len length (in data elements) of data array allocation
33015!> \param[out] stat (optional) allocation status result
33016! **************************************************************************************************
33017 SUBROUTINE mp_alloc_mem_c (DATA, len, stat)
33018 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: data
33019 INTEGER, INTENT(IN) :: len
33020 INTEGER, INTENT(OUT), OPTIONAL :: stat
33021
33022#if defined(__parallel)
33023 INTEGER :: size, ierr, length, &
33024 mp_res
33025 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
33026 TYPE(c_ptr) :: mp_baseptr
33027 mpi_info_type :: mp_info
33028
33029 length = max(len, 1)
33030 CALL mpi_type_size(mpi_complex, size, ierr)
33031 mp_size = int(length, kind=mpi_address_kind)*size
33032 IF (mp_size .GT. mp_max_memory_size) THEN
33033 cpabort("MPI cannot allocate more than 2 GiByte")
33034 END IF
33035 mp_info = mpi_info_null
33036 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
33037 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
33038 IF (PRESENT(stat)) stat = mp_res
33039#else
33040 INTEGER :: length, mystat
33041 length = max(len, 1)
33042 IF (PRESENT(stat)) THEN
33043 ALLOCATE (DATA(length), stat=mystat)
33044 stat = mystat ! show to convention checker that stat is used
33045 ELSE
33046 ALLOCATE (DATA(length))
33047 END IF
33048#endif
33049 END SUBROUTINE mp_alloc_mem_c
33050
33051! **************************************************************************************************
33052!> \brief Deallocates am array, ... this is hackish
33053!> as the Fortran version takes an integer, which we hope to get by reference
33054!> \param DATA data array to allocate
33055!> \param[out] stat (optional) allocation status result
33056! **************************************************************************************************
33057 SUBROUTINE mp_free_mem_c (DATA, stat)
33058 COMPLEX(kind=real_4), DIMENSION(:), &
33059 POINTER, asynchronous :: data
33060 INTEGER, INTENT(OUT), OPTIONAL :: stat
33061
33062#if defined(__parallel)
33063 INTEGER :: mp_res
33064 CALL mpi_free_mem(DATA, mp_res)
33065 IF (PRESENT(stat)) stat = mp_res
33066#else
33067 DEALLOCATE (data)
33068 IF (PRESENT(stat)) stat = 0
33069#endif
33070 END SUBROUTINE mp_free_mem_c
33071
33072 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:120
message_passing::mp_allocate
Definition message_passing.F:856
message_passing::mp_deallocate
Definition message_passing.F:865
message_passing::mp_testall
Definition message_passing.F:840
message_passing::mp_testany
Definition message_passing.F:844
message_passing::mp_type_make
Definition message_passing.F:874
message_passing::mp_waitall
Definition message_passing.F:836
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:777
message_passing::mp_comm_unequal
integer, parameter, public mp_comm_unequal
Definition message_passing.F:795
message_passing::mp_collect_timings
logical, save, public mp_collect_timings
Definition message_passing.F:935
message_passing::mp_dims_create
subroutine, public mp_dims_create(nodes, dims)
wrapper to MPI_Dims_create
Definition message_passing.F:2102
message_passing::mp_para_env_create
subroutine, public mp_para_env_create(para_env, group)
creates a new para environment
Definition message_passing.F:1975
message_passing::intlen
integer, parameter intlen
Definition message_passing.F:930
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:4239
message_passing::mp_world_init
subroutine, public mp_world_init(mp_comm)
initializes the system default communicator
Definition message_passing.F:1244
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:2013
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:4428
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:792
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:27931
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:1382
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:23220
message_passing::mp_comm_world
type(mp_comm_type), parameter, public mp_comm_world
Definition message_passing.F:779
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:1997
message_passing::mp_comm_self
type(mp_comm_type), parameter, public mp_comm_self
Definition message_passing.F:778
message_passing::mp_comm_congruent
integer, parameter, public mp_comm_congruent
Definition message_passing.F:793
message_passing::mp_para_cart_release
subroutine, public mp_para_cart_release(cart)
releases the given cart
Definition message_passing.F:2030
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:18509
message_passing::mp_comm_compare_default
integer, parameter, public mp_comm_compare_default
Definition message_passing.F:796
message_passing::mp_world_finalize
subroutine, public mp_world_finalize()
finalizes the system default communicator
Definition message_passing.F:1345
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:3739
message_passing::mp_comm_similar
integer, parameter, public mp_comm_similar
Definition message_passing.F:794
message_passing::mp_file_null
type(mp_file_type), parameter, public mp_file_null
Definition message_passing.F:782
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:32642
message_passing::mp_info_null
type(mp_info_type), parameter, public mp_info_null
Definition message_passing.F:783
message_passing::mp_win_null
type(mp_win_type), parameter, public mp_win_null
Definition message_passing.F:781
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:3648
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:4474
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:2285
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:780
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:4282
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:4085
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:706
message_passing::mp_comm_type
Definition message_passing.F:155
message_passing::mp_file_descriptor_type
Definition message_passing.F:922
message_passing::mp_file_type
Definition message_passing.F:635
message_passing::mp_info_type
Definition message_passing.F:694
message_passing::mp_para_cart_type
represent a multidimensional parallel environment
Definition message_passing.F:766
message_passing::mp_para_env_p_type
represent a pointer to a para env (to build arrays)
Definition message_passing.F:746
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:729
message_passing::mp_request_type
Definition message_passing.F:589
message_passing::mp_type_descriptor_type
Definition message_passing.F:898
message_passing::mp_win_type
Definition message_passing.F:605