(git:f56c6e3)
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-2025 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, &
25 c_ptr
26 USE kinds, ONLY: &
27 dp, int_4, int_4_size, int_8, int_8_size, real_4, real_4_size, real_8, &
28 real_8_size, default_string_length
29 USE machine, ONLY: m_abort
30 USE mp_perf_env, ONLY: add_perf, &
31 add_mp_perf_env, rm_mp_perf_env
32
33#include "../base/base_uses.f90"
34
35! To simplify the transition between the old MPI module and the F08-style module, we introduce these constants to switch between the required handle types
36! Unfortunately, Fortran does not offer something like typedef in C++
37#if defined(__parallel) && defined(__MPI_F08)
38#define MPI_DATA_TYPE TYPE(MPI_Datatype)
39#define MPI_COMM_TYPE TYPE(MPI_Comm)
40#define MPI_REQUEST_TYPE TYPE(MPI_Request)
41#define MPI_WIN_TYPE TYPE(MPI_Win)
42#define MPI_FILE_TYPE TYPE(MPI_File)
43#define MPI_INFO_TYPE TYPE(MPI_Info)
44#define MPI_STATUS_TYPE TYPE(MPI_Status)
45#define MPI_GROUP_TYPE TYPE(MPI_Group)
46#define MPI_STATUS_EXTRACT(X) %X
47#define MPI_GET_COMP %mpi_val
48#else
49#define MPI_DATA_TYPE INTEGER
50#define MPI_COMM_TYPE INTEGER
51#define MPI_REQUEST_TYPE INTEGER
52#define MPI_WIN_TYPE INTEGER
53#define MPI_FILE_TYPE INTEGER
54#define MPI_INFO_TYPE INTEGER
55#define MPI_STATUS_TYPE INTEGER, DIMENSION(MPI_STATUS_SIZE)
56#define MPI_GROUP_TYPE INTEGER
57#define MPI_STATUS_EXTRACT(X) (X)
58#define MPI_GET_COMP
59#endif
60
61#if defined(__parallel)
62#if defined(__MPI_F08)
63 USE mpi_f08, ONLY: mpi_allgather, mpi_allgatherv, mpi_alloc_mem, mpi_allreduce, mpi_alltoall, mpi_alltoallv, mpi_bcast, &
64 mpi_cart_coords, mpi_cart_create, mpi_cart_get, mpi_cart_rank, mpi_cart_sub, mpi_dims_create, mpi_file_close, &
65 mpi_file_get_size, mpi_file_open, mpi_file_read_at_all, mpi_file_read_at, mpi_file_write_at_all, &
66 mpi_file_write_at, mpi_free_mem, mpi_gather, mpi_gatherv, mpi_get_address, mpi_group_translate_ranks, mpi_irecv, &
67 mpi_isend, mpi_recv, mpi_reduce, mpi_reduce_scatter, mpi_rget, mpi_scatter, mpi_send, &
68 mpi_sendrecv, mpi_sendrecv_replace, mpi_testany, mpi_waitall, mpi_waitany, mpi_win_create, mpi_comm_get_attr, &
69 mpi_ibcast, mpi_any_tag, mpi_any_source, mpi_address_kind, mpi_thread_serialized, mpi_errors_return, mpi_comm_world, &
70#if defined(__dlaf)
71 mpi_thread_multiple, &
72#endif
73 mpi_comm_self, mpi_comm_null, mpi_info_null, mpi_request_null, mpi_request, mpi_comm, mpi_group, &
74 mpi_status_ignore, mpi_info, mpi_file, mpi_success, &
75 mpi_tag_ub, mpi_host, mpi_io, mpi_wtime_is_global, mpi_logical, &
76 mpi_status, mpi_lor, mpi_2real, mpi_real, mpi_maxloc, mpi_integer8, mpi_bottom, &
77 mpi_iscatter, mpi_iscatterv, mpi_gatherv, mpi_igatherv, mpi_iallgather, &
78 mpi_iallgatherv, mpi_status, mpi_comm_type_shared, mpi_integer, mpi_minloc, mpi_2double_precision, &
79 mpi_file, mpi_minloc, mpi_integer, mpi_sum, mpi_scan, &
80 mpi_2integer, mpi_in_place, mpi_max, mpi_min, mpi_prod, mpi_iallreduce, mpi_double_precision, &
81 mpi_error_string, mpi_double_complex, mpi_complex, mpi_type_size, mpi_file_write_all, &
82 mpi_max_error_string, mpi_datatype, mpi_offset_kind, mpi_win, mpi_mode_rdonly, mpi_mode_rdwr, &
83 mpi_mode_wronly, mpi_mode_create, mpi_mode_append, mpi_mode_excl, mpi_max_library_version_string, &
84 mpi_win_null, mpi_file_null, mpi_datatype_null, mpi_character, mpi_mode_nocheck, &
85 mpi_status_size, mpi_proc_null, mpi_unequal, mpi_similar, mpi_ident, mpi_congruent
86#else
87 USE mpi
88#endif
89! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines (problems with types and ranks explosion),
90! we do not quite know what is in the module, so we can not include any....
91! to nevertheless get checking for what is included, we use the mpi module without use clause, getting all there is
92! USE mpi, ONLY: mpi_allgather, mpi_allgatherv, mpi_alloc_mem, mpi_allreduce, mpi_alltoall, mpi_alltoallv, mpi_bcast,&
93! mpi_cart_coords, mpi_cart_create, mpi_cart_get, mpi_cart_rank, mpi_cart_sub, mpi_dims_create, mpi_file_close,&
94! mpi_file_get_size, mpi_file_open, mpi_file_read_at_all, mpi_file_read_at, mpi_file_write_at_all,&
95! mpi_file_write_at, mpi_free_mem, mpi_gather, mpi_gatherv, mpi_get_address, mpi_group_translate_ranks, mpi_irecv,&
96! mpi_isend, mpi_recv, mpi_reduce, mpi_reduce_scatter, mpi_rget, mpi_scatter, mpi_send,&
97! mpi_sendrecv, mpi_sendrecv_replace, mpi_testany, mpi_waitall, mpi_waitany, mpi_win_create
98! functions
99! USE mpi, ONLY: mpi_wtime
100! constants
101! USE mpi, ONLY: MPI_DOUBLE_PRECISION, MPI_DOUBLE_COMPLEX, MPI_REAL, MPI_COMPLEX, MPI_ANY_TAG,&
102! MPI_ANY_SOURCE, MPI_COMM_NULL, MPI_REQUEST_NULL, MPI_WIN_NULL, MPI_STATUS_SIZE, MPI_STATUS_IGNORE, MPI_STATUSES_IGNORE, &
103! MPI_ADDRESS_KIND, MPI_OFFSET_KIND, MPI_MODE_CREATE, MPI_MODE_RDONLY, MPI_MODE_WRONLY,&
104! MPI_MODE_RDWR, MPI_MODE_EXCL, MPI_COMM_SELF, MPI_COMM_WORLD, MPI_THREAD_SERIALIZED,&
105! MPI_ERRORS_RETURN, MPI_SUCCESS, MPI_MAX_PROCESSOR_NAME, MPI_MAX_ERROR_STRING, MPI_IDENT,&
106! MPI_UNEQUAL, MPI_MAX, MPI_SUM, MPI_INFO_NULL, MPI_IN_PLACE, MPI_CONGRUENT, MPI_SIMILAR, MPI_MIN, MPI_SOURCE,&
107! MPI_TAG, MPI_INTEGER8, MPI_INTEGER, MPI_MAXLOC, MPI_2INTEGER, MPI_MINLOC, MPI_LOGICAL, MPI_2DOUBLE_PRECISION,&
108! MPI_LOR, MPI_CHARACTER, MPI_BOTTOM, MPI_MODE_NOCHECK, MPI_2REAL
109#endif
110
111 IMPLICIT NONE
112 PRIVATE
113
114 ! parameters that might be needed
115#if defined(__parallel)
116 LOGICAL, PARAMETER :: cp2k_is_parallel = .true.
117 INTEGER, PARAMETER, PUBLIC :: mp_any_tag = mpi_any_tag
118 INTEGER, PARAMETER, PUBLIC :: mp_any_source = mpi_any_source
119 mpi_comm_type, PARAMETER :: mp_comm_null_handle = mpi_comm_null
120 mpi_comm_type, PARAMETER :: mp_comm_self_handle = mpi_comm_self
121 mpi_comm_type, PARAMETER :: mp_comm_world_handle = mpi_comm_world
122 mpi_request_type, PARAMETER :: mp_request_null_handle = mpi_request_null
123 mpi_win_type, PARAMETER :: mp_win_null_handle = mpi_win_null
124 mpi_file_type, PARAMETER :: mp_file_null_handle = mpi_file_null
125 mpi_info_type, PARAMETER :: mp_info_null_handle = mpi_info_null
126 mpi_data_type, PARAMETER :: mp_datatype_null_handle = mpi_datatype_null
127 INTEGER, PARAMETER, PUBLIC :: mp_status_size = mpi_status_size
128 INTEGER, PARAMETER, PUBLIC :: mp_proc_null = mpi_proc_null
129 ! Set max allocatable memory by MPI to 2 GiByte
130 INTEGER(KIND=MPI_ADDRESS_KIND), PARAMETER, PRIVATE :: mp_max_memory_size = huge(int(1, kind=int_4))
131
132 INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = mpi_max_library_version_string
133
134 INTEGER, PARAMETER, PUBLIC :: file_offset = mpi_offset_kind
135 INTEGER, PARAMETER, PUBLIC :: address_kind = mpi_address_kind
136 INTEGER, PARAMETER, PUBLIC :: file_amode_create = mpi_mode_create
137 INTEGER, PARAMETER, PUBLIC :: file_amode_rdonly = mpi_mode_rdonly
138 INTEGER, PARAMETER, PUBLIC :: file_amode_wronly = mpi_mode_wronly
139 INTEGER, PARAMETER, PUBLIC :: file_amode_rdwr = mpi_mode_rdwr
140 INTEGER, PARAMETER, PUBLIC :: file_amode_excl = mpi_mode_excl
141 INTEGER, PARAMETER, PUBLIC :: file_amode_append = mpi_mode_append
142#else
143 LOGICAL, PARAMETER :: cp2k_is_parallel = .false.
144 INTEGER, PARAMETER, PUBLIC :: mp_any_tag = -1
145 INTEGER, PARAMETER, PUBLIC :: mp_any_source = -2
146 mpi_comm_type, PARAMETER :: mp_comm_null_handle = -3
147 mpi_comm_type, PARAMETER :: mp_comm_self_handle = -11
148 mpi_comm_type, PARAMETER :: mp_comm_world_handle = -12
149 mpi_request_type, PARAMETER :: mp_request_null_handle = -4
150 mpi_win_type, PARAMETER :: mp_win_null_handle = -5
151 mpi_file_type, PARAMETER :: mp_file_null_handle = -6
152 mpi_info_type, PARAMETER :: mp_info_null_handle = -7
153 mpi_data_type, PARAMETER :: mp_datatype_null_handle = -8
154 INTEGER, PARAMETER, PUBLIC :: mp_status_size = -9
155 INTEGER, PARAMETER, PUBLIC :: mp_proc_null = -10
156 INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = 1
157
158 INTEGER, PARAMETER, PUBLIC :: file_offset = int_8
159 INTEGER, PARAMETER, PUBLIC :: address_kind = int_8
160 INTEGER, PARAMETER, PUBLIC :: file_amode_create = 1
161 INTEGER, PARAMETER, PUBLIC :: file_amode_rdonly = 2
162 INTEGER, PARAMETER, PUBLIC :: file_amode_wronly = 4
163 INTEGER, PARAMETER, PUBLIC :: file_amode_rdwr = 8
164 INTEGER, PARAMETER, PUBLIC :: file_amode_excl = 64
165 INTEGER, PARAMETER, PUBLIC :: file_amode_append = 128
166#endif
167
168 ! we need to fix this to a given number (crossing fingers)
169 ! so that the serial code using Fortran stream IO and the MPI have the same sizes.
170 INTEGER, PARAMETER, PUBLIC :: mpi_character_size = 1
171 INTEGER, PARAMETER, PUBLIC :: mpi_integer_size = 4
172
173 CHARACTER(LEN=*), PARAMETER, PRIVATE :: modulen = 'message_passing'
174
175 ! internal reference counter used to debug communicator leaks
176 INTEGER, PRIVATE, SAVE :: debug_comm_count
177
178 PUBLIC :: mp_comm_type
179 PUBLIC :: mp_request_type
180 PUBLIC :: mp_win_type
181 PUBLIC :: mp_file_type
182 PUBLIC :: mp_info_type
183 PUBLIC :: mp_cart_type
184
185 PUBLIC :: mp_para_env_type, mp_para_env_p_type, mp_para_cart_type
186 PUBLIC :: mp_para_env_create, mp_para_env_release, &
187 mp_para_cart_create, mp_para_cart_release
188
189 TYPE mp_comm_type
190 PRIVATE
191 mpi_comm_type :: handle = mp_comm_null_handle
192 ! Number of dimensions within a Cartesian topology (useful with mp_cart_type)
193 INTEGER :: ndims = 1
194 ! Meta data to the communicator
195 INTEGER, PUBLIC :: mepos = -1, source = -1, num_pe = -1
196 CONTAINS
197 ! Setters/Getters
198 PROCEDURE, pass, non_overridable :: set_handle => mp_comm_type_set_handle
199 PROCEDURE, pass, non_overridable :: get_handle => mp_comm_type_get_handle
200 ! Comparisons
201 PROCEDURE, PRIVATE, pass, non_overridable :: mp_comm_op_eq
202 PROCEDURE, PRIVATE, pass, non_overridable :: mp_comm_op_neq
203 generic, PUBLIC :: operator(==) => mp_comm_op_eq
204 generic, PUBLIC :: operator(/=) => mp_comm_op_neq
205 ! Communication routines
206 PROCEDURE, PRIVATE, pass(comm), non_overridable :: &
207 mp_sendrecv_i, mp_sendrecv_l, mp_sendrecv_r, mp_sendrecv_d, &
208 mp_sendrecv_c, mp_sendrecv_z, &
209 mp_sendrecv_iv, mp_sendrecv_im2, mp_sendrecv_im3, mp_sendrecv_im4, &
210 mp_sendrecv_lv, mp_sendrecv_lm2, mp_sendrecv_lm3, mp_sendrecv_lm4, &
211 mp_sendrecv_rv, mp_sendrecv_rm2, mp_sendrecv_rm3, mp_sendrecv_rm4, &
212 mp_sendrecv_dv, mp_sendrecv_dm2, mp_sendrecv_dm3, mp_sendrecv_dm4, &
213 mp_sendrecv_cv, mp_sendrecv_cm2, mp_sendrecv_cm3, mp_sendrecv_cm4, &
214 mp_sendrecv_zv, mp_sendrecv_zm2, mp_sendrecv_zm3, mp_sendrecv_zm4
215 generic, PUBLIC :: sendrecv => mp_sendrecv_i, mp_sendrecv_l, &
216 mp_sendrecv_r, mp_sendrecv_d, mp_sendrecv_c, mp_sendrecv_z, &
217 mp_sendrecv_iv, mp_sendrecv_im2, mp_sendrecv_im3, mp_sendrecv_im4, &
218 mp_sendrecv_lv, mp_sendrecv_lm2, mp_sendrecv_lm3, mp_sendrecv_lm4, &
219 mp_sendrecv_rv, mp_sendrecv_rm2, mp_sendrecv_rm3, mp_sendrecv_rm4, &
220 mp_sendrecv_dv, mp_sendrecv_dm2, mp_sendrecv_dm3, mp_sendrecv_dm4, &
221 mp_sendrecv_cv, mp_sendrecv_cm2, mp_sendrecv_cm3, mp_sendrecv_cm4, &
222 mp_sendrecv_zv, mp_sendrecv_zm2, mp_sendrecv_zm3, mp_sendrecv_zm4
223
224 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_minloc_iv, &
225 mp_minloc_lv, mp_minloc_rv, mp_minloc_dv
226 generic, PUBLIC :: minloc => mp_minloc_iv, &
227 mp_minloc_lv, mp_minloc_rv, mp_minloc_dv
228
229 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_maxloc_iv, &
230 mp_maxloc_lv, mp_maxloc_rv, mp_maxloc_dv
231 generic, PUBLIC :: maxloc => mp_maxloc_iv, &
232 mp_maxloc_lv, mp_maxloc_rv, mp_maxloc_dv
233
234 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_shift_im, mp_shift_i, &
235 mp_shift_lm, mp_shift_l, mp_shift_rm, mp_shift_r, &
236 mp_shift_dm, mp_shift_d, mp_shift_cm, mp_shift_c, &
237 mp_shift_zm, mp_shift_z
238 generic, PUBLIC :: shift => mp_shift_im, mp_shift_i, &
239 mp_shift_lm, mp_shift_l, mp_shift_rm, mp_shift_r, &
240 mp_shift_dm, mp_shift_d, mp_shift_cm, mp_shift_c, &
241 mp_shift_zm, mp_shift_z
242
243 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_bcast_i, mp_bcast_iv, mp_bcast_im, mp_bcast_i3, &
244 mp_bcast_l, mp_bcast_lv, mp_bcast_lm, mp_bcast_l3, &
245 mp_bcast_r, mp_bcast_rv, mp_bcast_rm, mp_bcast_r3, &
246 mp_bcast_d, mp_bcast_dv, mp_bcast_dm, mp_bcast_d3, &
247 mp_bcast_c, mp_bcast_cv, mp_bcast_cm, mp_bcast_c3, &
248 mp_bcast_z, mp_bcast_zv, mp_bcast_zm, mp_bcast_z3, &
249 mp_bcast_b, mp_bcast_bv, mp_bcast_av, mp_bcast_am, &
250 mp_bcast_i_src, mp_bcast_iv_src, mp_bcast_im_src, mp_bcast_i3_src, &
251 mp_bcast_l_src, mp_bcast_lv_src, mp_bcast_lm_src, mp_bcast_l3_src, &
252 mp_bcast_r_src, mp_bcast_rv_src, mp_bcast_rm_src, mp_bcast_r3_src, &
253 mp_bcast_d_src, mp_bcast_dv_src, mp_bcast_dm_src, mp_bcast_d3_src, &
254 mp_bcast_c_src, mp_bcast_cv_src, mp_bcast_cm_src, mp_bcast_c3_src, &
255 mp_bcast_z_src, mp_bcast_zv_src, mp_bcast_zm_src, mp_bcast_z3_src, &
256 mp_bcast_b_src, mp_bcast_bv_src, mp_bcast_av_src, mp_bcast_am_src
257 generic, PUBLIC :: bcast => mp_bcast_i, mp_bcast_iv, mp_bcast_im, mp_bcast_i3, &
258 mp_bcast_l, mp_bcast_lv, mp_bcast_lm, mp_bcast_l3, &
259 mp_bcast_r, mp_bcast_rv, mp_bcast_rm, mp_bcast_r3, &
260 mp_bcast_d, mp_bcast_dv, mp_bcast_dm, mp_bcast_d3, &
261 mp_bcast_c, mp_bcast_cv, mp_bcast_cm, mp_bcast_c3, &
262 mp_bcast_z, mp_bcast_zv, mp_bcast_zm, mp_bcast_z3, &
263 mp_bcast_b, mp_bcast_bv, mp_bcast_av, mp_bcast_am, &
264 mp_bcast_i_src, mp_bcast_iv_src, mp_bcast_im_src, mp_bcast_i3_src, &
265 mp_bcast_l_src, mp_bcast_lv_src, mp_bcast_lm_src, mp_bcast_l3_src, &
266 mp_bcast_r_src, mp_bcast_rv_src, mp_bcast_rm_src, mp_bcast_r3_src, &
267 mp_bcast_d_src, mp_bcast_dv_src, mp_bcast_dm_src, mp_bcast_d3_src, &
268 mp_bcast_c_src, mp_bcast_cv_src, mp_bcast_cm_src, mp_bcast_c3_src, &
269 mp_bcast_z_src, mp_bcast_zv_src, mp_bcast_zm_src, mp_bcast_z3_src, &
270 mp_bcast_b_src, mp_bcast_bv_src, mp_bcast_av_src, mp_bcast_am_src
271
272 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_ibcast_i, mp_ibcast_iv, &
273 mp_ibcast_l, mp_ibcast_lv, mp_ibcast_r, mp_ibcast_rv, &
274 mp_ibcast_d, mp_ibcast_dv, mp_ibcast_c, mp_ibcast_cv, &
275 mp_ibcast_z, mp_ibcast_zv
276 generic, PUBLIC :: ibcast => mp_ibcast_i, mp_ibcast_iv, &
277 mp_ibcast_l, mp_ibcast_lv, mp_ibcast_r, mp_ibcast_rv, &
278 mp_ibcast_d, mp_ibcast_dv, mp_ibcast_c, mp_ibcast_cv, &
279 mp_ibcast_z, mp_ibcast_zv
280
281 PROCEDURE, PRIVATE, pass(comm), non_overridable :: &
282 mp_sum_i, mp_sum_iv, mp_sum_im, mp_sum_im3, mp_sum_im4, &
283 mp_sum_l, mp_sum_lv, mp_sum_lm, mp_sum_lm3, mp_sum_lm4, &
284 mp_sum_r, mp_sum_rv, mp_sum_rm, mp_sum_rm3, mp_sum_rm4, &
285 mp_sum_d, mp_sum_dv, mp_sum_dm, mp_sum_dm3, mp_sum_dm4, &
286 mp_sum_c, mp_sum_cv, mp_sum_cm, mp_sum_cm3, mp_sum_cm4, &
287 mp_sum_z, mp_sum_zv, mp_sum_zm, mp_sum_zm3, mp_sum_zm4, &
288 mp_sum_root_iv, mp_sum_root_im, mp_sum_root_lv, mp_sum_root_lm, &
289 mp_sum_root_rv, mp_sum_root_rm, mp_sum_root_dv, mp_sum_root_dm, &
290 mp_sum_root_cv, mp_sum_root_cm, mp_sum_root_zv, mp_sum_root_zm, &
291 mp_sum_b, mp_sum_bv
292 generic, PUBLIC :: sum => mp_sum_i, mp_sum_iv, mp_sum_im, mp_sum_im3, mp_sum_im4, &
293 mp_sum_l, mp_sum_lv, mp_sum_lm, mp_sum_lm3, mp_sum_lm4, &
294 mp_sum_r, mp_sum_rv, mp_sum_rm, mp_sum_rm3, mp_sum_rm4, &
295 mp_sum_d, mp_sum_dv, mp_sum_dm, mp_sum_dm3, mp_sum_dm4, &
296 mp_sum_c, mp_sum_cv, mp_sum_cm, mp_sum_cm3, mp_sum_cm4, &
297 mp_sum_z, mp_sum_zv, mp_sum_zm, mp_sum_zm3, mp_sum_zm4, &
298 mp_sum_root_iv, mp_sum_root_im, mp_sum_root_lv, mp_sum_root_lm, &
299 mp_sum_root_rv, mp_sum_root_rm, mp_sum_root_dv, mp_sum_root_dm, &
300 mp_sum_root_cv, mp_sum_root_cm, mp_sum_root_zv, mp_sum_root_zm, &
301 mp_sum_b, mp_sum_bv
302
303 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_isum_iv, &
304 mp_isum_lv, mp_isum_rv, mp_isum_dv, mp_isum_cv, &
305 mp_isum_zv, mp_isum_bv
306 generic, PUBLIC :: isum => mp_isum_iv, &
307 mp_isum_lv, mp_isum_rv, mp_isum_dv, mp_isum_cv, &
308 mp_isum_zv, mp_isum_bv
309
310 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_sum_partial_im, &
311 mp_sum_partial_lm, mp_sum_partial_rm, mp_sum_partial_dm, &
312 mp_sum_partial_cm, mp_sum_partial_zm
313 generic, PUBLIC :: sum_partial => mp_sum_partial_im, &
314 mp_sum_partial_lm, mp_sum_partial_rm, mp_sum_partial_dm, &
315 mp_sum_partial_cm, mp_sum_partial_zm
316
317 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_max_i, mp_max_iv, &
318 mp_max_l, mp_max_lv, mp_max_r, mp_max_rv, &
319 mp_max_d, mp_max_dv, mp_max_c, mp_max_cv, &
320 mp_max_z, mp_max_zv, mp_max_root_i, mp_max_root_l, &
321 mp_max_root_r, mp_max_root_d, mp_max_root_c, mp_max_root_z, &
322 mp_max_root_im, mp_max_root_lm, mp_max_root_rm, mp_max_root_dm, &
323 mp_max_root_cm, mp_max_root_zm
324 generic, PUBLIC :: max => mp_max_i, mp_max_iv, &
325 mp_max_l, mp_max_lv, mp_max_r, mp_max_rv, &
326 mp_max_d, mp_max_dv, mp_max_c, mp_max_cv, &
327 mp_max_z, mp_max_zv, mp_max_root_i, mp_max_root_l, &
328 mp_max_root_r, mp_max_root_d, mp_max_root_c, mp_max_root_z, &
329 mp_max_root_im, mp_max_root_lm, mp_max_root_rm, mp_max_root_dm, &
330 mp_max_root_cm, mp_max_root_zm
331
332 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_min_i, mp_min_iv, &
333 mp_min_l, mp_min_lv, mp_min_r, mp_min_rv, &
334 mp_min_d, mp_min_dv, mp_min_c, mp_min_cv, &
335 mp_min_z, mp_min_zv
336 generic, PUBLIC :: min => mp_min_i, mp_min_iv, &
337 mp_min_l, mp_min_lv, mp_min_r, mp_min_rv, &
338 mp_min_d, mp_min_dv, mp_min_c, mp_min_cv, &
339 mp_min_z, mp_min_zv
340
341 PROCEDURE, PUBLIC, pass(comm), non_overridable :: &
342 mp_sum_scatter_iv, mp_sum_scatter_lv, mp_sum_scatter_rv, &
343 mp_sum_scatter_dv, mp_sum_scatter_cv, mp_sum_scatter_zv
344 generic, PUBLIC :: sum_scatter => &
345 mp_sum_scatter_iv, mp_sum_scatter_lv, mp_sum_scatter_rv, &
346 mp_sum_scatter_dv, mp_sum_scatter_cv, mp_sum_scatter_zv
347
348 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
349 generic, PUBLIC :: prod => mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
350
351 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_gather_i, mp_gather_iv, mp_gather_im, &
352 mp_gather_l, mp_gather_lv, mp_gather_lm, &
353 mp_gather_r, mp_gather_rv, mp_gather_rm, &
354 mp_gather_d, mp_gather_dv, mp_gather_dm, &
355 mp_gather_c, mp_gather_cv, mp_gather_cm, &
356 mp_gather_z, mp_gather_zv, mp_gather_zm, &
357 mp_gather_i_src, mp_gather_iv_src, mp_gather_im_src, &
358 mp_gather_l_src, mp_gather_lv_src, mp_gather_lm_src, &
359 mp_gather_r_src, mp_gather_rv_src, mp_gather_rm_src, &
360 mp_gather_d_src, mp_gather_dv_src, mp_gather_dm_src, &
361 mp_gather_c_src, mp_gather_cv_src, mp_gather_cm_src, &
362 mp_gather_z_src, mp_gather_zv_src, mp_gather_zm_src
363 generic, PUBLIC :: gather => mp_gather_i, mp_gather_iv, mp_gather_im, &
364 mp_gather_l, mp_gather_lv, mp_gather_lm, &
365 mp_gather_r, mp_gather_rv, mp_gather_rm, &
366 mp_gather_d, mp_gather_dv, mp_gather_dm, &
367 mp_gather_c, mp_gather_cv, mp_gather_cm, &
368 mp_gather_z, mp_gather_zv, mp_gather_zm, &
369 mp_gather_i_src, mp_gather_iv_src, mp_gather_im_src, &
370 mp_gather_l_src, mp_gather_lv_src, mp_gather_lm_src, &
371 mp_gather_r_src, mp_gather_rv_src, mp_gather_rm_src, &
372 mp_gather_d_src, mp_gather_dv_src, mp_gather_dm_src, &
373 mp_gather_c_src, mp_gather_cv_src, mp_gather_cm_src, &
374 mp_gather_z_src, mp_gather_zv_src, mp_gather_zm_src
375
376 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_gatherv_iv, &
377 mp_gatherv_lv, mp_gatherv_rv, mp_gatherv_dv, &
378 mp_gatherv_cv, mp_gatherv_zv, mp_gatherv_lm2, mp_gatherv_rm2, &
379 mp_gatherv_dm2, mp_gatherv_cm2, mp_gatherv_zm2, mp_gatherv_iv_src, &
380 mp_gatherv_lv_src, mp_gatherv_rv_src, mp_gatherv_dv_src, &
381 mp_gatherv_cv_src, mp_gatherv_zv_src, mp_gatherv_lm2_src, mp_gatherv_rm2_src, &
382 mp_gatherv_dm2_src, mp_gatherv_cm2_src, mp_gatherv_zm2_src
383 generic, PUBLIC :: gatherv => mp_gatherv_iv, &
384 mp_gatherv_lv, mp_gatherv_rv, mp_gatherv_dv, &
385 mp_gatherv_cv, mp_gatherv_zv, mp_gatherv_lm2, mp_gatherv_rm2, &
386 mp_gatherv_dm2, mp_gatherv_cm2, mp_gatherv_zm2, mp_gatherv_iv_src, &
387 mp_gatherv_lv_src, mp_gatherv_rv_src, mp_gatherv_dv_src, &
388 mp_gatherv_cv_src, mp_gatherv_zv_src, mp_gatherv_lm2_src, mp_gatherv_rm2_src, &
389 mp_gatherv_dm2_src, mp_gatherv_cm2_src, mp_gatherv_zm2_src
390
391 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_igatherv_iv, &
392 mp_igatherv_lv, mp_igatherv_rv, mp_igatherv_dv, &
393 mp_igatherv_cv, mp_igatherv_zv
394 generic, PUBLIC :: igatherv => mp_igatherv_iv, &
395 mp_igatherv_lv, mp_igatherv_rv, mp_igatherv_dv, &
396 mp_igatherv_cv, mp_igatherv_zv
397
398 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_allgather_i, mp_allgather_i2, &
399 mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
400 mp_allgather_i22, mp_allgather_l, mp_allgather_l2, &
401 mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
402 mp_allgather_l22, mp_allgather_r, mp_allgather_r2, &
403 mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
404 mp_allgather_r22, mp_allgather_d, mp_allgather_d2, &
405 mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
406 mp_allgather_d22, mp_allgather_c, mp_allgather_c2, &
407 mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
408 mp_allgather_c22, mp_allgather_z, mp_allgather_z2, &
409 mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
410 mp_allgather_z22
411 generic, PUBLIC :: allgather => mp_allgather_i, mp_allgather_i2, &
412 mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
413 mp_allgather_i22, mp_allgather_l, mp_allgather_l2, &
414 mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
415 mp_allgather_l22, mp_allgather_r, mp_allgather_r2, &
416 mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
417 mp_allgather_r22, mp_allgather_d, mp_allgather_d2, &
418 mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
419 mp_allgather_d22, mp_allgather_c, mp_allgather_c2, &
420 mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
421 mp_allgather_c22, mp_allgather_z, mp_allgather_z2, &
422 mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
423 mp_allgather_z22
424
425 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_allgatherv_iv, mp_allgatherv_lv, &
426 mp_allgatherv_rv, mp_allgatherv_dv, mp_allgatherv_cv, mp_allgatherv_zv, &
427 mp_allgatherv_im2, mp_allgatherv_lm2, mp_allgatherv_rm2, &
428 mp_allgatherv_dm2, mp_allgatherv_cm2, mp_allgatherv_zm2
429 generic, PUBLIC :: allgatherv => mp_allgatherv_iv, mp_allgatherv_lv, &
430 mp_allgatherv_rv, mp_allgatherv_dv, mp_allgatherv_cv, mp_allgatherv_zv, &
431 mp_allgatherv_im2, mp_allgatherv_lm2, mp_allgatherv_rm2, &
432 mp_allgatherv_dm2, mp_allgatherv_cm2, mp_allgatherv_zm2
433
434 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iallgather_i, mp_iallgather_l, &
435 mp_iallgather_r, mp_iallgather_d, mp_iallgather_c, mp_iallgather_z, &
436 mp_iallgather_i11, mp_iallgather_l11, mp_iallgather_r11, mp_iallgather_d11, &
437 mp_iallgather_c11, mp_iallgather_z11, mp_iallgather_i13, mp_iallgather_l13, &
438 mp_iallgather_r13, mp_iallgather_d13, mp_iallgather_c13, mp_iallgather_z13, &
439 mp_iallgather_i22, mp_iallgather_l22, mp_iallgather_r22, mp_iallgather_d22, &
440 mp_iallgather_c22, mp_iallgather_z22, mp_iallgather_i24, mp_iallgather_l24, &
441 mp_iallgather_r24, mp_iallgather_d24, mp_iallgather_c24, mp_iallgather_z24, &
442 mp_iallgather_i33, mp_iallgather_l33, mp_iallgather_r33, mp_iallgather_d33, &
443 mp_iallgather_c33, mp_iallgather_z33
444 generic, PUBLIC :: iallgather => mp_iallgather_i, mp_iallgather_l, &
445 mp_iallgather_r, mp_iallgather_d, mp_iallgather_c, mp_iallgather_z, &
446 mp_iallgather_i11, mp_iallgather_l11, mp_iallgather_r11, mp_iallgather_d11, &
447 mp_iallgather_c11, mp_iallgather_z11, mp_iallgather_i13, mp_iallgather_l13, &
448 mp_iallgather_r13, mp_iallgather_d13, mp_iallgather_c13, mp_iallgather_z13, &
449 mp_iallgather_i22, mp_iallgather_l22, mp_iallgather_r22, mp_iallgather_d22, &
450 mp_iallgather_c22, mp_iallgather_z22, mp_iallgather_i24, mp_iallgather_l24, &
451 mp_iallgather_r24, mp_iallgather_d24, mp_iallgather_c24, mp_iallgather_z24, &
452 mp_iallgather_i33, mp_iallgather_l33, mp_iallgather_r33, mp_iallgather_d33, &
453 mp_iallgather_c33, mp_iallgather_z33
454
455 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iallgatherv_iv, mp_iallgatherv_iv2, &
456 mp_iallgatherv_lv, mp_iallgatherv_lv2, mp_iallgatherv_rv, mp_iallgatherv_rv2, &
457 mp_iallgatherv_dv, mp_iallgatherv_dv2, mp_iallgatherv_cv, mp_iallgatherv_cv2, &
458 mp_iallgatherv_zv, mp_iallgatherv_zv2
459 generic, PUBLIC :: iallgatherv => mp_iallgatherv_iv, mp_iallgatherv_iv2, &
460 mp_iallgatherv_lv, mp_iallgatherv_lv2, mp_iallgatherv_rv, mp_iallgatherv_rv2, &
461 mp_iallgatherv_dv, mp_iallgatherv_dv2, mp_iallgatherv_cv, mp_iallgatherv_cv2, &
462 mp_iallgatherv_zv, mp_iallgatherv_zv2
463
464 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_scatter_iv, mp_scatter_lv, &
465 mp_scatter_rv, mp_scatter_dv, mp_scatter_cv, mp_scatter_zv
466 generic, PUBLIC :: scatter => mp_scatter_iv, mp_scatter_lv, &
467 mp_scatter_rv, mp_scatter_dv, mp_scatter_cv, mp_scatter_zv
468
469 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iscatter_i, mp_iscatter_l, &
470 mp_iscatter_r, mp_iscatter_d, mp_iscatter_c, mp_iscatter_z, &
471 mp_iscatter_iv2, mp_iscatter_lv2, mp_iscatter_rv2, mp_iscatter_dv2, &
472 mp_iscatter_cv2, mp_iscatter_zv2
473 generic, PUBLIC :: iscatter => mp_iscatter_i, mp_iscatter_l, &
474 mp_iscatter_r, mp_iscatter_d, mp_iscatter_c, mp_iscatter_z, &
475 mp_iscatter_iv2, mp_iscatter_lv2, mp_iscatter_rv2, mp_iscatter_dv2, &
476 mp_iscatter_cv2, mp_iscatter_zv2
477
478 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_iscatterv_iv, mp_iscatterv_lv, &
479 mp_iscatterv_rv, mp_iscatterv_dv, mp_iscatterv_cv, mp_iscatterv_zv
480 generic, PUBLIC :: iscatterv => mp_iscatterv_iv, mp_iscatterv_lv, &
481 mp_iscatterv_rv, mp_iscatterv_dv, mp_iscatterv_cv, mp_iscatterv_zv
482
483 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
484 mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
485 mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
486 mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
487 mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
488 mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
489 mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
490 mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
491 mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
492 mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
493 mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
494 mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
495 mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
496 mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
497 mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
498 mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
499 mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
500 mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
501 generic, PUBLIC :: alltoall => mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
502 mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
503 mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
504 mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
505 mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
506 mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
507 mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
508 mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
509 mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
510 mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
511 mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
512 mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
513 mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
514 mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
515 mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
516 mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
517 mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
518 mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
519
520 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
521 mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
522 mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
523 mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
524 mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
525 mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
526 generic, PUBLIC :: send => mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
527 mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
528 mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
529 mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
530 mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
531 mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
532
533 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
534 mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
535 mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
536 mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
537 mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
538 mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
539 generic, PUBLIC :: recv => mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
540 mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
541 mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
542 mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
543 mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
544 mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
545
546 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_isendrecv_i, mp_isendrecv_iv, &
547 mp_isendrecv_l, mp_isendrecv_lv, mp_isendrecv_r, mp_isendrecv_rv, &
548 mp_isendrecv_d, mp_isendrecv_dv, mp_isendrecv_c, mp_isendrecv_cv, &
549 mp_isendrecv_z, mp_isendrecv_zv
550 generic, PUBLIC :: isendrecv => mp_isendrecv_i, mp_isendrecv_iv, &
551 mp_isendrecv_l, mp_isendrecv_lv, mp_isendrecv_r, mp_isendrecv_rv, &
552 mp_isendrecv_d, mp_isendrecv_dv, mp_isendrecv_c, mp_isendrecv_cv, &
553 mp_isendrecv_z, mp_isendrecv_zv
554
555 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
556 mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
557 mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
558 mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
559 mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
560 mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4, &
561 mp_isend_bv, mp_isend_bm3, mp_isend_custom
562 generic, PUBLIC :: isend => mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
563 mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
564 mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
565 mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
566 mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
567 mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4, &
568 mp_isend_bv, mp_isend_bm3, mp_isend_custom
569
570 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
571 mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
572 mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
573 mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
574 mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
575 mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4, &
576 mp_irecv_bv, mp_irecv_bm3, mp_irecv_custom
577 generic, PUBLIC :: irecv => mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
578 mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
579 mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
580 mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
581 mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
582 mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4, &
583 mp_irecv_bv, mp_irecv_bm3, mp_irecv_custom
584
585 PROCEDURE, PUBLIC, pass(comm), non_overridable :: probe => mp_probe
586
587 PROCEDURE, PUBLIC, pass(comm), non_overridable :: sync => mp_sync
588 PROCEDURE, PUBLIC, pass(comm), non_overridable :: isync => mp_isync
589
590 PROCEDURE, PUBLIC, pass(comm1), non_overridable :: compare => mp_comm_compare
591 PROCEDURE, PUBLIC, pass(comm1), non_overridable :: rank_compare => mp_rank_compare
592
593 PROCEDURE, PUBLIC, pass(comm2), non_overridable :: from_dup => mp_comm_dup
594 PROCEDURE, PUBLIC, pass(comm), non_overridable :: mp_comm_free
595 generic, PUBLIC :: free => mp_comm_free
596
597 PROCEDURE, PUBLIC, pass(comm), non_overridable :: mp_comm_init
598 generic, PUBLIC :: init => mp_comm_init
599
600 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_size => mp_comm_size
601 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_rank => mp_comm_rank
602 PROCEDURE, PUBLIC, pass(comm), non_overridable :: get_ndims => mp_comm_get_ndims
603 PROCEDURE, PUBLIC, pass(comm), non_overridable :: is_source => mp_comm_is_source
604
605 ! Creation routines
606 PROCEDURE, PRIVATE, pass(sub_comm), non_overridable :: mp_comm_split, mp_comm_split_direct
607 generic, PUBLIC :: from_split => mp_comm_split, mp_comm_split_direct
608 PROCEDURE, PUBLIC, pass(mp_new_comm), non_overridable :: from_reordering => mp_reordering
609 PROCEDURE, PUBLIC, pass(comm_new), non_overridable :: mp_comm_assign
610 generic, PUBLIC :: ASSIGNMENT(=) => mp_comm_assign
611
612 ! Other Getters
613 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_tag_ub
614 generic, PUBLIC :: get_tag_ub => mp_comm_get_tag_ub
615 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_host_rank
616 generic, PUBLIC :: get_host_rank => mp_comm_get_host_rank
617 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_io_rank
618 generic, PUBLIC :: get_io_rank => mp_comm_get_io_rank
619 PROCEDURE, PRIVATE, pass(comm), non_overridable :: mp_comm_get_wtime_is_global
620 generic, PUBLIC :: get_wtime_is_global => mp_comm_get_wtime_is_global
621 END TYPE
622
623 TYPE mp_request_type
624 PRIVATE
625 mpi_request_type :: handle = mp_request_null_handle
626 CONTAINS
627 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_request_type_set_handle
628 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_request_type_get_handle
629 PROCEDURE, PRIVATE, non_overridable :: mp_request_op_eq
630 PROCEDURE, PRIVATE, non_overridable :: mp_request_op_neq
631 generic, PUBLIC :: OPERATOR(==) => mp_request_op_eq
632 generic, PUBLIC :: OPERATOR(/=) => mp_request_op_neq
633
634 PROCEDURE, PUBLIC, pass(request), non_overridable :: test => mp_test_1
635
636 PROCEDURE, PUBLIC, pass(request), non_overridable :: wait => mp_wait
637 END TYPE
638
639 TYPE mp_win_type
640 PRIVATE
641 mpi_win_type :: handle = mp_win_null_handle
642 CONTAINS
643 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_win_type_set_handle
644 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_win_type_get_handle
645 PROCEDURE, PRIVATE, non_overridable :: mp_win_op_eq
646 PROCEDURE, PRIVATE, non_overridable :: mp_win_op_neq
647 generic, PUBLIC :: OPERATOR(==) => mp_win_op_eq
648 generic, PUBLIC :: OPERATOR(/=) => mp_win_op_neq
649
650 PROCEDURE, PRIVATE, pass(win), non_overridable :: mp_win_create_iv, mp_win_create_lv, &
651 mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv
652 generic, PUBLIC :: create => mp_win_create_iv, mp_win_create_lv, &
653 mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv
654
655 PROCEDURE, PRIVATE, pass(win), non_overridable :: mp_rget_iv, mp_rget_lv, &
656 mp_rget_rv, mp_rget_dv, mp_rget_cv, mp_rget_zv
657 generic, PUBLIC :: rget => mp_rget_iv, mp_rget_lv, &
658 mp_rget_rv, mp_rget_dv, mp_rget_cv, mp_rget_zv
659
660 PROCEDURE, PUBLIC, pass(win), non_overridable :: free => mp_win_free
661 PROCEDURE, PUBLIC, pass(win_new), non_overridable :: mp_win_assign
662 generic, PUBLIC :: ASSIGNMENT(=) => mp_win_assign
663
664 PROCEDURE, PUBLIC, pass(win), non_overridable :: lock_all => mp_win_lock_all
665 PROCEDURE, PUBLIC, pass(win), non_overridable :: unlock_all => mp_win_unlock_all
666 PROCEDURE, PUBLIC, pass(win), non_overridable :: flush_all => mp_win_flush_all
667 END TYPE
668
669 TYPE mp_file_type
670 PRIVATE
671 mpi_file_type :: handle = mp_file_null_handle
672 CONTAINS
673 PROCEDURE, PUBLIC, non_overridable :: set_handle => mp_file_type_set_handle
674 PROCEDURE, PUBLIC, non_overridable :: get_handle => mp_file_type_get_handle
675 PROCEDURE, PRIVATE, non_overridable :: mp_file_op_eq
676 PROCEDURE, PRIVATE, non_overridable :: mp_file_op_neq
677 generic, PUBLIC :: OPERATOR(==) => mp_file_op_eq
678 generic, PUBLIC :: OPERATOR(/=) => mp_file_op_neq
679
680 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_write_at_ch, mp_file_write_at_chv, &
681 mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, &
682 mp_file_write_at_d, mp_file_write_at_dv, mp_file_write_at_c, mp_file_write_at_cv, &
683 mp_file_write_at_z, mp_file_write_at_zv, mp_file_write_at_l, mp_file_write_at_lv
684 generic, PUBLIC :: write_at => mp_file_write_at_ch, mp_file_write_at_chv, &
685 mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, &
686 mp_file_write_at_d, mp_file_write_at_dv, mp_file_write_at_c, mp_file_write_at_cv, &
687 mp_file_write_at_z, mp_file_write_at_zv, mp_file_write_at_l, mp_file_write_at_lv
688
689 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
690 mp_file_write_at_all_i, mp_file_write_at_all_iv, mp_file_write_at_all_l, mp_file_write_at_all_lv, &
691 mp_file_write_at_all_r, mp_file_write_at_all_rv, mp_file_write_at_all_d, mp_file_write_at_all_dv, &
692 mp_file_write_at_all_c, mp_file_write_at_all_cv, mp_file_write_at_all_z, mp_file_write_at_all_zv
693 generic, PUBLIC :: write_at_all => mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
694 mp_file_write_at_all_i, mp_file_write_at_all_iv, mp_file_write_at_all_l, mp_file_write_at_all_lv, &
695 mp_file_write_at_all_r, mp_file_write_at_all_rv, mp_file_write_at_all_d, mp_file_write_at_all_dv, &
696 mp_file_write_at_all_c, mp_file_write_at_all_cv, mp_file_write_at_all_z, mp_file_write_at_all_zv
697
698 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_read_at_ch, mp_file_read_at_chv, &
699 mp_file_read_at_i, mp_file_read_at_iv, mp_file_read_at_r, mp_file_read_at_rv, &
700 mp_file_read_at_d, mp_file_read_at_dv, mp_file_read_at_c, mp_file_read_at_cv, &
701 mp_file_read_at_z, mp_file_read_at_zv, mp_file_read_at_l, mp_file_read_at_lv
702 generic, PUBLIC :: read_at => mp_file_read_at_ch, mp_file_read_at_chv, &
703 mp_file_read_at_i, mp_file_read_at_iv, mp_file_read_at_r, mp_file_read_at_rv, &
704 mp_file_read_at_d, mp_file_read_at_dv, mp_file_read_at_c, mp_file_read_at_cv, &
705 mp_file_read_at_z, mp_file_read_at_zv, mp_file_read_at_l, mp_file_read_at_lv
706
707 PROCEDURE, PRIVATE, pass(fh), non_overridable :: mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
708 mp_file_read_at_all_i, mp_file_read_at_all_iv, mp_file_read_at_all_l, mp_file_read_at_all_lv, &
709 mp_file_read_at_all_r, mp_file_read_at_all_rv, mp_file_read_at_all_d, mp_file_read_at_all_dv, &
710 mp_file_read_at_all_c, mp_file_read_at_all_cv, mp_file_read_at_all_z, mp_file_read_at_all_zv
711 generic, PUBLIC :: read_at_all => mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
712 mp_file_read_at_all_i, mp_file_read_at_all_iv, mp_file_read_at_all_l, mp_file_read_at_all_lv, &
713 mp_file_read_at_all_r, mp_file_read_at_all_rv, mp_file_read_at_all_d, mp_file_read_at_all_dv, &
714 mp_file_read_at_all_c, mp_file_read_at_all_cv, mp_file_read_at_all_z, mp_file_read_at_all_zv
715
716 PROCEDURE, PUBLIC, pass(fh), non_overridable :: open => mp_file_open
717 PROCEDURE, PUBLIC, pass(fh), non_overridable :: close => mp_file_close
718 PROCEDURE, PRIVATE, pass(fh_new), non_overridable :: mp_file_assign
719 generic, PUBLIC :: ASSIGNMENT(=) => mp_file_assign
720
721 PROCEDURE, PUBLIC, pass(fh), non_overridable :: get_size => mp_file_get_size
722 PROCEDURE, PUBLIC, pass(fh), non_overridable :: get_position => mp_file_get_position
723
724 PROCEDURE, PUBLIC, pass(fh), non_overridable :: read_all => mp_file_read_all_chv
725 PROCEDURE, PUBLIC, pass(fh), non_overridable :: write_all => mp_file_write_all_chv
726 END TYPE
727
728 TYPE mp_info_type
729 PRIVATE
730 mpi_info_type :: handle = mp_info_null_handle
731 CONTAINS
732 PROCEDURE, NON_OVERRIDABLE :: set_handle => mp_info_type_set_handle
733 PROCEDURE, non_overridable :: get_handle => mp_info_type_get_handle
734 PROCEDURE, PRIVATE, non_overridable :: mp_info_op_eq
735 PROCEDURE, PRIVATE, non_overridable :: mp_info_op_neq
736 generic, PUBLIC :: OPERATOR(==) => mp_info_op_eq
737 generic, PUBLIC :: OPERATOR(/=) => mp_info_op_neq
738 END TYPE
739
740 TYPE, EXTENDS(mp_comm_type) :: mp_cart_type
741 INTEGER, DIMENSION(:), ALLOCATABLE, PUBLIC :: mepos_cart, num_pe_cart
742 LOGICAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: periodic
743 CONTAINS
744 PROCEDURE, PUBLIC, pass(comm_cart), non_overridable :: create => mp_cart_create
745 PROCEDURE, PUBLIC, pass(sub_comm), non_overridable :: from_sub => mp_cart_sub
746
747 PROCEDURE, PRIVATE, pass(comm), non_overridable :: get_info_cart => mp_cart_get
748
749 PROCEDURE, PUBLIC, pass(comm), non_overridable :: coords => mp_cart_coords
750 PROCEDURE, PUBLIC, pass(comm), non_overridable :: rank_cart => mp_cart_rank
751 END TYPE
752
753! **************************************************************************************************
754!> \brief stores all the informations relevant to an mpi environment
755!> \param owns_group if it owns the group (and thus should free it when
756!> this object is deallocated)
757!> \param ref_count the reference count, when it is zero this object gets
758!> deallocated
759!> \par History
760!> 08.2002 created [fawzi]
761!> \author Fawzi Mohamed
762! **************************************************************************************************
763 TYPE, EXTENDS(mp_comm_type) :: mp_para_env_type
764 PRIVATE
765 ! We set it to true to have less initialization steps in case we create a new communicator
766 LOGICAL :: owns_group = .true.
767 INTEGER :: ref_count = -1
768 CONTAINS
769 PROCEDURE, PUBLIC, pass(para_env), non_overridable :: retain => mp_para_env_retain
770 PROCEDURE, PUBLIC, pass(para_env), non_overridable :: is_valid => mp_para_env_is_valid
771 END TYPE mp_para_env_type
772
773! **************************************************************************************************
774!> \brief represent a pointer to a para env (to build arrays)
775!> \param para_env the pointer to the para_env
776!> \par History
777!> 07.2003 created [fawzi]
778!> \author Fawzi Mohamed
779! **************************************************************************************************
780 TYPE mp_para_env_p_type
781 TYPE(mp_para_env_type), POINTER :: para_env => null()
782 END TYPE mp_para_env_p_type
783
784! **************************************************************************************************
785!> \brief represent a multidimensional parallel environment
786!> \param mepos_cart the position of the actual processor
787!> \param num_pe_cart number of processors in the group in each dimension
788!> \param source_cart id of a special processor (for example the one for i-o,
789!> or the master
790!> \param owns_group if it owns the group (and thus should free it when
791!> this object is deallocated)
792!> \param ref_count the reference count, when it is zero this object gets
793!> deallocated
794!> \note
795!> not yet implemented for mpi
796!> \par History
797!> 08.2002 created [fawzi]
798!> \author Fawzi Mohamed
799! **************************************************************************************************
800 TYPE, EXTENDS(mp_cart_type) :: mp_para_cart_type
801 PRIVATE
802 ! We set it to true to have less initialization steps in case we create a new communicator
803 LOGICAL :: owns_group = .true.
804 INTEGER :: ref_count = -1
805 CONTAINS
806 PROCEDURE, PUBLIC, pass(cart), non_overridable :: retain => mp_para_cart_retain
807 PROCEDURE, PUBLIC, pass(cart), non_overridable :: is_valid => mp_para_cart_is_valid
808 END TYPE mp_para_cart_type
809
810 ! Create the constants from the corresponding handles
811 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_null = mp_comm_type(mp_comm_null_handle)
812 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_self = mp_comm_type(mp_comm_self_handle)
813 TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_world = mp_comm_type(mp_comm_world_handle)
814 TYPE(mp_request_type), PARAMETER, PUBLIC :: mp_request_null = mp_request_type(mp_request_null_handle)
815 TYPE(mp_win_type), PARAMETER, PUBLIC :: mp_win_null = mp_win_type(mp_win_null_handle)
816 TYPE(mp_file_type), PARAMETER, PUBLIC :: mp_file_null = mp_file_type(mp_file_null_handle)
817 TYPE(mp_info_type), PARAMETER, PUBLIC :: mp_info_null = mp_info_type(mp_info_null_handle)
818
819#if !defined(__parallel)
820 ! This communicator is to be used in serial mode to emulate a valid communicator which is not a compiler constant
821 INTEGER, PARAMETER, PRIVATE :: mp_comm_default_handle = 1
822 TYPE(mp_comm_type), PARAMETER, PRIVATE :: mp_comm_default = mp_comm_type(mp_comm_default_handle)
823#endif
824
825 ! Constants to compare communicators
826 INTEGER, PARAMETER, PUBLIC :: mp_comm_ident = 0
827 INTEGER, PARAMETER, PUBLIC :: mp_comm_congruent = 1
828 INTEGER, PARAMETER, PUBLIC :: mp_comm_similar = 2
829 INTEGER, PARAMETER, PUBLIC :: mp_comm_unequal = 3
830 INTEGER, PARAMETER, PUBLIC :: mp_comm_compare_default = -1
831
832 ! init and error
833 PUBLIC :: mp_world_init, mp_world_finalize
834 PUBLIC :: mp_abort
835
836 ! informational / generation of sub comms
837 PUBLIC :: mp_dims_create
838 PUBLIC :: cp2k_is_parallel
839
840 ! message passing
841 PUBLIC :: mp_waitall, mp_waitany
842 PUBLIC :: mp_testall, mp_testany
843
844 ! Memory management
845 PUBLIC :: mp_allocate, mp_deallocate
846
847 ! I/O
848 PUBLIC :: mp_file_delete
849 PUBLIC :: mp_file_get_amode
850
851 ! some 'advanced types' currently only used for dbcsr
852 PUBLIC :: mp_type_descriptor_type
853 PUBLIC :: mp_type_make
854 PUBLIC :: mp_type_size
855
856 ! vector types
857 PUBLIC :: mp_type_indexed_make_r, mp_type_indexed_make_d, &
858 mp_type_indexed_make_c, mp_type_indexed_make_z
859
860 ! More I/O types and routines: variable spaced data using bytes for spacings
861 PUBLIC :: mp_file_descriptor_type
862 PUBLIC :: mp_file_type_free
863 PUBLIC :: mp_file_type_hindexed_make_chv
864 PUBLIC :: mp_file_type_set_view_chv
865
866 PUBLIC :: mp_get_library_version
867
868 ! assumed to be private
869
870 INTERFACE mp_waitall
871 MODULE PROCEDURE mp_waitall_1, mp_waitall_2
872 END INTERFACE
873
874 INTERFACE mp_testall
875 MODULE PROCEDURE mp_testall_tv
876 END INTERFACE
877
878 INTERFACE mp_testany
879 MODULE PROCEDURE mp_testany_1, mp_testany_2
880 END INTERFACE
881
882 INTERFACE mp_type_free
883 MODULE PROCEDURE mp_type_free_m, mp_type_free_v
884 END INTERFACE
885
886 !
887 ! interfaces to deal easily with scalars / vectors / matrices / ...
888 ! of the different types (integers, doubles, logicals, characters)
889 !
890 INTERFACE mp_allocate
891 MODULE PROCEDURE mp_allocate_i, &
892 mp_allocate_l, &
893 mp_allocate_r, &
894 mp_allocate_d, &
895 mp_allocate_c, &
896 mp_allocate_z
897 END INTERFACE
898
899 INTERFACE mp_deallocate
900 MODULE PROCEDURE mp_deallocate_i, &
901 mp_deallocate_l, &
902 mp_deallocate_r, &
903 mp_deallocate_d, &
904 mp_deallocate_c, &
905 mp_deallocate_z
906 END INTERFACE
907
908 INTERFACE mp_type_make
909 MODULE PROCEDURE mp_type_make_struct
910 MODULE PROCEDURE mp_type_make_i, mp_type_make_l, &
911 mp_type_make_r, mp_type_make_d, &
912 mp_type_make_c, mp_type_make_z
913 END INTERFACE
914
915 INTERFACE mp_alloc_mem
916 MODULE PROCEDURE mp_alloc_mem_i, mp_alloc_mem_l, &
917 mp_alloc_mem_d, mp_alloc_mem_z, &
918 mp_alloc_mem_r, mp_alloc_mem_c
919 END INTERFACE
920
921 INTERFACE mp_free_mem
922 MODULE PROCEDURE mp_free_mem_i, mp_free_mem_l, &
923 mp_free_mem_d, mp_free_mem_z, &
924 mp_free_mem_r, mp_free_mem_c
925 END INTERFACE
926
927! Type declarations
928 TYPE mp_indexing_meta_type
929 INTEGER, DIMENSION(:), POINTER :: index => null(), chunks => null()
930 END TYPE mp_indexing_meta_type
931
932 TYPE mp_type_descriptor_type
933 mpi_data_type :: type_handle = mp_datatype_null_handle
934 INTEGER :: length = -1
935#if defined(__parallel)
936 INTEGER(kind=mpi_address_kind) :: base = -1
937#endif
938 INTEGER(kind=int_4), DIMENSION(:), POINTER :: data_i => null()
939 INTEGER(kind=int_8), DIMENSION(:), POINTER :: data_l => null()
940 REAL(kind=real_4), DIMENSION(:), POINTER :: data_r => null()
941 REAL(kind=real_8), DIMENSION(:), POINTER :: data_d => null()
942 COMPLEX(kind=real_4), DIMENSION(:), POINTER :: data_c => null()
943 COMPLEX(kind=real_8), DIMENSION(:), POINTER :: data_z => null()
944 TYPE(mp_type_descriptor_type), DIMENSION(:), POINTER :: subtype => null()
945 INTEGER :: vector_descriptor(2) = -1
946 LOGICAL :: has_indexing = .false.
947 TYPE(mp_indexing_meta_type) :: index_descriptor = mp_indexing_meta_type()
948 END TYPE mp_type_descriptor_type
949
950 TYPE mp_file_indexing_meta_type
951 INTEGER, DIMENSION(:), POINTER :: index => null()
952 INTEGER(kind=file_offset), &
953 DIMENSION(:), POINTER :: chunks => null()
954 END TYPE mp_file_indexing_meta_type
955
956 TYPE mp_file_descriptor_type
957 mpi_data_type :: type_handle = mp_datatype_null_handle
958 INTEGER :: length = -1
959 LOGICAL :: has_indexing = .false.
960 TYPE(mp_file_indexing_meta_type) :: index_descriptor = mp_file_indexing_meta_type()
961 END TYPE
962
963 ! we make some assumptions on the length of INTEGERS, REALS and LOGICALS
964 INTEGER, PARAMETER :: intlen = bit_size(0)/8
965 INTEGER, PARAMETER :: reallen = 8
966 INTEGER, PARAMETER :: loglen = bit_size(0)/8
967 INTEGER, PARAMETER :: charlen = 1
968
969 LOGICAL, PUBLIC, SAVE :: mp_collect_timings = .false.
970
971CONTAINS
972
973 LOGICAL FUNCTION mp_comm_op_eq(comm1, comm2)
974 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
975#if defined(__parallel) && defined(__MPI_F08)
976 mp_comm_op_eq = (comm1%handle%mpi_val == comm2%handle%mpi_val)
977#else
978 mp_comm_op_eq = (comm1%handle == comm2%handle)
979#endif
980 END FUNCTION mp_comm_op_eq
981
982 LOGICAL FUNCTION mp_comm_op_neq(comm1, comm2)
983 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
984#if defined(__parallel) && defined(__MPI_F08)
985 mp_comm_op_neq = (comm1%handle%mpi_val /= comm2%handle%mpi_val)
986#else
987 mp_comm_op_neq = (comm1%handle /= comm2%handle)
988#endif
989 END FUNCTION mp_comm_op_neq
990
991 ELEMENTAL IMPURE SUBROUTINE mp_comm_type_set_handle(this, handle , ndims)
992 CLASS(mp_comm_type), INTENT(INOUT) :: this
993 INTEGER, INTENT(IN) :: handle
994 INTEGER, INTENT(IN), OPTIONAL :: ndims
995
996#if defined(__parallel) && defined(__MPI_F08)
997 this%handle%mpi_val = handle
998#else
999 this%handle = handle
1000#endif
1001
1002 SELECT TYPE (this)
1003 CLASS IS (mp_cart_type)
1004 IF (.NOT. PRESENT(ndims)) &
1005 CALL cp_abort(__location__, &
1006 "Setup of a cartesian communicator requires information on the number of dimensions!")
1007 END SELECT
1008 IF (PRESENT(ndims)) this%ndims = ndims
1009 CALL this%init()
1010
1011 END SUBROUTINE mp_comm_type_set_handle
1012
1013 ELEMENTAL FUNCTION mp_comm_type_get_handle(this) RESULT(handle)
1014 CLASS(mp_comm_type), INTENT(IN) :: this
1015 INTEGER :: handle
1016
1017#if defined(__parallel) && defined(__MPI_F08)
1018 handle = this%handle%mpi_val
1019#else
1020 handle = this%handle
1021#endif
1022 END FUNCTION mp_comm_type_get_handle
1023 LOGICAL FUNCTION mp_request_op_eq(request1, request2)
1024 CLASS(mp_request_type), INTENT(IN) :: request1, request2
1025#if defined(__parallel) && defined(__MPI_F08)
1026 mp_request_op_eq = (request1%handle%mpi_val == request2%handle%mpi_val)
1027#else
1028 mp_request_op_eq = (request1%handle == request2%handle)
1029#endif
1030 END FUNCTION mp_request_op_eq
1031
1032 LOGICAL FUNCTION mp_request_op_neq(request1, request2)
1033 CLASS(mp_request_type), INTENT(IN) :: request1, request2
1034#if defined(__parallel) && defined(__MPI_F08)
1035 mp_request_op_neq = (request1%handle%mpi_val /= request2%handle%mpi_val)
1036#else
1037 mp_request_op_neq = (request1%handle /= request2%handle)
1038#endif
1039 END FUNCTION mp_request_op_neq
1040
1041 ELEMENTAL SUBROUTINE mp_request_type_set_handle(this, handle )
1042 CLASS(mp_request_type), INTENT(INOUT) :: this
1043 INTEGER, INTENT(IN) :: handle
1044
1045#if defined(__parallel) && defined(__MPI_F08)
1046 this%handle%mpi_val = handle
1047#else
1048 this%handle = handle
1049#endif
1050
1051
1052 END SUBROUTINE mp_request_type_set_handle
1053
1054 ELEMENTAL FUNCTION mp_request_type_get_handle(this) RESULT(handle)
1055 CLASS(mp_request_type), INTENT(IN) :: this
1056 INTEGER :: handle
1057
1058#if defined(__parallel) && defined(__MPI_F08)
1059 handle = this%handle%mpi_val
1060#else
1061 handle = this%handle
1062#endif
1063 END FUNCTION mp_request_type_get_handle
1064 LOGICAL FUNCTION mp_win_op_eq(win1, win2)
1065 CLASS(mp_win_type), INTENT(IN) :: win1, win2
1066#if defined(__parallel) && defined(__MPI_F08)
1067 mp_win_op_eq = (win1%handle%mpi_val == win2%handle%mpi_val)
1068#else
1069 mp_win_op_eq = (win1%handle == win2%handle)
1070#endif
1071 END FUNCTION mp_win_op_eq
1072
1073 LOGICAL FUNCTION mp_win_op_neq(win1, win2)
1074 CLASS(mp_win_type), INTENT(IN) :: win1, win2
1075#if defined(__parallel) && defined(__MPI_F08)
1076 mp_win_op_neq = (win1%handle%mpi_val /= win2%handle%mpi_val)
1077#else
1078 mp_win_op_neq = (win1%handle /= win2%handle)
1079#endif
1080 END FUNCTION mp_win_op_neq
1081
1082 ELEMENTAL SUBROUTINE mp_win_type_set_handle(this, handle )
1083 CLASS(mp_win_type), INTENT(INOUT) :: this
1084 INTEGER, INTENT(IN) :: handle
1085
1086#if defined(__parallel) && defined(__MPI_F08)
1087 this%handle%mpi_val = handle
1088#else
1089 this%handle = handle
1090#endif
1091
1092
1093 END SUBROUTINE mp_win_type_set_handle
1094
1095 ELEMENTAL FUNCTION mp_win_type_get_handle(this) RESULT(handle)
1096 CLASS(mp_win_type), INTENT(IN) :: this
1097 INTEGER :: handle
1098
1099#if defined(__parallel) && defined(__MPI_F08)
1100 handle = this%handle%mpi_val
1101#else
1102 handle = this%handle
1103#endif
1104 END FUNCTION mp_win_type_get_handle
1105 LOGICAL FUNCTION mp_file_op_eq(file1, file2)
1106 CLASS(mp_file_type), INTENT(IN) :: file1, file2
1107#if defined(__parallel) && defined(__MPI_F08)
1108 mp_file_op_eq = (file1%handle%mpi_val == file2%handle%mpi_val)
1109#else
1110 mp_file_op_eq = (file1%handle == file2%handle)
1111#endif
1112 END FUNCTION mp_file_op_eq
1113
1114 LOGICAL FUNCTION mp_file_op_neq(file1, file2)
1115 CLASS(mp_file_type), INTENT(IN) :: file1, file2
1116#if defined(__parallel) && defined(__MPI_F08)
1117 mp_file_op_neq = (file1%handle%mpi_val /= file2%handle%mpi_val)
1118#else
1119 mp_file_op_neq = (file1%handle /= file2%handle)
1120#endif
1121 END FUNCTION mp_file_op_neq
1122
1123 ELEMENTAL SUBROUTINE mp_file_type_set_handle(this, handle )
1124 CLASS(mp_file_type), INTENT(INOUT) :: this
1125 INTEGER, INTENT(IN) :: handle
1126
1127#if defined(__parallel) && defined(__MPI_F08)
1128 this%handle%mpi_val = handle
1129#else
1130 this%handle = handle
1131#endif
1132
1133
1134 END SUBROUTINE mp_file_type_set_handle
1135
1136 ELEMENTAL FUNCTION mp_file_type_get_handle(this) RESULT(handle)
1137 CLASS(mp_file_type), INTENT(IN) :: this
1138 INTEGER :: handle
1139
1140#if defined(__parallel) && defined(__MPI_F08)
1141 handle = this%handle%mpi_val
1142#else
1143 handle = this%handle
1144#endif
1145 END FUNCTION mp_file_type_get_handle
1146 LOGICAL FUNCTION mp_info_op_eq(info1, info2)
1147 CLASS(mp_info_type), INTENT(IN) :: info1, info2
1148#if defined(__parallel) && defined(__MPI_F08)
1149 mp_info_op_eq = (info1%handle%mpi_val == info2%handle%mpi_val)
1150#else
1151 mp_info_op_eq = (info1%handle == info2%handle)
1152#endif
1153 END FUNCTION mp_info_op_eq
1154
1155 LOGICAL FUNCTION mp_info_op_neq(info1, info2)
1156 CLASS(mp_info_type), INTENT(IN) :: info1, info2
1157#if defined(__parallel) && defined(__MPI_F08)
1158 mp_info_op_neq = (info1%handle%mpi_val /= info2%handle%mpi_val)
1159#else
1160 mp_info_op_neq = (info1%handle /= info2%handle)
1161#endif
1162 END FUNCTION mp_info_op_neq
1163
1164 ELEMENTAL SUBROUTINE mp_info_type_set_handle(this, handle )
1165 CLASS(mp_info_type), INTENT(INOUT) :: this
1166 INTEGER, INTENT(IN) :: handle
1167
1168#if defined(__parallel) && defined(__MPI_F08)
1169 this%handle%mpi_val = handle
1170#else
1171 this%handle = handle
1172#endif
1173
1174
1175 END SUBROUTINE mp_info_type_set_handle
1176
1177 ELEMENTAL FUNCTION mp_info_type_get_handle(this) RESULT(handle)
1178 CLASS(mp_info_type), INTENT(IN) :: this
1179 INTEGER :: handle
1180
1181#if defined(__parallel) && defined(__MPI_F08)
1182 handle = this%handle%mpi_val
1183#else
1184 handle = this%handle
1185#endif
1186 END FUNCTION mp_info_type_get_handle
1187
1188 FUNCTION mp_comm_get_tag_ub(comm) RESULT(tag_ub)
1189 CLASS(mp_comm_type), INTENT(IN) :: comm
1190 INTEGER :: tag_ub
1191
1192#if defined(__parallel)
1193 INTEGER :: ierr
1194 LOGICAL :: flag
1195 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1196
1197 CALL mpi_comm_get_attr(comm%handle, mpi_tag_ub, attrval, flag, ierr)
1198 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_tag_ub")
1199 IF (.NOT. flag) cpabort("Upper bound of tags not available!")
1200 tag_ub = int(attrval, kind=kind(tag_ub))
1201#else
1202 mark_used(comm)
1203 tag_ub = huge(1)
1204#endif
1205 END FUNCTION mp_comm_get_tag_ub
1206
1207 FUNCTION mp_comm_get_host_rank(comm) RESULT(host_rank)
1208 CLASS(mp_comm_type), INTENT(IN) :: comm
1209 INTEGER :: host_rank
1210
1211#if defined(__parallel)
1212 INTEGER :: ierr
1213 LOGICAL :: flag
1214 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1215
1216 CALL mpi_comm_get_attr(comm%handle, mpi_host, attrval, flag, ierr)
1217 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_host_rank")
1218 IF (.NOT. flag) cpabort("Host process rank not available!")
1219 host_rank = int(attrval, kind=kind(host_rank))
1220#else
1221 mark_used(comm)
1222 host_rank = 0
1223#endif
1224 END FUNCTION mp_comm_get_host_rank
1225
1226 FUNCTION mp_comm_get_io_rank(comm) RESULT(io_rank)
1227 CLASS(mp_comm_type), INTENT(IN) :: comm
1228 INTEGER :: io_rank
1229
1230#if defined(__parallel)
1231 INTEGER :: ierr
1232 LOGICAL :: flag
1233 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1234
1235 CALL mpi_comm_get_attr(comm%handle, mpi_io, attrval, flag, ierr)
1236 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_io_rank")
1237 IF (.NOT. flag) cpabort("IO rank not available!")
1238 io_rank = int(attrval, kind=kind(io_rank))
1239#else
1240 mark_used(comm)
1241 io_rank = 0
1242#endif
1243 END FUNCTION mp_comm_get_io_rank
1244
1245 FUNCTION mp_comm_get_wtime_is_global(comm) RESULT(wtime_is_global)
1246 CLASS(mp_comm_type), INTENT(IN) :: comm
1247 LOGICAL :: wtime_is_global
1248
1249#if defined(__parallel)
1250 INTEGER :: ierr
1251 LOGICAL :: flag
1252 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1253
1254 CALL mpi_comm_get_attr(comm%handle, mpi_tag_ub, attrval, flag, ierr)
1255 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_wtime_is_global")
1256 IF (.NOT. flag) cpabort("Synchronization state of WTIME not available!")
1257 wtime_is_global = (attrval == 1_mpi_address_kind)
1258#else
1259 mark_used(comm)
1260 wtime_is_global = .true.
1261#endif
1262 END FUNCTION mp_comm_get_wtime_is_global
1263
1264! **************************************************************************************************
1265!> \brief initializes the system default communicator
1266!> \param mp_comm [output] : handle of the default communicator
1267!> \par History
1268!> 2.2004 created [Joost VandeVondele ]
1269!> \note
1270!> should only be called once
1271! **************************************************************************************************
1272 SUBROUTINE mp_world_init(mp_comm)
1273 CLASS(mp_comm_type), INTENT(OUT) :: mp_comm
1274#if defined(__parallel)
1275 INTEGER :: ierr
1276!$ INTEGER :: provided_tsl
1277!$ LOGICAL :: no_threading_support
1278
1279#if defined(__NO_MPI_THREAD_SUPPORT_CHECK)
1280 ! Hack that does not request or check MPI thread support level.
1281 ! User asserts that the MPI library will work correctly with
1282 ! threads.
1283!
1284!$ no_threading_support = .TRUE.
1285#else
1286 ! Does the right thing when using OpenMP: requests that the MPI
1287 ! library supports serialized mode and verifies that the MPI library
1288 ! provides that support.
1289 !
1290 ! Developers: Only the master thread will ever make calls to the
1291 ! MPI library.
1292!
1293!$ no_threading_support = .FALSE.
1294#endif
1295!$ IF (no_threading_support) THEN
1296 CALL mpi_init(ierr)
1297 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init @ mp_world_init")
1298!$ ELSE
1299!$OMP MASTER
1300#if defined(__DLAF)
1301 ! DLA-Future requires that the MPI library supports
1302 ! THREAD_MULTIPLE mode
1303!$ CALL mpi_init_thread(MPI_THREAD_MULTIPLE, provided_tsl, ierr)
1304#else
1305!$ CALL mpi_init_thread(MPI_THREAD_SERIALIZED, provided_tsl, ierr)
1306#endif
1307!$ IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
1308#if defined(__DLAF)
1309!$ IF (provided_tsl < MPI_THREAD_MULTIPLE) THEN
1310!$ CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_MULTIPLE), required by DLA-Future. Build CP2K without DLA-Future.")
1311!$ END IF
1312#else
1313!$ IF (provided_tsl < MPI_THREAD_SERIALIZED) THEN
1314!$ CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_SERIALIZED).")
1315!$ END IF
1316#endif
1317!$OMP END MASTER
1318!$ END IF
1319 CALL mpi_comm_set_errhandler(mpi_comm_world, mpi_errors_return, ierr)
1320 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_set_errhandler @ mp_world_init")
1321#endif
1322 debug_comm_count = 1
1323 mp_comm = mp_comm_world
1324 CALL mp_comm%init()
1325 CALL add_mp_perf_env()
1326 END SUBROUTINE mp_world_init
1327
1328! **************************************************************************************************
1329!> \brief re-create the system default communicator with a different MPI
1330!> rank order
1331!> \param mp_comm [output] : handle of the default communicator
1332!> \param mp_new_comm ...
1333!> \param ranks_order ...
1334!> \par History
1335!> 1.2012 created [ Christiane Pousa ]
1336!> \note
1337!> should only be called once, at very beginning of CP2K run
1338! **************************************************************************************************
1339 SUBROUTINE mp_reordering(mp_comm, mp_new_comm, ranks_order)
1340 CLASS(mp_comm_type), INTENT(IN) :: mp_comm
1341 CLASS(mp_comm_type), INTENT(out) :: mp_new_comm
1342 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: ranks_order
1343
1344 CHARACTER(len=*), PARAMETER :: routinen = 'mp_reordering'
1345
1346 INTEGER :: handle, ierr
1347#if defined(__parallel)
1348 mpi_group_type :: newgroup, oldgroup
1349#endif
1350
1351 CALL mp_timeset(routinen, handle)
1352 ierr = 0
1353#if defined(__parallel)
1354
1355 CALL mpi_comm_group(mp_comm%handle, oldgroup, ierr)
1356 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_reordering")
1357 CALL mpi_group_incl(oldgroup, SIZE(ranks_order), ranks_order, newgroup, ierr)
1358 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_incl @ mp_reordering")
1359
1360 CALL mpi_comm_create(mp_comm%handle, newgroup, mp_new_comm%handle, ierr)
1361 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_create @ mp_reordering")
1362
1363 CALL mpi_group_free(oldgroup, ierr)
1364 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1365 CALL mpi_group_free(newgroup, ierr)
1366 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1367
1368 CALL add_perf(perf_id=1, count=1)
1369#else
1370 mark_used(mp_comm)
1371 mark_used(ranks_order)
1372 mp_new_comm%handle = mp_comm_default_handle
1373#endif
1374 debug_comm_count = debug_comm_count + 1
1375 CALL mp_new_comm%init()
1376 CALL mp_timestop(handle)
1377 END SUBROUTINE mp_reordering
1378
1379! **************************************************************************************************
1380!> \brief finalizes the system default communicator
1381!> \par History
1382!> 2.2004 created [Joost VandeVondele]
1383! **************************************************************************************************
1384 SUBROUTINE mp_world_finalize()
1385
1386 CHARACTER(LEN=default_string_length) :: debug_comm_count_char
1387#if defined(__parallel)
1388 INTEGER :: ierr
1389 CALL mpi_barrier(mpi_comm_world, ierr) ! call mpi directly to avoid 0 stack pointer
1390#endif
1391 CALL rm_mp_perf_env()
1392
1393 debug_comm_count = debug_comm_count - 1
1394#if defined(__parallel)
1395 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_world_finalize")
1396#endif
1397 IF (debug_comm_count /= 0) THEN
1398 ! A bug, we're leaking or double-freeing communicators. Needs to be fixed where the leak happens.
1399 ! Memory leak checking might be helpful to locate the culprit
1400 WRITE (unit=debug_comm_count_char, fmt='(I2)') debug_comm_count
1401 CALL cp_abort(__location__, "mp_world_finalize: assert failed:"// &
1402 " leaking communicators "//adjustl(trim(debug_comm_count_char)))
1403 END IF
1404#if defined(__parallel)
1405 CALL mpi_finalize(ierr)
1406 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_finalize @ mp_world_finalize")
1407#endif
1408
1409 END SUBROUTINE mp_world_finalize
1410
1411! all the following routines should work for a given communicator, not MPI_WORLD
1412
1413! **************************************************************************************************
1414!> \brief globally stops all tasks
1415!> this is intended to be low level, most of CP2K should call cp_abort()
1416! **************************************************************************************************
1417 SUBROUTINE mp_abort()
1418 INTEGER :: ierr
1419
1420 ierr = 0
1421
1422#if !defined(__NO_ABORT)
1423#if defined(__parallel)
1424 CALL mpi_abort(mpi_comm_world, 1, ierr)
1425#else
1426 CALL m_abort()
1427#endif
1428#endif
1429 ! this routine never returns and levels with non-zero exit code
1430 stop 1
1431 END SUBROUTINE mp_abort
1432
1433! **************************************************************************************************
1434!> \brief stops *after an mpi error* translating the error code
1435!> \param ierr an error code * returned by an mpi call *
1436!> \param prg_code ...
1437!> \note
1438!> this function is private to message_passing.F
1439! **************************************************************************************************
1440 SUBROUTINE mp_stop(ierr, prg_code)
1441 INTEGER, INTENT(IN) :: ierr
1442 CHARACTER(LEN=*), INTENT(IN) :: prg_code
1443
1444#if defined(__parallel)
1445 INTEGER :: istat, len
1446 CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: error_string
1447 CHARACTER(LEN=MPI_MAX_ERROR_STRING + 512) :: full_error
1448#else
1449 CHARACTER(LEN=512) :: full_error
1450#endif
1451
1452#if defined(__parallel)
1453 CALL mpi_error_string(ierr, error_string, len, istat)
1454 WRITE (full_error, '(A,I0,A)') ' MPI error ', ierr, ' in '//trim(prg_code)//' : '//error_string(1:len)
1455#else
1456 WRITE (full_error, '(A,I0,A)') ' MPI error (!?) ', ierr, ' in '//trim(prg_code)
1457#endif
1458
1459 cpabort(full_error)
1460
1461 END SUBROUTINE mp_stop
1462
1463! **************************************************************************************************
1464!> \brief synchronizes with a barrier a given group of mpi tasks
1465!> \param group mpi communicator
1466! **************************************************************************************************
1467 SUBROUTINE mp_sync(comm)
1468 CLASS(mp_comm_type), INTENT(IN) :: comm
1469
1470 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sync'
1471
1472 INTEGER :: handle, ierr
1473
1474 ierr = 0
1475 CALL mp_timeset(routinen, handle)
1476
1477#if defined(__parallel)
1478 CALL mpi_barrier(comm%handle, ierr)
1479 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_sync")
1480 CALL add_perf(perf_id=5, count=1)
1481#else
1482 mark_used(comm)
1483#endif
1484 CALL mp_timestop(handle)
1485
1486 END SUBROUTINE mp_sync
1487
1488! **************************************************************************************************
1489!> \brief synchronizes with a barrier a given group of mpi tasks
1490!> \param comm mpi communicator
1491!> \param request ...
1492! **************************************************************************************************
1493 SUBROUTINE mp_isync(comm, request)
1494 CLASS(mp_comm_type), INTENT(IN) :: comm
1495 TYPE(mp_request_type), INTENT(OUT) :: request
1496
1497 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isync'
1498
1499 INTEGER :: handle, ierr
1500
1501 ierr = 0
1502 CALL mp_timeset(routinen, handle)
1503
1504#if defined(__parallel)
1505 CALL mpi_ibarrier(comm%handle, request%handle, ierr)
1506 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibarrier @ mp_isync")
1507 CALL add_perf(perf_id=26, count=1)
1508#else
1509 mark_used(comm)
1510 request = mp_request_null
1511#endif
1512 CALL mp_timestop(handle)
1513
1514 END SUBROUTINE mp_isync
1515
1516! **************************************************************************************************
1517!> \brief returns task id for a given mpi communicator
1518!> \param taskid The ID of the communicator
1519!> \param comm mpi communicator
1520! **************************************************************************************************
1521 SUBROUTINE mp_comm_rank(taskid, comm)
1522
1523 INTEGER, INTENT(OUT) :: taskid
1524 CLASS(mp_comm_type), INTENT(IN) :: comm
1525
1526 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_rank'
1527
1528 INTEGER :: handle
1529#if defined(__parallel)
1530 INTEGER :: ierr
1531#endif
1532
1533 CALL mp_timeset(routinen, handle)
1534
1535#if defined(__parallel)
1536 CALL mpi_comm_rank(comm%handle, taskid, ierr)
1537 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_rank")
1538#else
1539 mark_used(comm)
1540 taskid = 0
1541#endif
1542 CALL mp_timestop(handle)
1543
1544 END SUBROUTINE mp_comm_rank
1545
1546! **************************************************************************************************
1547!> \brief returns number of tasks for a given mpi communicator
1548!> \param numtask ...
1549!> \param comm mpi communicator
1550! **************************************************************************************************
1551 SUBROUTINE mp_comm_size(numtask, comm)
1552
1553 INTEGER, INTENT(OUT) :: numtask
1554 CLASS(mp_comm_type), INTENT(IN) :: comm
1555
1556 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_size'
1557
1558 INTEGER :: handle
1559#if defined(__parallel)
1560 INTEGER :: ierr
1561#endif
1562
1563 CALL mp_timeset(routinen, handle)
1564
1565#if defined(__parallel)
1566 CALL mpi_comm_size(comm%handle, numtask, ierr)
1567 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_size")
1568#else
1569 mark_used(comm)
1570 numtask = 1
1571#endif
1572 CALL mp_timestop(handle)
1573
1574 END SUBROUTINE mp_comm_size
1575
1576! **************************************************************************************************
1577!> \brief returns info for a given Cartesian MPI communicator
1578!> \param comm ...
1579!> \param ndims ...
1580!> \param dims ...
1581!> \param task_coor ...
1582!> \param periods ...
1583! **************************************************************************************************
1584 SUBROUTINE mp_cart_get(comm, dims, task_coor, periods)
1585
1586 CLASS(mp_cart_type), INTENT(IN) :: comm
1587 INTEGER, INTENT(OUT), OPTIONAL :: dims(comm%ndims), task_coor(comm%ndims)
1588 LOGICAL, INTENT(out), OPTIONAL :: periods(comm%ndims)
1589
1590 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_get'
1591
1592 INTEGER :: handle
1593#if defined(__parallel)
1594 INTEGER :: ierr
1595 INTEGER :: my_dims(comm%ndims), my_task_coor(comm%ndims)
1596 LOGICAL :: my_periods(comm%ndims)
1597#endif
1598
1599 CALL mp_timeset(routinen, handle)
1600
1601#if defined(__parallel)
1602 CALL mpi_cart_get(comm%handle, comm%ndims, my_dims, my_periods, my_task_coor, ierr)
1603 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_cart_get")
1604 IF (PRESENT(dims)) dims = my_dims
1605 IF (PRESENT(task_coor)) task_coor = my_task_coor
1606 IF (PRESENT(periods)) periods = my_periods
1607#else
1608 mark_used(comm)
1609 IF (PRESENT(task_coor)) task_coor = 0
1610 IF (PRESENT(dims)) dims = 1
1611 IF (PRESENT(periods)) periods = .false.
1612#endif
1613 CALL mp_timestop(handle)
1614
1615 END SUBROUTINE mp_cart_get
1616
1617 INTEGER ELEMENTAL function mp_comm_get_ndims(comm)
1618 CLASS(mp_comm_type), INTENT(IN) :: comm
1619
1620 mp_comm_get_ndims = comm%ndims
1621
1622 END FUNCTION
1623
1624! **************************************************************************************************
1625!> \brief creates a cartesian communicator from any communicator
1626!> \param comm_old ...
1627!> \param ndims ...
1628!> \param dims ...
1629!> \param pos ...
1630!> \param comm_cart ...
1631! **************************************************************************************************
1632 SUBROUTINE mp_cart_create(comm_old, ndims, dims, comm_cart)
1633
1634 CLASS(mp_comm_type), INTENT(IN) :: comm_old
1635 INTEGER, INTENT(IN) :: ndims
1636 INTEGER, INTENT(INOUT) :: dims(ndims)
1637 CLASS(mp_cart_type), INTENT(OUT) :: comm_cart
1638
1639 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_create'
1640
1641 INTEGER :: handle, ierr
1642#if defined(__parallel)
1643 LOGICAL, DIMENSION(1:ndims) :: period
1644 LOGICAL :: reorder
1645#endif
1646
1647 ierr = 0
1648 CALL mp_timeset(routinen, handle)
1649
1650 comm_cart%handle = comm_old%handle
1651#if defined(__parallel)
1652
1653 IF (any(dims == 0)) CALL mpi_dims_create(comm_old%num_pe, ndims, dims, ierr)
1654 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_cart_create")
1655
1656 ! FIX ME. Quick hack to avoid problems with realspace grids for compilers
1657 ! like IBM that actually reorder the processors when creating the new
1658 ! communicator
1659 reorder = .false.
1660 period = .true.
1661 CALL mpi_cart_create(comm_old%handle, ndims, dims, period, reorder, comm_cart%handle, &
1662 ierr)
1663 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_create @ mp_cart_create")
1664 CALL add_perf(perf_id=1, count=1)
1665#else
1666 dims = 1
1667 comm_cart%handle = mp_comm_default_handle
1668#endif
1669 comm_cart%ndims = ndims
1670 debug_comm_count = debug_comm_count + 1
1671 CALL comm_cart%init()
1672 CALL mp_timestop(handle)
1673
1674 END SUBROUTINE mp_cart_create
1675
1676! **************************************************************************************************
1677!> \brief wrapper to MPI_Cart_coords
1678!> \param comm ...
1679!> \param rank ...
1680!> \param coords ...
1681! **************************************************************************************************
1682 SUBROUTINE mp_cart_coords(comm, rank, coords)
1683
1684 CLASS(mp_cart_type), INTENT(IN) :: comm
1685 INTEGER, INTENT(IN) :: rank
1686 INTEGER, DIMENSION(:), INTENT(OUT) :: coords
1687
1688 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_coords'
1689
1690 INTEGER :: handle, ierr, m
1691
1692 ierr = 0
1693 CALL mp_timeset(routinen, handle)
1694
1695 m = SIZE(coords)
1696#if defined(__parallel)
1697 CALL mpi_cart_coords(comm%handle, rank, m, coords, ierr)
1698 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_coords @ mp_cart_coords")
1699#else
1700 coords = 0
1701 mark_used(rank)
1702 mark_used(comm)
1703#endif
1704 CALL mp_timestop(handle)
1705
1706 END SUBROUTINE mp_cart_coords
1707
1708! **************************************************************************************************
1709!> \brief wrapper to MPI_Comm_compare
1710!> \param comm1 ...
1711!> \param comm2 ...
1712!> \param res ...
1713! **************************************************************************************************
1714 FUNCTION mp_comm_compare(comm1, comm2) RESULT(res)
1715
1716 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
1717 INTEGER :: res
1718
1719 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_compare'
1720
1721 INTEGER :: handle
1722#if defined(__parallel)
1723 INTEGER :: ierr, iout
1724#endif
1725
1726 CALL mp_timeset(routinen, handle)
1727
1728 res = 0
1729#if defined(__parallel)
1730 CALL mpi_comm_compare(comm1%handle, comm2%handle, iout, ierr)
1731 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_compare @ mp_comm_compare")
1732 SELECT CASE (iout)
1733 CASE (mpi_ident)
1734 res = mp_comm_ident
1735 CASE (mpi_congruent)
1736 res = mp_comm_congruent
1737 CASE (mpi_similar)
1738 res = mp_comm_similar
1739 CASE (mpi_unequal)
1740 res = mp_comm_unequal
1741 CASE default
1742 cpabort("Unknown comparison state of the communicators!")
1743 END SELECT
1744#else
1745 mark_used(comm1)
1746 mark_used(comm2)
1747#endif
1748 CALL mp_timestop(handle)
1749
1750 END FUNCTION mp_comm_compare
1751
1752! **************************************************************************************************
1753!> \brief wrapper to MPI_Cart_sub
1754!> \param comm ...
1755!> \param rdim ...
1756!> \param sub_comm ...
1757! **************************************************************************************************
1758 SUBROUTINE mp_cart_sub(comm, rdim, sub_comm)
1759
1760 CLASS(mp_cart_type), INTENT(IN) :: comm
1761 LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: rdim
1762 CLASS(mp_cart_type), INTENT(OUT) :: sub_comm
1763
1764 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_sub'
1765
1766 INTEGER :: handle
1767#if defined(__parallel)
1768 INTEGER :: ierr
1769#endif
1770
1771 CALL mp_timeset(routinen, handle)
1772
1773#if defined(__parallel)
1774 CALL mpi_cart_sub(comm%handle, rdim, sub_comm%handle, ierr)
1775 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_sub @ mp_cart_sub")
1776#else
1777 mark_used(comm)
1778 mark_used(rdim)
1779 sub_comm%handle = mp_comm_default_handle
1780#endif
1781 sub_comm%ndims = count(rdim)
1782 debug_comm_count = debug_comm_count + 1
1783 CALL sub_comm%init()
1784 CALL mp_timestop(handle)
1785
1786 END SUBROUTINE mp_cart_sub
1787
1788! **************************************************************************************************
1789!> \brief wrapper to MPI_Comm_free
1790!> \param comm ...
1791! **************************************************************************************************
1792 SUBROUTINE mp_comm_free(comm)
1793
1794 CLASS(mp_comm_type), INTENT(INOUT) :: comm
1795
1796 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_free'
1797
1798 INTEGER :: handle
1799 LOGICAL :: free_comm
1800#if defined(__parallel)
1801 INTEGER :: ierr
1802#endif
1803
1804 free_comm = .true.
1805 SELECT TYPE (comm)
1806 CLASS IS (mp_para_env_type)
1807 free_comm = .false.
1808 IF (comm%ref_count <= 0) &
1809 cpabort("para_env%ref_count <= 0")
1810 comm%ref_count = comm%ref_count - 1
1811 IF (comm%ref_count <= 0) THEN
1812 free_comm = comm%owns_group
1813 END IF
1814 CLASS IS (mp_para_cart_type)
1815 free_comm = .false.
1816 IF (comm%ref_count <= 0) &
1817 cpabort("para_cart%ref_count <= 0")
1818 comm%ref_count = comm%ref_count - 1
1819 IF (comm%ref_count <= 0) THEN
1820 free_comm = comm%owns_group
1821 END IF
1822 END SELECT
1823
1824 CALL mp_timeset(routinen, handle)
1825
1826 IF (free_comm) THEN
1827#if defined(__parallel)
1828 CALL mpi_comm_free(comm%handle, ierr)
1829 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_free @ mp_comm_free")
1830#else
1831 comm%handle = mp_comm_null_handle
1832#endif
1833 debug_comm_count = debug_comm_count - 1
1834 END IF
1835
1836 SELECT TYPE (comm)
1837 CLASS IS (mp_cart_type)
1838 DEALLOCATE (comm%periodic, comm%mepos_cart, comm%num_pe_cart)
1839 END SELECT
1840
1841 CALL mp_timestop(handle)
1842
1843 END SUBROUTINE mp_comm_free
1844
1845! **************************************************************************************************
1846!> \brief check whether the environment exists
1847!> \param para_env ...
1848!> \return ...
1849! **************************************************************************************************
1850 ELEMENTAL LOGICAL FUNCTION mp_para_env_is_valid(para_env)
1851 CLASS(mp_para_env_type), INTENT(IN) :: para_env
1852
1853 mp_para_env_is_valid = para_env%ref_count > 0
1854
1855 END FUNCTION mp_para_env_is_valid
1856
1857! **************************************************************************************************
1858!> \brief increase the reference counter but ensure that you free it later
1859!> \param para_env ...
1860! **************************************************************************************************
1861 ELEMENTAL SUBROUTINE mp_para_env_retain(para_env)
1862 CLASS(mp_para_env_type), INTENT(INOUT) :: para_env
1863
1864 para_env%ref_count = para_env%ref_count + 1
1865
1866 END SUBROUTINE mp_para_env_retain
1867
1868! **************************************************************************************************
1869!> \brief check whether the given environment is valid, i.e. existent
1870!> \param cart ...
1871!> \return ...
1872! **************************************************************************************************
1873 ELEMENTAL LOGICAL FUNCTION mp_para_cart_is_valid(cart)
1874 CLASS(mp_para_cart_type), INTENT(IN) :: cart
1875
1876 mp_para_cart_is_valid = cart%ref_count > 0
1877
1878 END FUNCTION mp_para_cart_is_valid
1879
1880! **************************************************************************************************
1881!> \brief increase the reference counter, don't forget to free it later
1882!> \param cart ...
1883! **************************************************************************************************
1884 ELEMENTAL SUBROUTINE mp_para_cart_retain(cart)
1885 CLASS(mp_para_cart_type), INTENT(INOUT) :: cart
1886
1887 cart%ref_count = cart%ref_count + 1
1888
1889 END SUBROUTINE mp_para_cart_retain
1890
1891! **************************************************************************************************
1892!> \brief wrapper to MPI_Comm_dup
1893!> \param comm1 ...
1894!> \param comm2 ...
1895! **************************************************************************************************
1896 SUBROUTINE mp_comm_dup(comm1, comm2)
1897
1898 CLASS(mp_comm_type), INTENT(IN) :: comm1
1899 CLASS(mp_comm_type), INTENT(OUT) :: comm2
1900
1901 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_dup'
1902
1903 INTEGER :: handle
1904#if defined(__parallel)
1905 INTEGER :: ierr
1906#endif
1907
1908 CALL mp_timeset(routinen, handle)
1909
1910#if defined(__parallel)
1911 CALL mpi_comm_dup(comm1%handle, comm2%handle, ierr)
1912 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_dup @ mp_comm_dup")
1913#else
1914 mark_used(comm1)
1915 comm2%handle = mp_comm_default_handle
1916#endif
1917 comm2%ndims = comm1%ndims
1918 debug_comm_count = debug_comm_count + 1
1919 CALL comm2%init()
1920 CALL mp_timestop(handle)
1921
1922 END SUBROUTINE mp_comm_dup
1923
1924! **************************************************************************************************
1925!> \brief Implements a simple assignment function to overload the assignment operator
1926!> \param comm_new communicator on the r.h.s. of the assignment operator
1927!> \param comm_old communicator on the l.h.s. of the assignment operator
1928! **************************************************************************************************
1929 ELEMENTAL IMPURE SUBROUTINE mp_comm_assign(comm_new, comm_old)
1930 CLASS(mp_comm_type), INTENT(IN) :: comm_old
1931 CLASS(mp_comm_type), INTENT(OUT) :: comm_new
1932
1933 comm_new%handle = comm_old%handle
1934 comm_new%ndims = comm_old%ndims
1935 CALL comm_new%init(.false.)
1936 END SUBROUTINE
1937
1938! **************************************************************************************************
1939!> \brief check whether the local process is the source process
1940!> \param para_env ...
1941!> \return ...
1942! **************************************************************************************************
1943 ELEMENTAL LOGICAL FUNCTION mp_comm_is_source(comm)
1944 CLASS(mp_comm_type), INTENT(IN) :: comm
1945
1946 mp_comm_is_source = comm%source == comm%mepos
1947
1948 END FUNCTION mp_comm_is_source
1949
1950! **************************************************************************************************
1951!> \brief Initializes the communicator (mostly relevant for its derived classes)
1952!> \param comm ...
1953! **************************************************************************************************
1954 ELEMENTAL IMPURE SUBROUTINE mp_comm_init(comm, owns_group)
1955 CLASS(mp_comm_type), INTENT(INOUT) :: comm
1956 LOGICAL, INTENT(IN), OPTIONAL :: owns_group
1957
1958 IF (comm%handle mpi_get_comp /= mp_comm_null_handle mpi_get_comp) THEN
1959 comm%source = 0
1960 CALL comm%get_size(comm%num_pe)
1961 CALL comm%get_rank(comm%mepos)
1962 END IF
1963
1964 SELECT TYPE (comm)
1965 CLASS IS (mp_cart_type)
1966 IF (ALLOCATED(comm%periodic)) DEALLOCATE (comm%periodic)
1967 IF (ALLOCATED(comm%mepos_cart)) DEALLOCATE (comm%mepos_cart)
1968 IF (ALLOCATED(comm%num_pe_cart)) DEALLOCATE (comm%num_pe_cart)
1969
1970 associate(ndims => comm%ndims)
1971
1972 ALLOCATE (comm%periodic(ndims), comm%mepos_cart(ndims), &
1973 comm%num_pe_cart(ndims))
1974 END associate
1975
1976 comm%mepos_cart = 0
1977 comm%periodic = .false.
1978 IF (comm%handle mpi_get_comp /= mp_comm_null_handle mpi_get_comp) THEN
1979 CALL comm%get_info_cart(comm%num_pe_cart, comm%mepos_cart, &
1980 comm%periodic)
1981 END IF
1982 END SELECT
1983
1984 SELECT TYPE (comm)
1985 CLASS IS (mp_para_env_type)
1986 IF (PRESENT(owns_group)) comm%owns_group = owns_group
1987 comm%ref_count = 1
1988 CLASS IS (mp_para_cart_type)
1989 IF (PRESENT(owns_group)) comm%owns_group = owns_group
1990 comm%ref_count = 1
1991 END SELECT
1992
1993 END SUBROUTINE
1994
1995! **************************************************************************************************
1996!> \brief creates a new para environment
1997!> \param para_env the new parallel environment
1998!> \param group the id of the actual mpi_group
1999!> \par History
2000!> 08.2002 created [fawzi]
2001!> \author Fawzi Mohamed
2002! **************************************************************************************************
2003 SUBROUTINE mp_para_env_create(para_env, group)
2004 TYPE(mp_para_env_type), POINTER :: para_env
2005 CLASS(mp_comm_type), INTENT(in) :: group
2006
2007 IF (ASSOCIATED(para_env)) &
2008 cpabort("The passed para_env must not be associated!")
2009 ALLOCATE (para_env)
2010 para_env%mp_comm_type = group
2011 CALL para_env%init()
2012 END SUBROUTINE mp_para_env_create
2013
2014! **************************************************************************************************
2015!> \brief releases the para object (to be called when you don't want anymore
2016!> the shared copy of this object)
2017!> \param para_env the new group
2018!> \par History
2019!> 08.2002 created [fawzi]
2020!> \author Fawzi Mohamed
2021!> \note
2022!> to avoid circular dependencies cp_log_handling has a private copy
2023!> of this method (see cp_log_handling:my_mp_para_env_release)!
2024! **************************************************************************************************
2025 SUBROUTINE mp_para_env_release(para_env)
2026 TYPE(mp_para_env_type), POINTER :: para_env
2027
2028 IF (ASSOCIATED(para_env)) THEN
2029 CALL para_env%free()
2030 IF (.NOT. para_env%is_valid()) DEALLOCATE (para_env)
2031 END IF
2032 NULLIFY (para_env)
2033 END SUBROUTINE mp_para_env_release
2034
2035! **************************************************************************************************
2036!> \brief creates a cart (multidimensional parallel environment)
2037!> \param cart the cart environment to create
2038!> \param group the mpi communicator
2039!> \author fawzi
2040! **************************************************************************************************
2041 SUBROUTINE mp_para_cart_create(cart, group)
2042 TYPE(mp_para_cart_type), POINTER, INTENT(OUT) :: cart
2043 CLASS(mp_comm_type), INTENT(in) :: group
2044
2045 IF (ASSOCIATED(cart)) &
2046 cpabort("The passed para_cart must not be associated!")
2047 ALLOCATE (cart)
2048 cart%mp_cart_type = group
2049 CALL cart%init()
2050
2051 END SUBROUTINE mp_para_cart_create
2052
2053! **************************************************************************************************
2054!> \brief releases the given cart
2055!> \param cart the cart to release
2056!> \author fawzi
2057! **************************************************************************************************
2058 SUBROUTINE mp_para_cart_release(cart)
2059 TYPE(mp_para_cart_type), POINTER :: cart
2060
2061 IF (ASSOCIATED(cart)) THEN
2062 CALL cart%free()
2063 IF (.NOT. cart%is_valid()) DEALLOCATE (cart)
2064 END IF
2065 NULLIFY (cart)
2066 END SUBROUTINE mp_para_cart_release
2067
2068! **************************************************************************************************
2069!> \brief wrapper to MPI_Group_translate_ranks
2070!> \param comm1 ...
2071!> \param comm2 ...
2072!> \param rank ...
2073! **************************************************************************************************
2074 SUBROUTINE mp_rank_compare(comm1, comm2, rank)
2075
2076 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
2077 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rank
2078
2079 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rank_compare'
2080
2081 INTEGER :: handle
2082#if defined(__parallel)
2083 INTEGER :: i, ierr, n, n1, n2
2084 INTEGER, ALLOCATABLE, DIMENSION(:) :: rin
2085 mpi_group_type :: g1, g2
2086#endif
2087
2088 CALL mp_timeset(routinen, handle)
2089
2090 rank = 0
2091#if defined(__parallel)
2092 CALL mpi_comm_size(comm1%handle, n1, ierr)
2093 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
2094 CALL mpi_comm_size(comm2%handle, n2, ierr)
2095 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
2096 n = max(n1, n2)
2097 CALL mpi_comm_group(comm1%handle, g1, ierr)
2098 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
2099 CALL mpi_comm_group(comm2%handle, g2, ierr)
2100 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
2101 ALLOCATE (rin(0:n - 1), stat=ierr)
2102 IF (ierr /= 0) &
2103 cpabort("allocate @ mp_rank_compare")
2104 DO i = 0, n - 1
2105 rin(i) = i
2106 END DO
2107 CALL mpi_group_translate_ranks(g1, n, rin, g2, rank, ierr)
2108 IF (ierr /= 0) CALL mp_stop(ierr, &
2109 "mpi_group_translate_rank @ mp_rank_compare")
2110 CALL mpi_group_free(g1, ierr)
2111 IF (ierr /= 0) &
2112 cpabort("group_free @ mp_rank_compare")
2113 CALL mpi_group_free(g2, ierr)
2114 IF (ierr /= 0) &
2115 cpabort("group_free @ mp_rank_compare")
2116 DEALLOCATE (rin)
2117#else
2118 mark_used(comm1)
2119 mark_used(comm2)
2120#endif
2121 CALL mp_timestop(handle)
2122
2123 END SUBROUTINE mp_rank_compare
2124
2125! **************************************************************************************************
2126!> \brief wrapper to MPI_Dims_create
2127!> \param nodes ...
2128!> \param dims ...
2129! **************************************************************************************************
2130 SUBROUTINE mp_dims_create(nodes, dims)
2131
2132 INTEGER, INTENT(IN) :: nodes
2133 INTEGER, DIMENSION(:), INTENT(INOUT) :: dims
2134
2135 CHARACTER(len=*), PARAMETER :: routinen = 'mp_dims_create'
2136
2137 INTEGER :: handle, ndim
2138#if defined(__parallel)
2139 INTEGER :: ierr
2140#endif
2141
2142 CALL mp_timeset(routinen, handle)
2143
2144 ndim = SIZE(dims)
2145#if defined(__parallel)
2146 IF (any(dims == 0)) CALL mpi_dims_create(nodes, ndim, dims, ierr)
2147 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_dims_create")
2148#else
2149 dims = 1
2150 mark_used(nodes)
2151#endif
2152 CALL mp_timestop(handle)
2153
2154 END SUBROUTINE mp_dims_create
2155
2156! **************************************************************************************************
2157!> \brief wrapper to MPI_Cart_rank
2158!> \param comm ...
2159!> \param pos ...
2160!> \param rank ...
2161! **************************************************************************************************
2162 SUBROUTINE mp_cart_rank(comm, pos, rank)
2163 CLASS(mp_cart_type), INTENT(IN) :: comm
2164 INTEGER, DIMENSION(:), INTENT(IN) :: pos
2165 INTEGER, INTENT(OUT) :: rank
2166
2167 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_rank'
2168
2169 INTEGER :: handle
2170#if defined(__parallel)
2171 INTEGER :: ierr
2172#endif
2173
2174 CALL mp_timeset(routinen, handle)
2175
2176#if defined(__parallel)
2177 CALL mpi_cart_rank(comm%handle, pos, rank, ierr)
2178 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_rank @ mp_cart_rank")
2179#else
2180 rank = 0
2181 mark_used(comm)
2182 mark_used(pos)
2183#endif
2184 CALL mp_timestop(handle)
2185
2186 END SUBROUTINE mp_cart_rank
2187
2188! **************************************************************************************************
2189!> \brief waits for completion of the given request
2190!> \param request ...
2191!> \par History
2192!> 08.2003 created [f&j]
2193!> \author joost & fawzi
2194!> \note
2195!> see isendrecv
2196! **************************************************************************************************
2197 SUBROUTINE mp_wait(request)
2198 CLASS(mp_request_type), INTENT(inout) :: request
2199
2200 CHARACTER(len=*), PARAMETER :: routinen = 'mp_wait'
2201
2202 INTEGER :: handle
2203#if defined(__parallel)
2204 INTEGER :: ierr
2205#endif
2206
2207 CALL mp_timeset(routinen, handle)
2208
2209#if defined(__parallel)
2210
2211 CALL mpi_wait(request%handle, mpi_status_ignore, ierr)
2212 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_wait @ mp_wait")
2213
2214 CALL add_perf(perf_id=9, count=1)
2215#else
2216 request%handle = mp_request_null_handle
2217#endif
2218 CALL mp_timestop(handle)
2219 END SUBROUTINE mp_wait
2220
2221! **************************************************************************************************
2222!> \brief waits for completion of the given requests
2223!> \param requests ...
2224!> \par History
2225!> 08.2003 created [f&j]
2226!> \author joost & fawzi
2227!> \note
2228!> see isendrecv
2229! **************************************************************************************************
2230 SUBROUTINE mp_waitall_1(requests)
2231 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2232
2233 CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_1'
2234
2235 INTEGER :: handle
2236#if defined(__parallel)
2237 INTEGER :: count, ierr
2238#if !defined(__MPI_F08)
2239 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: status
2240#else
2241 TYPE(mpi_status), ALLOCATABLE, DIMENSION(:) :: status
2242#endif
2243#endif
2244
2245 CALL mp_timeset(routinen, handle)
2246
2247#if defined(__parallel)
2248 count = SIZE(requests)
2249#if !defined(__MPI_F08)
2250 ALLOCATE (status(mpi_status_size, count))
2251#else
2252 ALLOCATE (status(count))
2253#endif
2254 CALL mpi_waitall_internal(count, requests, status, ierr) ! MPI_STATUSES_IGNORE openmpi workaround
2255 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_1")
2256 DEALLOCATE (status)
2257 CALL add_perf(perf_id=9, count=1)
2258#else
2259 requests = mp_request_null
2260#endif
2261 CALL mp_timestop(handle)
2262 END SUBROUTINE mp_waitall_1
2263
2264! **************************************************************************************************
2265!> \brief waits for completion of the given requests
2266!> \param requests ...
2267!> \par History
2268!> 08.2003 created [f&j]
2269!> \author joost & fawzi
2270! **************************************************************************************************
2271 SUBROUTINE mp_waitall_2(requests)
2272 TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2273
2274 CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_2'
2275
2276 INTEGER :: handle
2277#if defined(__parallel)
2278 INTEGER :: count, ierr
2279#if !defined(__MPI_F08)
2280 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: status
2281#else
2282 TYPE(mpi_status), ALLOCATABLE, DIMENSION(:) :: status
2283#endif
2284#endif
2285
2286 CALL mp_timeset(routinen, handle)
2287
2288#if defined(__parallel)
2289 count = SIZE(requests)
2290#if !defined(__MPI_F08)
2291 ALLOCATE (status(mpi_status_size, count))
2292#else
2293 ALLOCATE (status(count))
2294#endif
2295
2296 CALL mpi_waitall_internal(count, requests, status, ierr) ! MPI_STATUSES_IGNORE openmpi workaround
2297 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_2")
2298 DEALLOCATE (status)
2299
2300 CALL add_perf(perf_id=9, count=1)
2301#else
2302 requests = mp_request_null
2303#endif
2304 CALL mp_timestop(handle)
2305 END SUBROUTINE mp_waitall_2
2306
2307! **************************************************************************************************
2308!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2309!> the issue is with the rank or requests
2310!> \param count ...
2311!> \param array_of_requests ...
2312!> \param array_of_statuses ...
2313!> \param ierr ...
2314!> \author Joost VandeVondele
2315! **************************************************************************************************
2316#if defined(__parallel)
2317 SUBROUTINE mpi_waitall_internal(count, array_of_requests, array_of_statuses, ierr)
2318 INTEGER, INTENT(in) :: count
2319 TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2320#if !defined(__MPI_F08)
2321 INTEGER, DIMENSION(MPI_STATUS_SIZE, count), &
2322 INTENT(out) :: array_of_statuses
2323#else
2324 TYPE(mpi_status), DIMENSION(count), &
2325 INTENT(out) :: array_of_statuses
2326#endif
2327 INTEGER, INTENT(out) :: ierr
2328
2329 INTEGER :: i
2330 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2331
2332 ALLOCATE (request_handles(count))
2333 DO i = 1, count
2334 request_handles(i) = array_of_requests(i)%handle
2335 END DO
2336
2337 CALL mpi_waitall(count, request_handles, array_of_statuses, ierr)
2338
2339 DO i = 1, count
2340 array_of_requests(i)%handle = request_handles(i)
2341 END DO
2342
2343 END SUBROUTINE mpi_waitall_internal
2344#endif
2345
2346! **************************************************************************************************
2347!> \brief waits for completion of any of the given requests
2348!> \param requests ...
2349!> \param completed ...
2350!> \par History
2351!> 09.2008 created
2352!> \author Iain Bethune (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
2353! **************************************************************************************************
2354 SUBROUTINE mp_waitany(requests, completed)
2355 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2356 INTEGER, INTENT(out) :: completed
2357
2358 CHARACTER(len=*), PARAMETER :: routinen = 'mp_waitany'
2359
2360 INTEGER :: handle
2361#if defined(__parallel)
2362 INTEGER :: count, i, ierr
2363 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2364#endif
2365
2366 CALL mp_timeset(routinen, handle)
2367
2368#if defined(__parallel)
2369 count = SIZE(requests)
2370! Convert CP2K's request_handles to the plane handle for the library
2371! (Maybe, the compiler optimizes it away)
2372 ALLOCATE (request_handles(count))
2373 DO i = 1, count
2374 request_handles(i) = requests(i)%handle
2375 END DO
2376 CALL mpi_waitany(count, request_handles, completed, mpi_status_ignore, ierr)
2377 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitany @ mp_waitany")
2378! Convert the plane handles to CP2K handles
2379 DO i = 1, count
2380 requests(i)%handle = request_handles(i)
2381 END DO
2382 CALL add_perf(perf_id=9, count=1)
2383#else
2384 requests = mp_request_null
2385 completed = 1
2386#endif
2387 CALL mp_timestop(handle)
2388 END SUBROUTINE mp_waitany
2389
2390! **************************************************************************************************
2391!> \brief Tests for completion of the given requests.
2392!> \brief We use mpi_test so that we can use a single status.
2393!> \param requests the list of requests to test
2394!> \return logical which determines if requests are complete
2395!> \par History
2396!> 3.2016 adapted to any shape [Nico Holmberg]
2397!> \author Alfio Lazzaro
2398! **************************************************************************************************
2399 FUNCTION mp_testall_tv(requests) RESULT(flag)
2400 TYPE(mp_request_type), DIMENSION(:), INTENT(INOUT) :: requests
2401 LOGICAL :: flag
2402
2403#if defined(__parallel)
2404 INTEGER :: i, ierr
2405 LOGICAL, DIMENSION(:), POINTER :: flags
2406#endif
2407
2408 flag = .true.
2409
2410#if defined(__parallel)
2411 ALLOCATE (flags(SIZE(requests)))
2412 DO i = 1, SIZE(requests)
2413 CALL mpi_test(requests(i)%handle, flags(i), mpi_status_ignore, ierr)
2414 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testall @ mp_testall_tv")
2415 flag = flag .AND. flags(i)
2416 END DO
2417 DEALLOCATE (flags)
2418#else
2419 requests = mp_request_null
2420#endif
2421 END FUNCTION mp_testall_tv
2422
2423! **************************************************************************************************
2424!> \brief Tests for completion of the given request.
2425!> \param request the request
2426!> \param flag logical which determines if the request is completed
2427!> \par History
2428!> 3.2016 created
2429!> \author Nico Holmberg
2430! **************************************************************************************************
2431 FUNCTION mp_test_1(request) RESULT(flag)
2432 CLASS(mp_request_type), INTENT(inout) :: request
2433 LOGICAL :: flag
2434
2435#if defined(__parallel)
2436 INTEGER :: ierr
2437
2438 CALL mpi_test(request%handle, flag, mpi_status_ignore, ierr)
2439 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_test @ mp_test_1")
2440#else
2441 mark_used(request)
2442 flag = .true.
2443#endif
2444 END FUNCTION mp_test_1
2445
2446! **************************************************************************************************
2447!> \brief tests for completion of the given requests
2448!> \param requests ...
2449!> \param completed ...
2450!> \param flag ...
2451!> \par History
2452!> 08.2011 created
2453!> \author Iain Bethune
2454! **************************************************************************************************
2455 SUBROUTINE mp_testany_1(requests, completed, flag)
2456 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2457 INTEGER, INTENT(out), OPTIONAL :: completed
2458 LOGICAL, INTENT(out), OPTIONAL :: flag
2459
2460#if defined(__parallel)
2461 INTEGER :: completed_l, count, ierr
2462 LOGICAL :: flag_l
2463
2464 count = SIZE(requests)
2465
2466 CALL mpi_testany_internal(count, requests, completed_l, flag_l, mpi_status_ignore, ierr)
2467 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_1 @ mp_testany")
2468
2469 IF (PRESENT(completed)) completed = completed_l
2470 IF (PRESENT(flag)) flag = flag_l
2471#else
2472 mark_used(requests)
2473 IF (PRESENT(completed)) completed = 1
2474 IF (PRESENT(flag)) flag = .true.
2475#endif
2476 END SUBROUTINE mp_testany_1
2477
2478! **************************************************************************************************
2479!> \brief tests for completion of the given requests
2480!> \param requests ...
2481!> \param completed ...
2482!> \param flag ...
2483!> \par History
2484!> 08.2011 created
2485!> \author Iain Bethune
2486! **************************************************************************************************
2487 SUBROUTINE mp_testany_2(requests, completed, flag)
2488 TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2489 INTEGER, INTENT(out), OPTIONAL :: completed
2490 LOGICAL, INTENT(out), OPTIONAL :: flag
2491
2492#if defined(__parallel)
2493 INTEGER :: completed_l, count, ierr
2494 LOGICAL :: flag_l
2495
2496 count = SIZE(requests)
2497
2498 CALL mpi_testany_internal(count, requests, completed_l, flag_l, mpi_status_ignore, ierr)
2499 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_2 @ mp_testany")
2500
2501 IF (PRESENT(completed)) completed = completed_l
2502 IF (PRESENT(flag)) flag = flag_l
2503#else
2504 mark_used(requests)
2505 IF (PRESENT(completed)) completed = 1
2506 IF (PRESENT(flag)) flag = .true.
2507#endif
2508 END SUBROUTINE mp_testany_2
2509
2510! **************************************************************************************************
2511!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2512!> the issue is with the rank or requests
2513!> \param count ...
2514!> \param array_of_requests ...
2515!> \param index ...
2516!> \param flag ...
2517!> \param status ...
2518!> \param ierr ...
2519!> \author Joost VandeVondele
2520! **************************************************************************************************
2521#if defined(__parallel)
2522 SUBROUTINE mpi_testany_internal(count, array_of_requests, index, flag, status, ierr)
2523 INTEGER, INTENT(in) :: count
2524 TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2525 INTEGER, INTENT(out) :: index
2526 LOGICAL, INTENT(out) :: flag
2527 mpi_status_type, INTENT(out) :: status
2528 INTEGER, INTENT(out) :: ierr
2529
2530 INTEGER :: i
2531 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2532
2533 ALLOCATE (request_handles(count))
2534 DO i = 1, count
2535 request_handles(i) = array_of_requests(i)%handle
2536 END DO
2537
2538 CALL mpi_testany(count, request_handles, index, flag, status, ierr)
2539
2540 DO i = 1, count
2541 array_of_requests(i)%handle = request_handles(i)
2542 END DO
2543
2544 END SUBROUTINE mpi_testany_internal
2545#endif
2546
2547! **************************************************************************************************
2548!> \brief the direct way to split a communicator each color is a sub_comm,
2549!> the rank order is according to the order in the orig comm
2550!> \param comm ...
2551!> \param sub_comm ...
2552!> \param color ...
2553!> \param key ...
2554!> \author Joost VandeVondele
2555! **************************************************************************************************
2556 SUBROUTINE mp_comm_split_direct(comm, sub_comm, color, key)
2557 CLASS(mp_comm_type), INTENT(in) :: comm
2558 CLASS(mp_comm_type), INTENT(OUT) :: sub_comm
2559 INTEGER, INTENT(in) :: color
2560 INTEGER, INTENT(in), OPTIONAL :: key
2561
2562 CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_split_direct'
2563
2564 INTEGER :: handle
2565#if defined(__parallel)
2566 INTEGER :: ierr, my_key
2567#endif
2568
2569 CALL mp_timeset(routinen, handle)
2570
2571#if defined(__parallel)
2572 my_key = 0
2573 IF (PRESENT(key)) my_key = key
2574 CALL mpi_comm_split(comm%handle, color, my_key, sub_comm%handle, ierr)
2575 IF (ierr /= mpi_success) CALL mp_stop(ierr, routinen)
2576 CALL add_perf(perf_id=10, count=1)
2577#else
2578 sub_comm%handle = mp_comm_default_handle
2579 mark_used(comm)
2580 mark_used(color)
2581 mark_used(key)
2582#endif
2583 debug_comm_count = debug_comm_count + 1
2584 CALL sub_comm%init()
2585 CALL mp_timestop(handle)
2586
2587 END SUBROUTINE mp_comm_split_direct
2588! **************************************************************************************************
2589!> \brief splits the given communicator in group in subgroups trying to organize
2590!> them in a way that the communication within each subgroup is
2591!> efficient (but not necessarily the communication between subgroups)
2592!> \param comm the mpi communicator that you want to split
2593!> \param sub_comm the communicator for the subgroup (created, needs to be freed later)
2594!> \param ngroups actual number of groups
2595!> \param group_distribution input : allocated with array with the nprocs entries (0 .. nprocs-1)
2596!> \param subgroup_min_size the minimum size of the subgroup
2597!> \param n_subgroups the number of subgroups wanted
2598!> \param group_partition n_subgroups sized array containing the number of cpus wanted per group.
2599!> should match the total number of cpus (only used if present and associated) (0..ngroups-1)
2600!> \param stride create groups using a stride (default=1) through the ranks of the comm to be split.
2601!> \par History
2602!> 10.2003 created [fawzi]
2603!> 02.2004 modified [Joost VandeVondele]
2604!> \author Fawzi Mohamed
2605!> \note
2606!> at least one of subgroup_min_size and n_subgroups is needed,
2607!> the other default to the value needed to use most processors.
2608!> if less cpus are present than needed for subgroup min size, n_subgroups,
2609!> just one comm is created that contains all cpus
2610! **************************************************************************************************
2611 SUBROUTINE mp_comm_split(comm, sub_comm, ngroups, group_distribution, &
2612 subgroup_min_size, n_subgroups, group_partition, stride)
2613 CLASS(mp_comm_type), INTENT(in) :: comm
2614 CLASS(mp_comm_type), INTENT(out) :: sub_comm
2615 INTEGER, INTENT(out) :: ngroups
2616 INTEGER, DIMENSION(0:), INTENT(INOUT) :: group_distribution
2617 INTEGER, INTENT(in), OPTIONAL :: subgroup_min_size, n_subgroups
2618 INTEGER, DIMENSION(0:), INTENT(IN), OPTIONAL :: group_partition
2619 INTEGER, OPTIONAL, INTENT(IN) :: stride
2620
2621 CHARACTER(LEN=*), PARAMETER :: routineN = 'mp_comm_split', &
2622 routinep = modulen//':'//routinen
2623
2624 INTEGER :: handle, mepos, nnodes
2625#if defined(__parallel)
2626 INTEGER :: color, i, ierr, j, k, &
2627 my_subgroup_min_size, &
2628 istride, local_stride, irank
2629 INTEGER, DIMENSION(:), ALLOCATABLE :: rank_permutation
2630#endif
2631
2632 CALL mp_timeset(routinen, handle)
2633
2634 ! actual number of groups
2635
2636 IF (.NOT. PRESENT(subgroup_min_size) .AND. .NOT. PRESENT(n_subgroups)) THEN
2637 cpabort(routinep//" missing arguments")
2638 END IF
2639 IF (PRESENT(subgroup_min_size) .AND. PRESENT(n_subgroups)) THEN
2640 cpabort(routinep//" too many arguments")
2641 END IF
2642
2643 CALL comm%get_size(nnodes)
2644 CALL comm%get_rank(mepos)
2645
2646 IF (ubound(group_distribution, 1) /= nnodes - 1) THEN
2647 cpabort(routinep//" group_distribution wrong bounds")
2648 END IF
2649
2650#if defined(__parallel)
2651 IF (PRESENT(subgroup_min_size)) THEN
2652 IF (subgroup_min_size < 0 .OR. subgroup_min_size > nnodes) THEN
2653 cpabort(routinep//" subgroup_min_size too small or too large")
2654 END IF
2655 ngroups = nnodes/subgroup_min_size
2656 my_subgroup_min_size = subgroup_min_size
2657 ELSE ! n_subgroups
2658 IF (n_subgroups <= 0) THEN
2659 cpabort(routinep//" n_subgroups too small")
2660 END IF
2661 IF (nnodes/n_subgroups > 0) THEN ! we have a least one cpu per group
2662 ngroups = n_subgroups
2663 ELSE ! well, only one group then
2664 ngroups = 1
2665 END IF
2666 my_subgroup_min_size = nnodes/ngroups
2667 END IF
2668
2669 ! rank_permutation: is a permutation of ranks, so that groups are not necessarily continuous in rank of the master group
2670 ! 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
2671 ! (by setting stride equal to the number of mpi ranks per node), or by sharing a node between two groups (stride 2).
2672 ALLOCATE (rank_permutation(0:nnodes - 1))
2673 local_stride = 1
2674 IF (PRESENT(stride)) local_stride = stride
2675 k = 0
2676 DO istride = 1, local_stride
2677 DO irank = istride - 1, nnodes - 1, local_stride
2678 rank_permutation(k) = irank
2679 k = k + 1
2680 END DO
2681 END DO
2682
2683 DO i = 0, nnodes - 1
2684 group_distribution(rank_permutation(i)) = min(i/my_subgroup_min_size, ngroups - 1)
2685 END DO
2686 ! even the user gave a partition, see if we can use it to overwrite this choice
2687 IF (PRESENT(group_partition)) THEN
2688 IF (all(group_partition > 0) .AND. (sum(group_partition) == nnodes) .AND. (ngroups == SIZE(group_partition))) THEN
2689 k = 0
2690 DO i = 0, SIZE(group_partition) - 1
2691 DO j = 1, group_partition(i)
2692 group_distribution(rank_permutation(k)) = i
2693 k = k + 1
2694 END DO
2695 END DO
2696 ELSE
2697 ! just ignore silently as we have reasonable defaults. Probably a warning would not be to bad
2698 END IF
2699 END IF
2700 color = group_distribution(mepos)
2701 CALL mpi_comm_split(comm%handle, color, 0, sub_comm%handle, ierr)
2702 IF (ierr /= mpi_success) CALL mp_stop(ierr, "in "//routinep//" split")
2703
2704 CALL add_perf(perf_id=10, count=1)
2705#else
2706 sub_comm%handle = mp_comm_default_handle
2707 group_distribution(0) = 0
2708 ngroups = 1
2709 mark_used(comm)
2710 mark_used(stride)
2711 mark_used(group_partition)
2712#endif
2713 debug_comm_count = debug_comm_count + 1
2714 CALL sub_comm%init()
2715 CALL mp_timestop(handle)
2716
2717 END SUBROUTINE mp_comm_split
2718
2719! **************************************************************************************************
2720!> \brief probes for an incoming message with any tag
2721!> \param[inout] source the source of the possible incoming message,
2722!> if MP_ANY_SOURCE it is a blocking one and return value is the source
2723!> of the next incoming message
2724!> if source is a different value it is a non-blocking probe returning
2725!> MP_ANY_SOURCE if there is no incoming message
2726!> \param[in] comm the communicator
2727!> \param[out] tag the tag of the incoming message
2728!> \author Mandes
2729! **************************************************************************************************
2730 SUBROUTINE mp_probe(source, comm, tag)
2731 INTEGER, INTENT(INOUT) :: source
2732 CLASS(mp_comm_type), INTENT(IN) :: comm
2733 INTEGER, INTENT(OUT) :: tag
2734
2735 CHARACTER(len=*), PARAMETER :: routineN = 'mp_probe'
2736
2737 INTEGER :: handle
2738#if defined(__parallel)
2739 INTEGER :: ierr
2740 mpi_status_type :: status_single
2741 LOGICAL :: flag
2742#endif
2743
2744! ---------------------------------------------------------------------------
2745
2746 CALL mp_timeset(routinen, handle)
2747
2748#if defined(__parallel)
2749 IF (source == mp_any_source) THEN
2750 CALL mpi_probe(mp_any_source, mp_any_tag, comm%handle, status_single, ierr)
2751 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_probe @ mp_probe")
2752 source = status_single mpi_status_extract(mpi_source)
2753 tag = status_single mpi_status_extract(mpi_tag)
2754 ELSE
2755 flag = .false.
2756 CALL mpi_iprobe(source, mp_any_tag, comm%handle, flag, status_single, ierr)
2757 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iprobe @ mp_probe")
2758 IF (flag .EQV. .false.) THEN
2759 source = mp_any_source
2760 tag = -1 !status_single(MPI_TAG) ! in case of flag==false status is undefined
2761 ELSE
2762 tag = status_single mpi_status_extract(mpi_tag)
2763 END IF
2764 END IF
2765#else
2766 tag = -1
2767 mark_used(comm)
2768 mark_used(source)
2769#endif
2770 CALL mp_timestop(handle)
2771 END SUBROUTINE mp_probe
2772
2773! **************************************************************************************************
2774! Here come the data routines with none of the standard data types.
2775! **************************************************************************************************
2776
2777! **************************************************************************************************
2778!> \brief ...
2779!> \param msg ...
2780!> \param source ...
2781!> \param comm ...
2782! **************************************************************************************************
2783 SUBROUTINE mp_bcast_b(msg, source, comm)
2784 LOGICAL, INTENT(INOUT) :: msg
2785 INTEGER, INTENT(IN) :: source
2786 CLASS(mp_comm_type), INTENT(IN) :: comm
2787
2788 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b'
2789
2790 INTEGER :: handle
2791#if defined(__parallel)
2792 INTEGER :: ierr, msglen
2793#endif
2794
2795 CALL mp_timeset(routinen, handle)
2796
2797#if defined(__parallel)
2798 msglen = 1
2799 CALL mpi_bcast(msg, msglen, mpi_logical, source, comm%handle, ierr)
2800 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2801 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2802#else
2803 mark_used(msg)
2804 mark_used(source)
2805 mark_used(comm)
2806#endif
2807 CALL mp_timestop(handle)
2808 END SUBROUTINE mp_bcast_b
2809
2810! **************************************************************************************************
2811!> \brief ...
2812!> \param msg ...
2813!> \param source ...
2814!> \param comm ...
2815! **************************************************************************************************
2816 SUBROUTINE mp_bcast_b_src(msg, comm)
2817 LOGICAL, INTENT(INOUT) :: msg
2818 CLASS(mp_comm_type), INTENT(IN) :: comm
2819
2820 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b_src'
2821
2822 INTEGER :: handle
2823#if defined(__parallel)
2824 INTEGER :: ierr, msglen
2825#endif
2826
2827 CALL mp_timeset(routinen, handle)
2828
2829#if defined(__parallel)
2830 msglen = 1
2831 CALL mpi_bcast(msg, msglen, mpi_logical, comm%source, comm%handle, ierr)
2832 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2833 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2834#else
2835 mark_used(msg)
2836 mark_used(comm)
2837#endif
2838 CALL mp_timestop(handle)
2839 END SUBROUTINE mp_bcast_b_src
2840
2841! **************************************************************************************************
2842!> \brief ...
2843!> \param msg ...
2844!> \param source ...
2845!> \param comm ...
2846! **************************************************************************************************
2847 SUBROUTINE mp_bcast_bv(msg, source, comm)
2848 LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2849 INTEGER, INTENT(IN) :: source
2850 CLASS(mp_comm_type), INTENT(IN) :: comm
2851
2852 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv'
2853
2854 INTEGER :: handle
2855#if defined(__parallel)
2856 INTEGER :: ierr, msglen
2857#endif
2858
2859 CALL mp_timeset(routinen, handle)
2860
2861#if defined(__parallel)
2862 msglen = SIZE(msg)
2863 CALL mpi_bcast(msg, msglen, mpi_logical, source, comm%handle, ierr)
2864 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2865 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2866#else
2867 mark_used(msg)
2868 mark_used(source)
2869 mark_used(comm)
2870#endif
2871 CALL mp_timestop(handle)
2872 END SUBROUTINE mp_bcast_bv
2873
2874! **************************************************************************************************
2875!> \brief ...
2876!> \param msg ...
2877!> \param comm ...
2878! **************************************************************************************************
2879 SUBROUTINE mp_bcast_bv_src(msg, comm)
2880 LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2881 CLASS(mp_comm_type), INTENT(IN) :: comm
2882
2883 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv_src'
2884
2885 INTEGER :: handle
2886#if defined(__parallel)
2887 INTEGER :: ierr, msglen
2888#endif
2889
2890 CALL mp_timeset(routinen, handle)
2891
2892#if defined(__parallel)
2893 msglen = SIZE(msg)
2894 CALL mpi_bcast(msg, msglen, mpi_logical, comm%source, comm%handle, ierr)
2895 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2896 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2897#else
2898 mark_used(msg)
2899 mark_used(comm)
2900#endif
2901 CALL mp_timestop(handle)
2902 END SUBROUTINE mp_bcast_bv_src
2903
2904! **************************************************************************************************
2905!> \brief Non-blocking send of logical vector data
2906!> \param msgin the input message
2907!> \param dest the destination processor
2908!> \param comm the communicator object
2909!> \param request communication request index
2910!> \param tag message tag
2911!> \par History
2912!> 3.2016 added _bv subroutine [Nico Holmberg]
2913!> \author fawzi
2914!> \note see mp_irecv_iv
2915!> \note
2916!> arrays can be pointers or assumed shape, but they must be contiguous!
2917! **************************************************************************************************
2918 SUBROUTINE mp_isend_bv(msgin, dest, comm, request, tag)
2919 LOGICAL, DIMENSION(:), INTENT(IN) :: msgin
2920 INTEGER, INTENT(IN) :: dest
2921 CLASS(mp_comm_type), INTENT(IN) :: comm
2922 TYPE(mp_request_type), INTENT(out) :: request
2923 INTEGER, INTENT(in), OPTIONAL :: tag
2924
2925 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bv'
2926
2927 INTEGER :: handle
2928#if defined(__parallel)
2929 INTEGER :: ierr, msglen, my_tag
2930 LOGICAL :: foo(1)
2931#endif
2932
2933 CALL mp_timeset(routinen, handle)
2934
2935#if defined(__parallel)
2936#if !defined(__GNUC__) || __GNUC__ >= 9
2937 cpassert(is_contiguous(msgin))
2938#endif
2939
2940 my_tag = 0
2941 IF (PRESENT(tag)) my_tag = tag
2942
2943 msglen = SIZE(msgin, 1)
2944 IF (msglen > 0) THEN
2945 CALL mpi_isend(msgin(1), msglen, mpi_logical, dest, my_tag, &
2946 comm%handle, request%handle, ierr)
2947 ELSE
2948 CALL mpi_isend(foo, msglen, mpi_logical, dest, my_tag, &
2949 comm%handle, request%handle, ierr)
2950 END IF
2951 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
2952
2953 CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2954#else
2955 cpabort("mp_isend called in non parallel case")
2956 mark_used(msgin)
2957 mark_used(dest)
2958 mark_used(comm)
2959 mark_used(tag)
2960 request = mp_request_null
2961#endif
2962 CALL mp_timestop(handle)
2963 END SUBROUTINE mp_isend_bv
2964
2965! **************************************************************************************************
2966!> \brief Non-blocking receive of logical vector data
2967!> \param msgout the received message
2968!> \param source the source processor
2969!> \param comm the communicator object
2970!> \param request communication request index
2971!> \param tag message tag
2972!> \par History
2973!> 3.2016 added _bv subroutine [Nico Holmberg]
2974!> \author fawzi
2975!> \note see mp_irecv_iv
2976!> \note
2977!> arrays can be pointers or assumed shape, but they must be contiguous!
2978! **************************************************************************************************
2979 SUBROUTINE mp_irecv_bv(msgout, source, comm, request, tag)
2980 LOGICAL, DIMENSION(:), INTENT(INOUT) :: msgout
2981 INTEGER, INTENT(IN) :: source
2982 CLASS(mp_comm_type), INTENT(IN) :: comm
2983 TYPE(mp_request_type), INTENT(out) :: request
2984 INTEGER, INTENT(in), OPTIONAL :: tag
2985
2986 CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bv'
2987
2988 INTEGER :: handle
2989#if defined(__parallel)
2990 INTEGER :: ierr, msglen, my_tag
2991 LOGICAL :: foo(1)
2992#endif
2993
2994 CALL mp_timeset(routinen, handle)
2995
2996#if defined(__parallel)
2997#if !defined(__GNUC__) || __GNUC__ >= 9
2998 cpassert(is_contiguous(msgout))
2999#endif
3000
3001 my_tag = 0
3002 IF (PRESENT(tag)) my_tag = tag
3003
3004 msglen = SIZE(msgout, 1)
3005 IF (msglen > 0) THEN
3006 CALL mpi_irecv(msgout(1), msglen, mpi_logical, source, my_tag, &
3007 comm%handle, request%handle, ierr)
3008 ELSE
3009 CALL mpi_irecv(foo, msglen, mpi_logical, source, my_tag, &
3010 comm%handle, request%handle, ierr)
3011 END IF
3012 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
3013
3014 CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
3015#else
3016 cpabort("mp_irecv called in non parallel case")
3017 mark_used(msgout)
3018 mark_used(source)
3019 mark_used(comm)
3020 mark_used(tag)
3021 request = mp_request_null
3022#endif
3023 CALL mp_timestop(handle)
3024 END SUBROUTINE mp_irecv_bv
3025
3026! **************************************************************************************************
3027!> \brief Non-blocking send of rank-3 logical data
3028!> \param msgin the input message
3029!> \param dest the destination processor
3030!> \param comm the communicator object
3031!> \param request communication request index
3032!> \param tag message tag
3033!> \par History
3034!> 2.2016 added _bm3 subroutine [Nico Holmberg]
3035!> \author fawzi
3036!> \note see mp_irecv_iv
3037!> \note
3038!> arrays can be pointers or assumed shape, but they must be contiguous!
3039! **************************************************************************************************
3040 SUBROUTINE mp_isend_bm3(msgin, dest, comm, request, tag)
3041 LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgin
3042 INTEGER, INTENT(IN) :: dest
3043 CLASS(mp_comm_type), INTENT(IN) :: comm
3044 TYPE(mp_request_type), INTENT(out) :: request
3045 INTEGER, INTENT(in), OPTIONAL :: tag
3046
3047 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bm3'
3048
3049 INTEGER :: handle
3050#if defined(__parallel)
3051 INTEGER :: ierr, msglen, my_tag
3052 LOGICAL :: foo(1)
3053#endif
3054
3055 CALL mp_timeset(routinen, handle)
3056
3057#if defined(__parallel)
3058#if !defined(__GNUC__) || __GNUC__ >= 9
3059 cpassert(is_contiguous(msgin))
3060#endif
3061
3062 my_tag = 0
3063 IF (PRESENT(tag)) my_tag = tag
3064
3065 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
3066 IF (msglen > 0) THEN
3067 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_logical, dest, my_tag, &
3068 comm%handle, request%handle, ierr)
3069 ELSE
3070 CALL mpi_isend(foo, msglen, mpi_logical, dest, my_tag, &
3071 comm%handle, request%handle, ierr)
3072 END IF
3073 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
3074
3075 CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
3076#else
3077 cpabort("mp_isend called in non parallel case")
3078 mark_used(msgin)
3079 mark_used(dest)
3080 mark_used(comm)
3081 mark_used(tag)
3082 request = mp_request_null
3083#endif
3084 CALL mp_timestop(handle)
3085 END SUBROUTINE mp_isend_bm3
3086
3087! **************************************************************************************************
3088!> \brief Non-blocking receive of rank-3 logical data
3089!> \param msgout the received message
3090!> \param source the source processor
3091!> \param comm the communicator object
3092!> \param request communication request index
3093!> \param tag message tag
3094!> \par History
3095!> 2.2016 added _bm3 subroutine [Nico Holmberg]
3096!> \author fawzi
3097!> \note see mp_irecv_iv
3098!> \note
3099!> arrays can be pointers or assumed shape, but they must be contiguous!
3100! **************************************************************************************************
3101 SUBROUTINE mp_irecv_bm3(msgout, source, comm, request, tag)
3102 LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgout
3103 INTEGER, INTENT(IN) :: source
3104 CLASS(mp_comm_type), INTENT(IN) :: comm
3105 TYPE(mp_request_type), INTENT(out) :: request
3106 INTEGER, INTENT(in), OPTIONAL :: tag
3107
3108 CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bm3'
3109
3110 INTEGER :: handle
3111#if defined(__parallel)
3112 INTEGER :: ierr, msglen, my_tag
3113 LOGICAL :: foo(1)
3114#endif
3115
3116 CALL mp_timeset(routinen, handle)
3117
3118#if defined(__parallel)
3119#if !defined(__GNUC__) || __GNUC__ >= 9
3120 cpassert(is_contiguous(msgout))
3121#endif
3122
3123 my_tag = 0
3124 IF (PRESENT(tag)) my_tag = tag
3125
3126 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
3127 IF (msglen > 0) THEN
3128 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_logical, source, my_tag, &
3129 comm%handle, request%handle, ierr)
3130 ELSE
3131 CALL mpi_irecv(foo, msglen, mpi_logical, source, my_tag, &
3132 comm%handle, request%handle, ierr)
3133 END IF
3134 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
3135
3136 CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
3137#else
3138 cpabort("mp_irecv called in non parallel case")
3139 mark_used(msgout)
3140 mark_used(source)
3141 mark_used(comm)
3142 mark_used(request)
3143 mark_used(tag)
3144 request = mp_request_null
3145#endif
3146 CALL mp_timestop(handle)
3147 END SUBROUTINE mp_irecv_bm3
3148
3149! **************************************************************************************************
3150!> \brief ...
3151!> \param msg ...
3152!> \param source ...
3153!> \param comm ...
3154! **************************************************************************************************
3155 SUBROUTINE mp_bcast_av(msg, source, comm)
3156 CHARACTER(LEN=*), INTENT(INOUT) :: msg
3157 INTEGER, INTENT(IN) :: source
3158 CLASS(mp_comm_type), INTENT(IN) :: comm
3159
3160 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av'
3161
3162 INTEGER :: handle
3163#if defined(__parallel)
3164 INTEGER :: i, ierr, msglen
3165 INTEGER, DIMENSION(:), ALLOCATABLE :: imsg
3166#endif
3167
3168 CALL mp_timeset(routinen, handle)
3169
3170#if defined(__parallel)
3171
3172 IF (comm%mepos == source) msglen = len_trim(msg)
3173
3174 CALL comm%bcast(msglen, source)
3175 ! this is a workaround to avoid problems on the T3E
3176 ! at the moment we have a data alignment error when trying to
3177 ! broadcast characters on the T3E (not always!)
3178 ! JH 19/3/99 on galileo
3179 ! CALL mpi_bcast(msg,msglen,MPI_CHARACTER,source,gid%handle,ierr)
3180 ALLOCATE (imsg(1:msglen))
3181 DO i = 1, msglen
3182 imsg(i) = ichar(msg(i:i))
3183 END DO
3184 CALL mpi_bcast(imsg, msglen, mpi_integer, source, comm%handle, ierr)
3185 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3186 msg = ""
3187 DO i = 1, msglen
3188 msg(i:i) = char(imsg(i))
3189 END DO
3190 DEALLOCATE (imsg)
3191 CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen)
3192#else
3193 mark_used(msg)
3194 mark_used(source)
3195 mark_used(comm)
3196#endif
3197 CALL mp_timestop(handle)
3198 END SUBROUTINE mp_bcast_av
3199
3200! **************************************************************************************************
3201!> \brief ...
3202!> \param msg ...
3203!> \param comm ...
3204! **************************************************************************************************
3205 SUBROUTINE mp_bcast_av_src(msg, comm)
3206 CHARACTER(LEN=*), INTENT(INOUT) :: msg
3207 CLASS(mp_comm_type), INTENT(IN) :: comm
3208
3209 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av_src'
3210
3211 INTEGER :: handle
3212#if defined(__parallel)
3213 INTEGER :: i, ierr, msglen
3214 INTEGER, DIMENSION(:), ALLOCATABLE :: imsg
3215#endif
3216
3217 CALL mp_timeset(routinen, handle)
3218
3219#if defined(__parallel)
3220
3221 IF (comm%is_source()) msglen = len_trim(msg)
3222
3223 CALL comm%bcast(msglen, comm%source)
3224 ! this is a workaround to avoid problems on the T3E
3225 ! at the moment we have a data alignment error when trying to
3226 ! broadcast characters on the T3E (not always!)
3227 ! JH 19/3/99 on galileo
3228 ! CALL mpi_bcast(msg,msglen,MPI_CHARACTER,source,gid%handle,ierr)
3229 ALLOCATE (imsg(1:msglen))
3230 DO i = 1, msglen
3231 imsg(i) = ichar(msg(i:i))
3232 END DO
3233 CALL mpi_bcast(imsg, msglen, mpi_integer, comm%source, comm%handle, ierr)
3234 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3235 msg = ""
3236 DO i = 1, msglen
3237 msg(i:i) = char(imsg(i))
3238 END DO
3239 DEALLOCATE (imsg)
3240 CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen)
3241#else
3242 mark_used(msg)
3243 mark_used(comm)
3244#endif
3245 CALL mp_timestop(handle)
3246 END SUBROUTINE mp_bcast_av_src
3247
3248! **************************************************************************************************
3249!> \brief ...
3250!> \param msg ...
3251!> \param source ...
3252!> \param comm ...
3253! **************************************************************************************************
3254 SUBROUTINE mp_bcast_am(msg, source, comm)
3255 CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3256 INTEGER, INTENT(IN) :: source
3257 CLASS(mp_comm_type), INTENT(IN) :: comm
3258
3259 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am'
3260
3261 INTEGER :: handle
3262#if defined(__parallel)
3263 INTEGER :: i, ierr, j, k, msglen, msgsiz
3264 INTEGER, ALLOCATABLE :: imsg(:), imsglen(:)
3265#endif
3266
3267 CALL mp_timeset(routinen, handle)
3268
3269#if defined(__parallel)
3270 msgsiz = SIZE(msg)
3271 ! Determine size of the minimum array of integers to broadcast the string
3272 ALLOCATE (imsglen(1:msgsiz))
3273 IF (comm%mepos == source) THEN
3274 DO j = 1, msgsiz
3275 imsglen(j) = len_trim(msg(j))
3276 END DO
3277 END IF
3278 CALL comm%bcast(imsglen, source)
3279 msglen = sum(imsglen)
3280 ! this is a workaround to avoid problems on the T3E
3281 ! at the moment we have a data alignment error when trying to
3282 ! broadcast characters on the T3E (not always!)
3283 ! JH 19/3/99 on galileo
3284 ALLOCATE (imsg(1:msglen))
3285 k = 0
3286 DO j = 1, msgsiz
3287 DO i = 1, imsglen(j)
3288 k = k + 1
3289 imsg(k) = ichar(msg(j) (i:i))
3290 END DO
3291 END DO
3292 CALL mpi_bcast(imsg, msglen, mpi_integer, source, comm%handle, ierr)
3293 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3294 msg = ""
3295 k = 0
3296 DO j = 1, msgsiz
3297 DO i = 1, imsglen(j)
3298 k = k + 1
3299 msg(j) (i:i) = char(imsg(k))
3300 END DO
3301 END DO
3302 DEALLOCATE (imsg)
3303 DEALLOCATE (imsglen)
3304 CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen*msgsiz)
3305#else
3306 mark_used(msg)
3307 mark_used(source)
3308 mark_used(comm)
3309#endif
3310 CALL mp_timestop(handle)
3311 END SUBROUTINE mp_bcast_am
3312
3313 SUBROUTINE mp_bcast_am_src(msg, comm)
3314 CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3315 CLASS(mp_comm_type), INTENT(IN) :: comm
3316
3317 CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am_src'
3318
3319 INTEGER :: handle
3320#if defined(__parallel)
3321 INTEGER :: i, ierr, j, k, msglen, msgsiz
3322 INTEGER, ALLOCATABLE :: imsg(:), imsglen(:)
3323#endif
3324
3325 CALL mp_timeset(routinen, handle)
3326
3327#if defined(__parallel)
3328 msgsiz = SIZE(msg)
3329 ! Determine size of the minimum array of integers to broadcast the string
3330 ALLOCATE (imsglen(1:msgsiz))
3331 DO j = 1, msgsiz
3332 imsglen(j) = len_trim(msg(j))
3333 END DO
3334 CALL comm%bcast(imsglen, comm%source)
3335 msglen = sum(imsglen)
3336 ! this is a workaround to avoid problems on the T3E
3337 ! at the moment we have a data alignment error when trying to
3338 ! broadcast characters on the T3E (not always!)
3339 ! JH 19/3/99 on galileo
3340 ALLOCATE (imsg(1:msglen))
3341 k = 0
3342 DO j = 1, msgsiz
3343 DO i = 1, imsglen(j)
3344 k = k + 1
3345 imsg(k) = ichar(msg(j) (i:i))
3346 END DO
3347 END DO
3348 CALL mpi_bcast(imsg, msglen, mpi_integer, comm%source, comm%handle, ierr)
3349 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3350 msg = ""
3351 k = 0
3352 DO j = 1, msgsiz
3353 DO i = 1, imsglen(j)
3354 k = k + 1
3355 msg(j) (i:i) = char(imsg(k))
3356 END DO
3357 END DO
3358 DEALLOCATE (imsg)
3359 DEALLOCATE (imsglen)
3360 CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen*msgsiz)
3361#else
3362 mark_used(msg)
3363 mark_used(comm)
3364#endif
3365 CALL mp_timestop(handle)
3366 END SUBROUTINE mp_bcast_am_src
3367
3368! **************************************************************************************************
3369!> \brief Finds the location of the minimal element in a vector.
3370!> \param[in,out] msg Find location of maximum element among these
3371!> data (input).
3372!> \param[in] comm Message passing environment identifier
3373!> \par MPI mapping
3374!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3375!> \par Invalid data types
3376!> This routine is invalid for (int_8) data!
3377! **************************************************************************************************
3378 SUBROUTINE mp_minloc_dv(msg, comm)
3379 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3380 CLASS(mp_comm_type), INTENT(IN) :: comm
3381
3382 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_dv'
3383
3384 INTEGER :: handle
3385#if defined(__parallel)
3386 INTEGER :: ierr, msglen
3387 REAL(kind=real_8), ALLOCATABLE :: res(:)
3388#endif
3389
3390 IF ("d" == "l" .AND. real_8 == int_8) THEN
3391 cpabort("Minimal location not available with long integers @ "//routinen)
3392 END IF
3393 CALL mp_timeset(routinen, handle)
3394
3395#if defined(__parallel)
3396 msglen = SIZE(msg)
3397 ALLOCATE (res(1:msglen), stat=ierr)
3398 IF (ierr /= 0) &
3399 cpabort("allocate @ "//routinen)
3400 CALL mpi_allreduce(msg, res, msglen/2, mpi_2double_precision, mpi_minloc, comm%handle, ierr)
3401 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3402 msg = res
3403 DEALLOCATE (res)
3404 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3405#else
3406 mark_used(msg)
3407 mark_used(comm)
3408#endif
3409 CALL mp_timestop(handle)
3410 END SUBROUTINE mp_minloc_dv
3411
3412! **************************************************************************************************
3413!> \brief Finds the location of the minimal element in a vector.
3414!> \param[in,out] msg Find location of maximum element among these
3415!> data (input).
3416!> \param[in] comm Message passing environment identifier
3417!> \par MPI mapping
3418!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3419!> \par Invalid data types
3420!> This routine is invalid for (int_8) data!
3421! **************************************************************************************************
3422 SUBROUTINE mp_minloc_iv(msg, comm)
3423 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3424 CLASS(mp_comm_type), INTENT(IN) :: comm
3425
3426 CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_iv'
3427
3428 INTEGER :: handle
3429#if defined(__parallel)
3430 INTEGER :: ierr, msglen
3431 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3432#endif
3433
3434 IF ("i" == "l" .AND. int_4 == int_8) THEN
3435 cpabort("Minimal location not available with long integers @ "//routinen)
3436 END IF
3437 CALL mp_timeset(routinen, handle)
3438
3439#if defined(__parallel)
3440 msglen = SIZE(msg)
3441 ALLOCATE (res(1:msglen))
3442 CALL mpi_allreduce(msg, res, msglen/2, mpi_2integer, mpi_minloc, comm%handle, ierr)
3443 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3444 msg = res
3445 DEALLOCATE (res)
3446 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3447#else
3448 mark_used(msg)
3449 mark_used(comm)
3450#endif
3451 CALL mp_timestop(handle)
3452 END SUBROUTINE mp_minloc_iv
3453
3454! **************************************************************************************************
3455!> \brief Finds the location of the minimal element in a vector.
3456!> \param[in,out] msg Find location of maximum element among these
3457!> data (input).
3458!> \param[in] comm Message passing environment identifier
3459!> \par MPI mapping
3460!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3461!> \par Invalid data types
3462!> This routine is invalid for (int_8) data!
3463! **************************************************************************************************
3464 SUBROUTINE mp_minloc_lv(msg, comm)
3465 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3466 CLASS(mp_comm_type), INTENT(IN) :: comm
3467
3468 CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_lv'
3469
3470 INTEGER :: handle
3471#if defined(__parallel)
3472 INTEGER :: ierr, msglen
3473 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3474#endif
3475
3476 IF ("l" == "l" .AND. int_8 == int_8) THEN
3477 cpabort("Minimal location not available with long integers @ "//routinen)
3478 END IF
3479 CALL mp_timeset(routinen, handle)
3480
3481#if defined(__parallel)
3482 msglen = SIZE(msg)
3483 ALLOCATE (res(1:msglen))
3484 CALL mpi_allreduce(msg, res, msglen/2, mpi_integer8, mpi_minloc, comm%handle, ierr)
3485 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3486 msg = res
3487 DEALLOCATE (res)
3488 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3489#else
3490 mark_used(msg)
3491 mark_used(comm)
3492#endif
3493 CALL mp_timestop(handle)
3494 END SUBROUTINE mp_minloc_lv
3495
3496! **************************************************************************************************
3497!> \brief Finds the location of the minimal element in a vector.
3498!> \param[in,out] msg Find location of maximum element among these
3499!> data (input).
3500!> \param[in] comm Message passing environment identifier
3501!> \par MPI mapping
3502!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3503!> \par Invalid data types
3504!> This routine is invalid for (int_8) data!
3505! **************************************************************************************************
3506 SUBROUTINE mp_minloc_rv(msg, comm)
3507 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3508 CLASS(mp_comm_type), INTENT(IN) :: comm
3509
3510 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_rv'
3511
3512 INTEGER :: handle
3513#if defined(__parallel)
3514 INTEGER :: ierr, msglen
3515 REAL(kind=real_4), ALLOCATABLE :: res(:)
3516#endif
3517
3518 IF ("r" == "l" .AND. real_4 == int_8) THEN
3519 cpabort("Minimal location not available with long integers @ "//routinen)
3520 END IF
3521 CALL mp_timeset(routinen, handle)
3522
3523#if defined(__parallel)
3524 msglen = SIZE(msg)
3525 ALLOCATE (res(1:msglen))
3526 CALL mpi_allreduce(msg, res, msglen/2, mpi_2real, mpi_minloc, comm%handle, ierr)
3527 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3528 msg = res
3529 DEALLOCATE (res)
3530 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3531#else
3532 mark_used(msg)
3533 mark_used(comm)
3534#endif
3535 CALL mp_timestop(handle)
3536 END SUBROUTINE mp_minloc_rv
3537
3538! **************************************************************************************************
3539!> \brief Finds the location of the maximal element in a vector.
3540!> \param[in,out] msg Find location of maximum element among these
3541!> data (input).
3542!> \param[in] comm Message passing environment identifier
3543!> \par MPI mapping
3544!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3545!> \par Invalid data types
3546!> This routine is invalid for (int_8) data!
3547! **************************************************************************************************
3548 SUBROUTINE mp_maxloc_dv(msg, comm)
3549 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3550 CLASS(mp_comm_type), INTENT(IN) :: comm
3551
3552 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_dv'
3553
3554 INTEGER :: handle
3555#if defined(__parallel)
3556 INTEGER :: ierr, msglen
3557 REAL(kind=real_8), ALLOCATABLE :: res(:)
3558#endif
3559
3560 IF ("d" == "l" .AND. real_8 == int_8) THEN
3561 cpabort("Maximal location not available with long integers @ "//routinen)
3562 END IF
3563 CALL mp_timeset(routinen, handle)
3564
3565#if defined(__parallel)
3566 msglen = SIZE(msg)
3567 ALLOCATE (res(1:msglen))
3568 CALL mpi_allreduce(msg, res, msglen/2, mpi_2double_precision, mpi_maxloc, comm%handle, ierr)
3569 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3570 msg = res
3571 DEALLOCATE (res)
3572 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3573#else
3574 mark_used(msg)
3575 mark_used(comm)
3576#endif
3577 CALL mp_timestop(handle)
3578 END SUBROUTINE mp_maxloc_dv
3579
3580! **************************************************************************************************
3581!> \brief Finds the location of the maximal element in a vector.
3582!> \param[in,out] msg Find location of maximum element among these
3583!> data (input).
3584!> \param[in] comm Message passing environment identifier
3585!> \par MPI mapping
3586!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3587!> \par Invalid data types
3588!> This routine is invalid for (int_8) data!
3589! **************************************************************************************************
3590 SUBROUTINE mp_maxloc_iv(msg, comm)
3591 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3592 CLASS(mp_comm_type), INTENT(IN) :: comm
3593
3594 CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_iv'
3595
3596 INTEGER :: handle
3597#if defined(__parallel)
3598 INTEGER :: ierr, msglen
3599 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3600#endif
3601
3602 IF ("i" == "l" .AND. int_4 == int_8) THEN
3603 cpabort("Maximal location not available with long integers @ "//routinen)
3604 END IF
3605 CALL mp_timeset(routinen, handle)
3606
3607#if defined(__parallel)
3608 msglen = SIZE(msg)
3609 ALLOCATE (res(1:msglen))
3610 CALL mpi_allreduce(msg, res, msglen/2, mpi_2integer, mpi_maxloc, comm%handle, ierr)
3611 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3612 msg = res
3613 DEALLOCATE (res)
3614 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3615#else
3616 mark_used(msg)
3617 mark_used(comm)
3618#endif
3619 CALL mp_timestop(handle)
3620 END SUBROUTINE mp_maxloc_iv
3621
3622! **************************************************************************************************
3623!> \brief Finds the location of the maximal element in a vector.
3624!> \param[in,out] msg Find location of maximum element among these
3625!> data (input).
3626!> \param[in] comm Message passing environment identifier
3627!> \par MPI mapping
3628!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3629!> \par Invalid data types
3630!> This routine is invalid for (int_8) data!
3631! **************************************************************************************************
3632 SUBROUTINE mp_maxloc_lv(msg, comm)
3633 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3634 CLASS(mp_comm_type), INTENT(IN) :: comm
3635
3636 CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_lv'
3637
3638 INTEGER :: handle
3639#if defined(__parallel)
3640 INTEGER :: ierr, msglen
3641 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3642#endif
3643
3644 IF ("l" == "l" .AND. int_8 == int_8) THEN
3645 cpabort("Maximal location not available with long integers @ "//routinen)
3646 END IF
3647 CALL mp_timeset(routinen, handle)
3648
3649#if defined(__parallel)
3650 msglen = SIZE(msg)
3651 ALLOCATE (res(1:msglen))
3652 CALL mpi_allreduce(msg, res, msglen/2, mpi_integer8, mpi_maxloc, comm%handle, ierr)
3653 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3654 msg = res
3655 DEALLOCATE (res)
3656 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3657#else
3658 mark_used(msg)
3659 mark_used(comm)
3660#endif
3661 CALL mp_timestop(handle)
3662 END SUBROUTINE mp_maxloc_lv
3663
3664! **************************************************************************************************
3665!> \brief Finds the location of the maximal element in a vector.
3666!> \param[in,out] msg Find location of maximum element among these
3667!> data (input).
3668!> \param[in] comm Message passing environment identifier
3669!> \par MPI mapping
3670!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3671!> \par Invalid data types
3672!> This routine is invalid for (int_8) data!
3673! **************************************************************************************************
3674 SUBROUTINE mp_maxloc_rv(msg, comm)
3675 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3676 CLASS(mp_comm_type), INTENT(IN) :: comm
3677
3678 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_rv'
3679
3680 INTEGER :: handle
3681#if defined(__parallel)
3682 INTEGER :: ierr, msglen
3683 REAL(kind=real_4), ALLOCATABLE :: res(:)
3684#endif
3685
3686 IF ("r" == "l" .AND. real_4 == int_8) THEN
3687 cpabort("Maximal location not available with long integers @ "//routinen)
3688 END IF
3689 CALL mp_timeset(routinen, handle)
3690
3691#if defined(__parallel)
3692 msglen = SIZE(msg)
3693 ALLOCATE (res(1:msglen))
3694 CALL mpi_allreduce(msg, res, msglen/2, mpi_2real, mpi_maxloc, comm%handle, ierr)
3695 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3696 msg = res
3697 DEALLOCATE (res)
3698 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3699#else
3700 mark_used(msg)
3701 mark_used(comm)
3702#endif
3703 CALL mp_timestop(handle)
3704 END SUBROUTINE mp_maxloc_rv
3705
3706! **************************************************************************************************
3707!> \brief Logical OR reduction
3708!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3709!> and resultant inclusive disjunction (output)
3710!> \param[in] comm Message passing environment identifier
3711!> \par MPI mapping
3712!> mpi_allreduce
3713! **************************************************************************************************
3714 SUBROUTINE mp_sum_b(msg, comm)
3715 LOGICAL, INTENT(INOUT) :: msg
3716 CLASS(mp_comm_type), INTENT(IN) :: comm
3717
3718 CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_b'
3719
3720 INTEGER :: handle
3721#if defined(__parallel)
3722 INTEGER :: ierr, msglen
3723#endif
3724
3725 CALL mp_timeset(routinen, handle)
3726#if defined(__parallel)
3727 msglen = 1
3728 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, ierr)
3729 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3730#else
3731 mark_used(msg)
3732 mark_used(comm)
3733#endif
3734 CALL mp_timestop(handle)
3735 END SUBROUTINE mp_sum_b
3736
3737! **************************************************************************************************
3738!> \brief Logical OR reduction
3739!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3740!> and resultant inclusive disjunction (output)
3741!> \param[in] comm Message passing environment identifier
3742!> \par MPI mapping
3743!> mpi_allreduce
3744! **************************************************************************************************
3745 SUBROUTINE mp_sum_bv(msg, comm)
3746 LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: msg
3747 CLASS(mp_comm_type), INTENT(IN) :: comm
3748
3749 CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_bv'
3750
3751 INTEGER :: handle
3752#if defined(__parallel)
3753 INTEGER :: ierr, msglen
3754#endif
3755
3756 CALL mp_timeset(routinen, handle)
3757#if defined(__parallel)
3758 msglen = SIZE(msg)
3759 IF (msglen > 0) THEN
3760 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, ierr)
3761 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3762 END IF
3763#else
3764 mark_used(msg)
3765 mark_used(comm)
3766#endif
3767 CALL mp_timestop(handle)
3768 END SUBROUTINE mp_sum_bv
3769
3770! **************************************************************************************************
3771!> \brief Logical OR reduction
3772!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3773!> and resultant inclusive disjunction (output)
3774!> \param[in] comm Message passing environment identifier
3775!> \param request ...
3776!> \par MPI mapping
3777!> mpi_allreduce
3778! **************************************************************************************************
3779 SUBROUTINE mp_isum_bv(msg, comm, request)
3780 LOGICAL, DIMENSION(:), INTENT(INOUT) :: msg
3781 CLASS(mp_comm_type), INTENT(IN) :: comm
3782 TYPE(mp_request_type), INTENT(INOUT) :: request
3783
3784 CHARACTER(len=*), PARAMETER :: routineN = 'mp_isum_bv'
3785
3786 INTEGER :: handle
3787#if defined(__parallel)
3788 INTEGER :: ierr, msglen
3789#endif
3790
3791 CALL mp_timeset(routinen, handle)
3792#if defined(__parallel)
3793 msglen = SIZE(msg)
3794#if !defined(__GNUC__) || __GNUC__ >= 9
3795 cpassert(is_contiguous(msg))
3796#endif
3797
3798 IF (msglen > 0) THEN
3799 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, request%handle, ierr)
3800 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3801 ELSE
3802 request = mp_request_null
3803 END IF
3804#else
3805 mark_used(msg)
3806 mark_used(comm)
3807 request = mp_request_null
3808#endif
3809 CALL mp_timestop(handle)
3810 END SUBROUTINE mp_isum_bv
3811
3812! **************************************************************************************************
3813!> \brief Get Version of the MPI Library (MPI 3)
3814!> \param[out] version Version of the library,
3815!> declared as CHARACTER(LEN=mp_max_library_version_string)
3816!> \param[out] resultlen Length (in printable characters) of
3817!> the result returned in version (integer)
3818! **************************************************************************************************
3819 SUBROUTINE mp_get_library_version(version, resultlen)
3820 CHARACTER(len=*), INTENT(OUT) :: version
3821 INTEGER, INTENT(OUT) :: resultlen
3822
3823#if defined(__parallel)
3824 INTEGER :: ierr
3825#endif
3826
3827 version = ''
3828
3829#if defined(__parallel)
3830 ierr = 0
3831 CALL mpi_get_library_version(version, resultlen, ierr)
3832 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_get_library_version @ mp_get_library_version")
3833#else
3834 resultlen = 0
3835#endif
3836 END SUBROUTINE mp_get_library_version
3837
3838! **************************************************************************************************
3839!> \brief Opens a file
3840!> \param[in] groupid message passing environment identifier
3841!> \param[out] fh file handle (file storage unit)
3842!> \param[in] filepath path to the file
3843!> \param amode_status access mode
3844!> \param info ...
3845!> \par MPI-I/O mapping mpi_file_open
3846!> \par STREAM-I/O mapping OPEN
3847!>
3848!> \param[in](optional) info info object
3849!> \par History
3850!> 11.2012 created [Hossein Bani-Hashemian]
3851! **************************************************************************************************
3852 SUBROUTINE mp_file_open(groupid, fh, filepath, amode_status, info)
3853 CLASS(mp_comm_type), INTENT(IN) :: groupid
3854 CLASS(mp_file_type), INTENT(OUT) :: fh
3855 CHARACTER(len=*), INTENT(IN) :: filepath
3856 INTEGER, INTENT(IN) :: amode_status
3857 TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3858
3859#if defined(__parallel)
3860 INTEGER :: ierr
3861 mpi_info_type :: my_info
3862#else
3863 CHARACTER(LEN=10) :: fstatus, fposition
3864 INTEGER :: amode, handle, istat
3865 LOGICAL :: exists, is_open
3866#endif
3867
3868#if defined(__parallel)
3869 ierr = 0
3870 my_info = mpi_info_null
3871 IF (PRESENT(info)) my_info = info%handle
3872 CALL mpi_file_open(groupid%handle, filepath, amode_status, my_info, fh%handle, ierr)
3873 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3874 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open")
3875#else
3876 mark_used(groupid)
3877 mark_used(info)
3878 amode = amode_status
3879 IF (amode > file_amode_append) THEN
3880 fposition = "APPEND"
3881 amode = amode - file_amode_append
3882 ELSE
3883 fposition = "REWIND"
3884 END IF
3885 IF ((amode == file_amode_create) .OR. &
3886 (amode == file_amode_create + file_amode_wronly) .OR. &
3887 (amode == file_amode_create + file_amode_wronly + file_amode_excl)) THEN
3888 fstatus = "UNKNOWN"
3889 ELSE
3890 fstatus = "OLD"
3891 END IF
3892 ! Get a new unit number
3893 DO handle = 1, 999
3894 INQUIRE (unit=handle, exist=exists, opened=is_open, iostat=istat)
3895 IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) EXIT
3896 END DO
3897 OPEN (unit=handle, file=filepath, status=fstatus, access="STREAM", position=fposition)
3898 fh%handle = handle
3899#endif
3900 END SUBROUTINE mp_file_open
3901
3902! **************************************************************************************************
3903!> \brief Deletes a file. Auxiliary routine to emulate 'replace' action for mp_file_open.
3904!> Only the master processor should call this routine.
3905!> \param[in] filepath path to the file
3906!> \param[in](optional) info info object
3907!> \par History
3908!> 11.2017 created [Nico Holmberg]
3909! **************************************************************************************************
3910 SUBROUTINE mp_file_delete(filepath, info)
3911 CHARACTER(len=*), INTENT(IN) :: filepath
3912 TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3913
3914#if defined(__parallel)
3915 INTEGER :: ierr
3916 mpi_info_type :: my_info
3917 LOGICAL :: exists
3918
3919 ierr = 0
3920 my_info = mpi_info_null
3921 IF (PRESENT(info)) my_info = info%handle
3922 INQUIRE (file=filepath, exist=exists)
3923 IF (exists) CALL mpi_file_delete(filepath, my_info, ierr)
3924 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete")
3925#else
3926 mark_used(filepath)
3927 mark_used(info)
3928 ! Explicit file delete not necessary, handled by subsequent call to open_file with action 'replace'
3929#endif
3930
3931 END SUBROUTINE mp_file_delete
3932
3933! **************************************************************************************************
3934!> \brief Closes a file
3935!> \param[in] fh file handle (file storage unit)
3936!> \par MPI-I/O mapping mpi_file_close
3937!> \par STREAM-I/O mapping CLOSE
3938!>
3939!> \par History
3940!> 11.2012 created [Hossein Bani-Hashemian]
3941! **************************************************************************************************
3942 SUBROUTINE mp_file_close(fh)
3943 CLASS(mp_file_type), INTENT(INOUT) :: fh
3944
3945#if defined(__parallel)
3946 INTEGER :: ierr
3947
3948 ierr = 0
3949 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3950 CALL mpi_file_close(fh%handle, ierr)
3951 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close")
3952#else
3953 CLOSE (fh%handle)
3954 fh%handle = mp_file_null_handle
3955#endif
3956 END SUBROUTINE mp_file_close
3957
3958 SUBROUTINE mp_file_assign(fh_new, fh_old)
3959 CLASS(mp_file_type), INTENT(OUT) :: fh_new
3960 CLASS(mp_file_type), INTENT(IN) :: fh_old
3961
3962 fh_new%handle = fh_old%handle
3963
3964 END SUBROUTINE
3965
3966! **************************************************************************************************
3967!> \brief Returns the file size
3968!> \param[in] fh file handle (file storage unit)
3969!> \param[out] file_size the file size
3970!> \par MPI-I/O mapping mpi_file_get_size
3971!> \par STREAM-I/O mapping INQUIRE
3972!>
3973!> \par History
3974!> 12.2012 created [Hossein Bani-Hashemian]
3975! **************************************************************************************************
3976 SUBROUTINE mp_file_get_size(fh, file_size)
3977 CLASS(mp_file_type), INTENT(IN) :: fh
3978 INTEGER(kind=file_offset), INTENT(OUT) :: file_size
3979
3980#if defined(__parallel)
3981 INTEGER :: ierr
3982#endif
3983
3984#if defined(__parallel)
3985 ierr = 0
3986 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3987 CALL mpi_file_get_size(fh%handle, file_size, ierr)
3988 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size")
3989#else
3990 INQUIRE (unit=fh%handle, size=file_size)
3991#endif
3992 END SUBROUTINE mp_file_get_size
3993
3994! **************************************************************************************************
3995!> \brief Returns the file position
3996!> \param[in] fh file handle (file storage unit)
3997!> \param[out] file_size the file position
3998!> \par MPI-I/O mapping mpi_file_get_position
3999!> \par STREAM-I/O mapping INQUIRE
4000!>
4001!> \par History
4002!> 11.2017 created [Nico Holmberg]
4003! **************************************************************************************************
4004 SUBROUTINE mp_file_get_position(fh, pos)
4005 CLASS(mp_file_type), INTENT(IN) :: fh
4006 INTEGER(kind=file_offset), INTENT(OUT) :: pos
4007
4008#if defined(__parallel)
4009 INTEGER :: ierr
4010#endif
4011
4012#if defined(__parallel)
4013 ierr = 0
4014 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4015 CALL mpi_file_get_position(fh%handle, pos, ierr)
4016 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position")
4017#else
4018 INQUIRE (unit=fh%handle, pos=pos)
4019#endif
4020 END SUBROUTINE mp_file_get_position
4021
4022! **************************************************************************************************
4023!> \brief (parallel) Blocking individual file write using explicit offsets
4024!> (serial) Unformatted stream write
4025!> \param[in] fh file handle (file storage unit)
4026!> \param[in] offset file offset (position)
4027!> \param[in] msg data to be written to the file
4028!> \param msglen ...
4029!> \par MPI-I/O mapping mpi_file_write_at
4030!> \par STREAM-I/O mapping WRITE
4031!> \param[in](optional) msglen number of the elements of data
4032! **************************************************************************************************
4033 SUBROUTINE mp_file_write_at_chv(fh, offset, msg, msglen)
4034 CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
4035 CLASS(mp_file_type), INTENT(IN) :: fh
4036 INTEGER, INTENT(IN), OPTIONAL :: msglen
4037 INTEGER(kind=file_offset), INTENT(IN) :: offset
4038
4039#if defined(__parallel)
4040 INTEGER :: ierr, msg_len
4041#endif
4042
4043#if defined(__parallel)
4044 msg_len = SIZE(msg)
4045 IF (PRESENT(msglen)) msg_len = msglen
4046 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4047 IF (ierr /= 0) &
4048 cpabort("mpi_file_write_at_chv @ mp_file_write_at_chv")
4049#else
4050 mark_used(msglen)
4051 WRITE (unit=fh%handle, pos=offset + 1) msg
4052#endif
4053 END SUBROUTINE mp_file_write_at_chv
4054
4055! **************************************************************************************************
4056!> \brief ...
4057!> \param fh ...
4058!> \param offset ...
4059!> \param msg ...
4060! **************************************************************************************************
4061 SUBROUTINE mp_file_write_at_ch(fh, offset, msg)
4062 CHARACTER(LEN=*), INTENT(IN) :: msg
4063 CLASS(mp_file_type), INTENT(IN) :: fh
4064 INTEGER(kind=file_offset), INTENT(IN) :: offset
4065
4066#if defined(__parallel)
4067 INTEGER :: ierr
4068#endif
4069
4070#if defined(__parallel)
4071 CALL mpi_file_write_at(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4072 IF (ierr /= 0) &
4073 cpabort("mpi_file_write_at_ch @ mp_file_write_at_ch")
4074#else
4075 WRITE (unit=fh%handle, pos=offset + 1) msg
4076#endif
4077 END SUBROUTINE mp_file_write_at_ch
4078
4079! **************************************************************************************************
4080!> \brief (parallel) Blocking collective file write using explicit offsets
4081!> (serial) Unformatted stream write
4082!> \param fh ...
4083!> \param offset ...
4084!> \param msg ...
4085!> \param msglen ...
4086!> \par MPI-I/O mapping mpi_file_write_at_all
4087!> \par STREAM-I/O mapping WRITE
4088! **************************************************************************************************
4089 SUBROUTINE mp_file_write_at_all_chv(fh, offset, msg, msglen)
4090 CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
4091 CLASS(mp_file_type), INTENT(IN) :: fh
4092 INTEGER, INTENT(IN), OPTIONAL :: msglen
4093 INTEGER(kind=file_offset), INTENT(IN) :: offset
4094
4095#if defined(__parallel)
4096 INTEGER :: ierr, msg_len
4097#endif
4098
4099#if defined(__parallel)
4100 msg_len = SIZE(msg)
4101 IF (PRESENT(msglen)) msg_len = msglen
4102 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4103 IF (ierr /= 0) &
4104 cpabort("mpi_file_write_at_all_chv @ mp_file_write_at_all_chv")
4105#else
4106 mark_used(msglen)
4107 WRITE (unit=fh%handle, pos=offset + 1) msg
4108#endif
4109 END SUBROUTINE mp_file_write_at_all_chv
4110
4111! **************************************************************************************************
4112!> \brief wrapper to MPI_File_write_at_all
4113!> \param fh ...
4114!> \param offset ...
4115!> \param msg ...
4116! **************************************************************************************************
4117 SUBROUTINE mp_file_write_at_all_ch(fh, offset, msg)
4118 CHARACTER(LEN=*), INTENT(IN) :: msg
4119 CLASS(mp_file_type), INTENT(IN) :: fh
4120 INTEGER(kind=file_offset), INTENT(IN) :: offset
4121
4122#if defined(__parallel)
4123 INTEGER :: ierr
4124#endif
4125
4126#if defined(__parallel)
4127 CALL mpi_file_write_at_all(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4128 IF (ierr /= 0) &
4129 cpabort("mpi_file_write_at_all_ch @ mp_file_write_at_all_ch")
4130#else
4131 WRITE (unit=fh%handle, pos=offset + 1) msg
4132#endif
4133 END SUBROUTINE mp_file_write_at_all_ch
4134
4135! **************************************************************************************************
4136!> \brief (parallel) Blocking individual file read using explicit offsets
4137!> (serial) Unformatted stream read
4138!> \param[in] fh file handle (file storage unit)
4139!> \param[in] offset file offset (position)
4140!> \param[out] msg data to be read from the file
4141!> \param msglen ...
4142!> \par MPI-I/O mapping mpi_file_read_at
4143!> \par STREAM-I/O mapping READ
4144!> \param[in](optional) msglen number of elements of data
4145! **************************************************************************************************
4146 SUBROUTINE mp_file_read_at_chv(fh, offset, msg, msglen)
4147 CHARACTER, CONTIGUOUS, INTENT(OUT) :: msg(:)
4148 CLASS(mp_file_type), INTENT(IN) :: fh
4149 INTEGER, INTENT(IN), OPTIONAL :: msglen
4150 INTEGER(kind=file_offset), INTENT(IN) :: offset
4151
4152#if defined(__parallel)
4153 INTEGER :: ierr, msg_len
4154#endif
4155
4156#if defined(__parallel)
4157 msg_len = SIZE(msg)
4158 IF (PRESENT(msglen)) msg_len = msglen
4159 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4160 IF (ierr /= 0) &
4161 cpabort("mpi_file_read_at_chv @ mp_file_read_at_chv")
4162#else
4163 mark_used(msglen)
4164 READ (unit=fh%handle, pos=offset + 1) msg
4165#endif
4166 END SUBROUTINE mp_file_read_at_chv
4167
4168! **************************************************************************************************
4169!> \brief wrapper to MPI_File_read_at
4170!> \param fh ...
4171!> \param offset ...
4172!> \param msg ...
4173! **************************************************************************************************
4174 SUBROUTINE mp_file_read_at_ch(fh, offset, msg)
4175 CHARACTER(LEN=*), INTENT(OUT) :: msg
4176 CLASS(mp_file_type), INTENT(IN) :: fh
4177 INTEGER(kind=file_offset), INTENT(IN) :: offset
4178
4179#if defined(__parallel)
4180 INTEGER :: ierr
4181#endif
4182
4183#if defined(__parallel)
4184 CALL mpi_file_read_at(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4185 IF (ierr /= 0) &
4186 cpabort("mpi_file_read_at_ch @ mp_file_read_at_ch")
4187#else
4188 READ (unit=fh%handle, pos=offset + 1) msg
4189#endif
4190 END SUBROUTINE mp_file_read_at_ch
4191
4192! **************************************************************************************************
4193!> \brief (parallel) Blocking collective file read using explicit offsets
4194!> (serial) Unformatted stream read
4195!> \param fh ...
4196!> \param offset ...
4197!> \param msg ...
4198!> \param msglen ...
4199!> \par MPI-I/O mapping mpi_file_read_at_all
4200!> \par STREAM-I/O mapping READ
4201! **************************************************************************************************
4202 SUBROUTINE mp_file_read_at_all_chv(fh, offset, msg, msglen)
4203 CHARACTER, INTENT(OUT) :: msg(:)
4204 CLASS(mp_file_type), INTENT(IN) :: fh
4205 INTEGER, INTENT(IN), OPTIONAL :: msglen
4206 INTEGER(kind=file_offset), INTENT(IN) :: offset
4207
4208#if defined(__parallel)
4209 INTEGER :: ierr, msg_len
4210#endif
4211
4212#if defined(__parallel)
4213 msg_len = SIZE(msg)
4214 IF (PRESENT(msglen)) msg_len = msglen
4215 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4216 IF (ierr /= 0) &
4217 cpabort("mpi_file_read_at_all_chv @ mp_file_read_at_all_chv")
4218#else
4219 mark_used(msglen)
4220 READ (unit=fh%handle, pos=offset + 1) msg
4221#endif
4222 END SUBROUTINE mp_file_read_at_all_chv
4223
4224! **************************************************************************************************
4225!> \brief wrapper to MPI_File_read_at_all
4226!> \param fh ...
4227!> \param offset ...
4228!> \param msg ...
4229! **************************************************************************************************
4230 SUBROUTINE mp_file_read_at_all_ch(fh, offset, msg)
4231 CHARACTER(LEN=*), INTENT(OUT) :: msg
4232 CLASS(mp_file_type), INTENT(IN) :: fh
4233 INTEGER(kind=file_offset), INTENT(IN) :: offset
4234
4235#if defined(__parallel)
4236 INTEGER :: ierr
4237#endif
4238
4239#if defined(__parallel)
4240 CALL mpi_file_read_at_all(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4241 IF (ierr /= 0) &
4242 cpabort("mpi_file_read_at_all_ch @ mp_file_read_at_all_ch")
4243#else
4244 READ (unit=fh%handle, pos=offset + 1) msg
4245#endif
4246 END SUBROUTINE mp_file_read_at_all_ch
4247
4248! **************************************************************************************************
4249!> \brief Returns the size of a data type in bytes
4250!> \param[in] type_descriptor data type
4251!> \param[out] type_size size of the data type
4252!> \par MPI mapping
4253!> mpi_type_size
4254!>
4255! **************************************************************************************************
4256 SUBROUTINE mp_type_size(type_descriptor, type_size)
4257 TYPE(mp_type_descriptor_type), INTENT(IN) :: type_descriptor
4258 INTEGER, INTENT(OUT) :: type_size
4259
4260#if defined(__parallel)
4261 INTEGER :: ierr
4262
4263 ierr = 0
4264 CALL mpi_type_size(type_descriptor%type_handle, type_size, ierr)
4265 IF (ierr /= 0) &
4266 cpabort("mpi_type_size failed @ mp_type_size")
4267#else
4268 SELECT CASE (type_descriptor%type_handle)
4269 CASE (1)
4270 type_size = real_4_size
4271 CASE (3)
4272 type_size = real_8_size
4273 CASE (5)
4274 type_size = 2*real_4_size
4275 CASE (7)
4276 type_size = 2*real_8_size
4277 END SELECT
4278#endif
4279 END SUBROUTINE mp_type_size
4280
4281! **************************************************************************************************
4282!> \brief wrapper to MPI_Type_create_struct
4283!> \param subtypes ...
4284!> \param vector_descriptor ...
4285!> \param index_descriptor ...
4286!> \return ...
4287! **************************************************************************************************
4288 FUNCTION mp_type_make_struct(subtypes, &
4289 vector_descriptor, index_descriptor) &
4290 result(type_descriptor)
4291 TYPE(mp_type_descriptor_type), &
4292 DIMENSION(:), INTENT(IN) :: subtypes
4293 INTEGER, DIMENSION(2), INTENT(IN), &
4294 OPTIONAL :: vector_descriptor
4295 TYPE(mp_indexing_meta_type), &
4296 INTENT(IN), OPTIONAL :: index_descriptor
4297 TYPE(mp_type_descriptor_type) :: type_descriptor
4298
4299 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_struct'
4300
4301 INTEGER :: i, n
4302 INTEGER, ALLOCATABLE, DIMENSION(:) :: lengths
4303#if defined(__parallel)
4304 INTEGER :: ierr
4305 INTEGER(kind=mpi_address_kind), &
4306 ALLOCATABLE, DIMENSION(:) :: displacements
4307#endif
4308 mpi_data_type, ALLOCATABLE, DIMENSION(:) :: old_types
4309
4310 n = SIZE(subtypes)
4311 type_descriptor%length = 1
4312#if defined(__parallel)
4313 ierr = 0
4314 CALL mpi_get_address(mpi_bottom, type_descriptor%base, ierr)
4315 IF (ierr /= 0) &
4316 cpabort("MPI_get_address @ "//routinen)
4317 ALLOCATE (displacements(n))
4318#endif
4319 type_descriptor%vector_descriptor(1:2) = 1
4320 type_descriptor%has_indexing = .false.
4321 ALLOCATE (type_descriptor%subtype(n))
4322 type_descriptor%subtype(:) = subtypes(:)
4323 ALLOCATE (lengths(n), old_types(n))
4324 DO i = 1, SIZE(subtypes)
4325#if defined(__parallel)
4326 displacements(i) = subtypes(i)%base
4327#endif
4328 old_types(i) = subtypes(i)%type_handle
4329 lengths(i) = subtypes(i)%length
4330 END DO
4331#if defined(__parallel)
4332 CALL mpi_type_create_struct(n, &
4333 lengths, displacements, old_types, &
4334 type_descriptor%type_handle, ierr)
4335 IF (ierr /= 0) &
4336 cpabort("MPI_Type_create_struct @ "//routinen)
4337 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4338 IF (ierr /= 0) &
4339 cpabort("MPI_Type_commit @ "//routinen)
4340#endif
4341 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
4342 cpabort(routinen//" Vectors and indices NYI")
4343 END IF
4344 END FUNCTION mp_type_make_struct
4345
4346! **************************************************************************************************
4347!> \brief wrapper to MPI_Type_free
4348!> \param type_descriptor ...
4349! **************************************************************************************************
4350 RECURSIVE SUBROUTINE mp_type_free_m(type_descriptor)
4351 TYPE(mp_type_descriptor_type), INTENT(inout) :: type_descriptor
4352
4353 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_free_m'
4354
4355 INTEGER :: handle, i
4356#if defined(__parallel)
4357 INTEGER :: ierr
4358#endif
4359
4360 CALL mp_timeset(routinen, handle)
4361
4362 ! If the subtype is associated, then it's a user-defined data type.
4363
4364 IF (ASSOCIATED(type_descriptor%subtype)) THEN
4365 DO i = 1, SIZE(type_descriptor%subtype)
4366 CALL mp_type_free_m(type_descriptor%subtype(i))
4367 END DO
4368 DEALLOCATE (type_descriptor%subtype)
4369 END IF
4370#if defined(__parallel)
4371 ierr = 0
4372 CALL mpi_type_free(type_descriptor%type_handle, ierr)
4373 IF (ierr /= 0) &
4374 cpabort("MPI_Type_free @ "//routinen)
4375#endif
4376
4377 CALL mp_timestop(handle)
4378
4379 END SUBROUTINE mp_type_free_m
4380
4381! **************************************************************************************************
4382!> \brief ...
4383!> \param type_descriptors ...
4384! **************************************************************************************************
4385 SUBROUTINE mp_type_free_v(type_descriptors)
4386 TYPE(mp_type_descriptor_type), DIMENSION(:), &
4387 INTENT(inout) :: type_descriptors
4388
4389 INTEGER :: i
4390
4391 DO i = 1, SIZE(type_descriptors)
4392 CALL mp_type_free(type_descriptors(i))
4393 END DO
4394
4395 END SUBROUTINE mp_type_free_v
4396
4397! **************************************************************************************************
4398!> \brief Creates an indexed MPI type for arrays of strings using bytes for spacing (hindexed type)
4399!> \param count number of array blocks to read
4400!> \param lengths lengths of each array block
4401!> \param displs byte offsets for array blocks
4402!> \return container holding the created type
4403!> \author Nico Holmberg [05.2017]
4404! **************************************************************************************************
4405 FUNCTION mp_file_type_hindexed_make_chv(count, lengths, displs) &
4406 result(type_descriptor)
4407 INTEGER, INTENT(IN) :: count
4408 INTEGER, DIMENSION(1:count), &
4409 INTENT(IN), TARGET :: lengths
4410 INTEGER(kind=file_offset), &
4411 DIMENSION(1:count), INTENT(in), TARGET :: displs
4412 TYPE(mp_file_descriptor_type) :: type_descriptor
4413
4414 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_hindexed_make_chv'
4415
4416 INTEGER :: ierr, handle
4417
4418 ierr = 0
4419 CALL mp_timeset(routinen, handle)
4420
4421#if defined(__parallel)
4422 CALL mpi_type_create_hindexed(count, lengths, int(displs, kind=address_kind), mpi_character, &
4423 type_descriptor%type_handle, ierr)
4424 IF (ierr /= 0) &
4425 cpabort("MPI_Type_create_hindexed @ "//routinen)
4426 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4427 IF (ierr /= 0) &
4428 cpabort("MPI_Type_commit @ "//routinen)
4429#else
4430 type_descriptor%type_handle = 68
4431#endif
4432 type_descriptor%length = count
4433 type_descriptor%has_indexing = .true.
4434 type_descriptor%index_descriptor%index => lengths
4435 type_descriptor%index_descriptor%chunks => displs
4436
4437 CALL mp_timestop(handle)
4438
4439 END FUNCTION mp_file_type_hindexed_make_chv
4440
4441! **************************************************************************************************
4442!> \brief Uses a previously created indexed MPI character type to tell the MPI processes
4443!> how to partition (set_view) an opened file
4444!> \param fh the file handle associated with the input file
4445!> \param offset global offset determining where the relevant data begins
4446!> \param type_descriptor container for the MPI type
4447!> \author Nico Holmberg [05.2017]
4448! **************************************************************************************************
4449 SUBROUTINE mp_file_type_set_view_chv(fh, offset, type_descriptor)
4450 TYPE(mp_file_type), INTENT(IN) :: fh
4451 INTEGER(kind=file_offset), INTENT(IN) :: offset
4452 TYPE(mp_file_descriptor_type) :: type_descriptor
4453
4454 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_set_view_chv'
4455
4456 INTEGER :: handle
4457#if defined(__parallel)
4458 INTEGER :: ierr
4459#endif
4460
4461 CALL mp_timeset(routinen, handle)
4462
4463#if defined(__parallel)
4464 ierr = 0
4465 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4466 CALL mpi_file_set_view(fh%handle, offset, mpi_character, &
4467 type_descriptor%type_handle, "native", mpi_info_null, ierr)
4468 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view")
4469#else
4470 ! Uses absolute offsets stored in mp_file_descriptor_type
4471 mark_used(fh)
4472 mark_used(offset)
4473 mark_used(type_descriptor)
4474#endif
4475
4476 CALL mp_timestop(handle)
4477
4478 END SUBROUTINE mp_file_type_set_view_chv
4479
4480! **************************************************************************************************
4481!> \brief (parallel) Collective, blocking read of a character array from a file. File access pattern
4482! determined by a previously set file view.
4483!> (serial) Unformatted stream read using explicit offsets
4484!> \param fh the file handle associated with the input file
4485!> \param msglen the message length of an individual vector component
4486!> \param ndims the number of vector components
4487!> \param buffer the buffer where the data is placed
4488!> \param type_descriptor container for the MPI type
4489!> \author Nico Holmberg [05.2017]
4490! **************************************************************************************************
4491 SUBROUTINE mp_file_read_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4492 CLASS(mp_file_type), INTENT(IN) :: fh
4493 INTEGER, INTENT(IN) :: msglen
4494 INTEGER, INTENT(IN) :: ndims
4495 CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(INOUT) :: buffer
4496 TYPE(mp_file_descriptor_type), &
4497 INTENT(IN), OPTIONAL :: type_descriptor
4498
4499 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_read_all_chv'
4500
4501 INTEGER :: handle
4502#if defined(__parallel)
4503 INTEGER:: ierr
4504#else
4505 INTEGER :: i
4506#endif
4507
4508 CALL mp_timeset(routinen, handle)
4509
4510#if defined(__parallel)
4511 ierr = 0
4512 mark_used(type_descriptor)
4513 CALL mpi_file_read_all(fh%handle, buffer, ndims*msglen, mpi_character, mpi_status_ignore, ierr)
4514 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all")
4515 CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4516#else
4517 mark_used(msglen)
4518 mark_used(ndims)
4519 IF (.NOT. PRESENT(type_descriptor)) &
4520 CALL cp_abort(__location__, &
4521 "Container for mp_file_descriptor_type must be present in serial call.")
4522 IF (.NOT. type_descriptor%has_indexing) &
4523 CALL cp_abort(__location__, &
4524 "File view has not been set in mp_file_descriptor_type.")
4525 ! Use explicit offsets
4526 DO i = 1, ndims
4527 READ (fh%handle, pos=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4528 END DO
4529#endif
4530
4531 CALL mp_timestop(handle)
4532
4533 END SUBROUTINE mp_file_read_all_chv
4534
4535! **************************************************************************************************
4536!> \brief (parallel) Collective, blocking write of a character array to a file. File access pattern
4537! determined by a previously set file view.
4538!> (serial) Unformatted stream write using explicit offsets
4539!> \param fh the file handle associated with the output file
4540!> \param msglen the message length of an individual vector component
4541!> \param ndims the number of vector components
4542!> \param buffer the buffer where the data is placed
4543!> \param type_descriptor container for the MPI type
4544!> \author Nico Holmberg [05.2017]
4545! **************************************************************************************************
4546 SUBROUTINE mp_file_write_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4547 CLASS(mp_file_type), INTENT(IN) :: fh
4548 INTEGER, INTENT(IN) :: msglen
4549 INTEGER, INTENT(IN) :: ndims
4550 CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(IN) :: buffer
4551 TYPE(mp_file_descriptor_type), &
4552 INTENT(IN), OPTIONAL :: type_descriptor
4553
4554 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_write_all_chv'
4555
4556 INTEGER :: handle
4557#if defined(__parallel)
4558 INTEGER :: ierr
4559#else
4560 INTEGER :: i
4561#endif
4562
4563 CALL mp_timeset(routinen, handle)
4564
4565#if defined(__parallel)
4566 mark_used(type_descriptor)
4567 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4568 CALL mpi_file_write_all(fh%handle, buffer, ndims*msglen, mpi_character, mpi_status_ignore, ierr)
4569 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all")
4570 CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4571#else
4572 mark_used(msglen)
4573 mark_used(ndims)
4574 IF (.NOT. PRESENT(type_descriptor)) &
4575 CALL cp_abort(__location__, &
4576 "Container for mp_file_descriptor_type must be present in serial call.")
4577 IF (.NOT. type_descriptor%has_indexing) &
4578 CALL cp_abort(__location__, &
4579 "File view has not been set in mp_file_descriptor_type.")
4580 ! Use explicit offsets
4581 DO i = 1, ndims
4582 WRITE (fh%handle, pos=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4583 END DO
4584#endif
4585
4586 CALL mp_timestop(handle)
4587
4588 END SUBROUTINE mp_file_write_all_chv
4589
4590! **************************************************************************************************
4591!> \brief Releases the type used for MPI I/O
4592!> \param type_descriptor the container for the MPI type
4593!> \author Nico Holmberg [05.2017]
4594! **************************************************************************************************
4595 SUBROUTINE mp_file_type_free(type_descriptor)
4596 TYPE(mp_file_descriptor_type) :: type_descriptor
4597
4598 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_type_free'
4599
4600 INTEGER :: handle
4601#if defined(__parallel)
4602 INTEGER :: ierr
4603#endif
4604
4605 CALL mp_timeset(routinen, handle)
4606
4607#if defined(__parallel)
4608 CALL mpi_type_free(type_descriptor%type_handle, ierr)
4609 IF (ierr /= 0) &
4610 cpabort("MPI_Type_free @ "//routinen)
4611#endif
4612#if defined(__parallel) && defined(__MPI_F08)
4613 type_descriptor%type_handle%mpi_val = -1
4614#else
4615 type_descriptor%type_handle = -1
4616#endif
4617 type_descriptor%length = -1
4618 IF (type_descriptor%has_indexing) THEN
4619 NULLIFY (type_descriptor%index_descriptor%index)
4620 NULLIFY (type_descriptor%index_descriptor%chunks)
4621 type_descriptor%has_indexing = .false.
4622 END IF
4623
4624 CALL mp_timestop(handle)
4625
4626 END SUBROUTINE mp_file_type_free
4627
4628! **************************************************************************************************
4629!> \brief (parallel) Utility routine to determine MPI file access mode based on variables
4630! that in the serial case would get passed to the intrinsic OPEN
4631!> (serial) No action
4632!> \param mpi_io flag that determines if MPI I/O will actually be used
4633!> \param replace flag that indicates whether file needs to be deleted prior to opening it
4634!> \param amode the MPI I/O access mode
4635!> \param form formatted or unformatted data?
4636!> \param action the variable that determines what to do with file
4637!> \param status the status flag:
4638!> \param position should the file be appended or rewound
4639!> \author Nico Holmberg [11.2017]
4640! **************************************************************************************************
4641 SUBROUTINE mp_file_get_amode(mpi_io, replace, amode, form, action, status, position)
4642 LOGICAL, INTENT(INOUT) :: mpi_io, replace
4643 INTEGER, INTENT(OUT) :: amode
4644 CHARACTER(len=*), INTENT(IN) :: form, action, status, position
4645
4646 amode = -1
4647#if defined(__parallel)
4648 ! Disable mpi io for unformatted access
4649 SELECT CASE (form)
4650 CASE ("FORMATTED")
4651 ! Do nothing
4652 CASE ("UNFORMATTED")
4653 mpi_io = .false.
4654 CASE DEFAULT
4655 cpabort("Unknown MPI file form requested.")
4656 END SELECT
4657 ! Determine file access mode (limited set of allowed choices)
4658 SELECT CASE (action)
4659 CASE ("WRITE")
4660 amode = file_amode_wronly
4661 SELECT CASE (status)
4662 CASE ("NEW")
4663 ! Try to open new file for writing, crash if file already exists
4664 amode = amode + file_amode_create + file_amode_excl
4665 CASE ("UNKNOWN")
4666 ! Open file for writing and create it if file does not exist
4667 amode = amode + file_amode_create
4668 SELECT CASE (position)
4669 CASE ("APPEND")
4670 ! Append existing file
4671 amode = amode + file_amode_append
4672 CASE ("REWIND", "ASIS")
4673 ! Do nothing
4674 CASE DEFAULT
4675 cpabort("Unknown MPI file position requested.")
4676 END SELECT
4677 CASE ("OLD")
4678 SELECT CASE (position)
4679 CASE ("APPEND")
4680 ! Append existing file
4681 amode = amode + file_amode_append
4682 CASE ("REWIND", "ASIS")
4683 ! Do nothing
4684 CASE DEFAULT
4685 cpabort("Unknown MPI file position requested.")
4686 END SELECT
4687 CASE ("REPLACE")
4688 ! Overwrite existing file. Must delete existing file first
4689 amode = amode + file_amode_create
4690 replace = .true.
4691 CASE ("SCRATCH")
4692 ! Disable
4693 mpi_io = .false.
4694 CASE DEFAULT
4695 cpabort("Unknown MPI file status requested.")
4696 END SELECT
4697 CASE ("READ")
4698 amode = file_amode_rdonly
4699 SELECT CASE (status)
4700 CASE ("NEW")
4701 cpabort("Cannot read from 'NEW' file.")
4702 CASE ("REPLACE")
4703 cpabort("Illegal status 'REPLACE' for read.")
4704 CASE ("UNKNOWN", "OLD")
4705 ! Do nothing
4706 CASE ("SCRATCH")
4707 ! Disable
4708 mpi_io = .false.
4709 CASE DEFAULT
4710 cpabort("Unknown MPI file status requested.")
4711 END SELECT
4712 CASE ("READWRITE")
4713 amode = file_amode_rdwr
4714 SELECT CASE (status)
4715 CASE ("NEW")
4716 ! Try to open new file, crash if file already exists
4717 amode = amode + file_amode_create + file_amode_excl
4718 CASE ("UNKNOWN")
4719 ! Open file and create it if file does not exist
4720 amode = amode + file_amode_create
4721 SELECT CASE (position)
4722 CASE ("APPEND")
4723 ! Append existing file
4724 amode = amode + file_amode_append
4725 CASE ("REWIND", "ASIS")
4726 ! Do nothing
4727 CASE DEFAULT
4728 cpabort("Unknown MPI file position requested.")
4729 END SELECT
4730 CASE ("OLD")
4731 SELECT CASE (position)
4732 CASE ("APPEND")
4733 ! Append existing file
4734 amode = amode + file_amode_append
4735 CASE ("REWIND", "ASIS")
4736 ! Do nothing
4737 CASE DEFAULT
4738 cpabort("Unknown MPI file position requested.")
4739 END SELECT
4740 CASE ("REPLACE")
4741 ! Overwrite existing file. Must delete existing file first
4742 amode = amode + file_amode_create
4743 replace = .true.
4744 CASE ("SCRATCH")
4745 ! Disable
4746 mpi_io = .false.
4747 CASE DEFAULT
4748 cpabort("Unknown MPI file status requested.")
4749 END SELECT
4750 CASE DEFAULT
4751 cpabort("Unknown MPI file action requested.")
4752 END SELECT
4753#else
4754 mark_used(replace)
4755 mark_used(form)
4756 mark_used(position)
4757 mark_used(status)
4758 mark_used(action)
4759 mpi_io = .false.
4760#endif
4761
4762 END SUBROUTINE mp_file_get_amode
4763
4764! **************************************************************************************************
4765!> \brief Non-blocking send of custom type
4766!> \param msgin ...
4767!> \param dest ...
4768!> \param comm ...
4769!> \param request ...
4770!> \param tag ...
4771! **************************************************************************************************
4772 SUBROUTINE mp_isend_custom(msgin, dest, comm, request, tag)
4773 TYPE(mp_type_descriptor_type), INTENT(IN) :: msgin
4774 INTEGER, INTENT(IN) :: dest
4775 CLASS(mp_comm_type), INTENT(IN) :: comm
4776 TYPE(mp_request_type), INTENT(out) :: request
4777 INTEGER, INTENT(in), OPTIONAL :: tag
4778
4779 INTEGER :: ierr, my_tag
4780
4781 ierr = 0
4782 my_tag = 0
4783
4784#if defined(__parallel)
4785 IF (PRESENT(tag)) my_tag = tag
4786
4787 CALL mpi_isend(mpi_bottom, 1, msgin%type_handle, dest, my_tag, &
4788 comm%handle, request%handle, ierr)
4789 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ mp_isend_custom")
4790#else
4791 mark_used(msgin)
4792 mark_used(dest)
4793 mark_used(comm)
4794 mark_used(tag)
4795 ierr = 1
4796 request = mp_request_null
4797 CALL mp_stop(ierr, "mp_isend called in non parallel case")
4798#endif
4799 END SUBROUTINE mp_isend_custom
4800
4801! **************************************************************************************************
4802!> \brief Non-blocking receive of vector data
4803!> \param msgout ...
4804!> \param source ...
4805!> \param comm ...
4806!> \param request ...
4807!> \param tag ...
4808! **************************************************************************************************
4809 SUBROUTINE mp_irecv_custom(msgout, source, comm, request, tag)
4810 TYPE(mp_type_descriptor_type), INTENT(INOUT) :: msgout
4811 INTEGER, INTENT(IN) :: source
4812 CLASS(mp_comm_type), INTENT(IN) :: comm
4813 TYPE(mp_request_type), INTENT(out) :: request
4814 INTEGER, INTENT(in), OPTIONAL :: tag
4815
4816 INTEGER :: ierr, my_tag
4817
4818 ierr = 0
4819 my_tag = 0
4820
4821#if defined(__parallel)
4822 IF (PRESENT(tag)) my_tag = tag
4823
4824 CALL mpi_irecv(mpi_bottom, 1, msgout%type_handle, source, my_tag, &
4825 comm%handle, request%handle, ierr)
4826 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ mp_irecv_custom")
4827#else
4828 mark_used(msgout)
4829 mark_used(source)
4830 mark_used(comm)
4831 mark_used(tag)
4832 ierr = 1
4833 request = mp_request_null
4834 cpabort("mp_irecv called in non parallel case")
4835#endif
4836 END SUBROUTINE mp_irecv_custom
4837
4838! **************************************************************************************************
4839!> \brief Window free
4840!> \param win ...
4841! **************************************************************************************************
4842 SUBROUTINE mp_win_free(win)
4843 CLASS(mp_win_type), INTENT(INOUT) :: win
4844
4845 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_free'
4846
4847 INTEGER :: handle
4848#if defined(__parallel)
4849 INTEGER :: ierr
4850#endif
4851
4852 CALL mp_timeset(routinen, handle)
4853
4854#if defined(__parallel)
4855 ierr = 0
4856 CALL mpi_win_free(win%handle, ierr)
4857 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_free @ "//routinen)
4858
4859 CALL add_perf(perf_id=21, count=1)
4860#else
4861 win%handle = mp_win_null_handle
4862#endif
4863 CALL mp_timestop(handle)
4864 END SUBROUTINE mp_win_free
4865
4866 SUBROUTINE mp_win_assign(win_new, win_old)
4867 CLASS(mp_win_type), INTENT(OUT) :: win_new
4868 CLASS(mp_win_type), INTENT(IN) :: win_old
4869
4870 win_new%handle = win_old%handle
4871
4872 END SUBROUTINE mp_win_assign
4873
4874! **************************************************************************************************
4875!> \brief Window flush
4876!> \param win ...
4877! **************************************************************************************************
4878 SUBROUTINE mp_win_flush_all(win)
4879 CLASS(mp_win_type), INTENT(IN) :: win
4880
4881 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_flush_all'
4882
4883 INTEGER :: handle, ierr
4884
4885 ierr = 0
4886 CALL mp_timeset(routinen, handle)
4887
4888#if defined(__parallel)
4889 CALL mpi_win_flush_all(win%handle, ierr)
4890 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_flush_all @ "//routinen)
4891#else
4892 mark_used(win)
4893#endif
4894 CALL mp_timestop(handle)
4895 END SUBROUTINE mp_win_flush_all
4896
4897! **************************************************************************************************
4898!> \brief Window lock
4899!> \param win ...
4900! **************************************************************************************************
4901 SUBROUTINE mp_win_lock_all(win)
4902 CLASS(mp_win_type), INTENT(IN) :: win
4903
4904 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_lock_all'
4905
4906 INTEGER :: handle, ierr
4907
4908 ierr = 0
4909 CALL mp_timeset(routinen, handle)
4910
4911#if defined(__parallel)
4912
4913 CALL mpi_win_lock_all(mpi_mode_nocheck, win%handle, ierr)
4914 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_lock_all @ "//routinen)
4915
4916 CALL add_perf(perf_id=19, count=1)
4917#else
4918 mark_used(win)
4919#endif
4920 CALL mp_timestop(handle)
4921 END SUBROUTINE mp_win_lock_all
4922
4923! **************************************************************************************************
4924!> \brief Window lock
4925!> \param win ...
4926! **************************************************************************************************
4927 SUBROUTINE mp_win_unlock_all(win)
4928 CLASS(mp_win_type), INTENT(IN) :: win
4929
4930 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_unlock_all'
4931
4932 INTEGER :: handle, ierr
4933
4934 ierr = 0
4935 CALL mp_timeset(routinen, handle)
4936
4937#if defined(__parallel)
4938
4939 CALL mpi_win_unlock_all(win%handle, ierr)
4940 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_unlock_all @ "//routinen)
4941
4942 CALL add_perf(perf_id=19, count=1)
4943#else
4944 mark_used(win)
4945#endif
4946 CALL mp_timestop(handle)
4947 END SUBROUTINE mp_win_unlock_all
4948
4949! **************************************************************************************************
4950!> \brief Starts a timer region
4951!> \param routineN ...
4952!> \param handle ...
4953! **************************************************************************************************
4954 SUBROUTINE mp_timeset(routineN, handle)
4955 CHARACTER(len=*), INTENT(IN) :: routinen
4956 INTEGER, INTENT(OUT) :: handle
4957
4958 IF (mp_collect_timings) &
4959 CALL timeset(routinen, handle)
4960 END SUBROUTINE mp_timeset
4961
4962! **************************************************************************************************
4963!> \brief Ends a timer region
4964!> \param handle ...
4965! **************************************************************************************************
4966 SUBROUTINE mp_timestop(handle)
4967 INTEGER, INTENT(IN) :: handle
4968
4969 IF (mp_collect_timings) &
4970 CALL timestop(handle)
4971 END SUBROUTINE mp_timestop
4972
4973! **************************************************************************************************
4974!> \brief Shift around the data in msg
4975!> \param[in,out] msg Rank-2 data to shift
4976!> \param[in] comm message passing environment identifier
4977!> \param[in] displ_in displacements (?)
4978!> \par Example
4979!> msg will be moved from rank to rank+displ_in (in a circular way)
4980!> \par Limitations
4981!> * displ_in will be 1 by default (others not tested)
4982!> * the message array needs to be the same size on all processes
4983! **************************************************************************************************
4984 SUBROUTINE mp_shift_im(msg, comm, displ_in)
4985
4986 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
4987 CLASS(mp_comm_type), INTENT(IN) :: comm
4988 INTEGER, INTENT(IN), OPTIONAL :: displ_in
4989
4990 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_im'
4991
4992 INTEGER :: handle, ierror
4993#if defined(__parallel)
4994 INTEGER :: displ, left, &
4995 msglen, myrank, nprocs, &
4996 right, tag
4997#endif
4998
4999 ierror = 0
5000 CALL mp_timeset(routinen, handle)
5001
5002#if defined(__parallel)
5003 CALL mpi_comm_rank(comm%handle, myrank, ierror)
5004 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
5005 CALL mpi_comm_size(comm%handle, nprocs, ierror)
5006 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
5007 IF (PRESENT(displ_in)) THEN
5008 displ = displ_in
5009 ELSE
5010 displ = 1
5011 END IF
5012 right = modulo(myrank + displ, nprocs)
5013 left = modulo(myrank - displ, nprocs)
5014 tag = 17
5015 msglen = SIZE(msg)
5016 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer, right, tag, left, tag, &
5017 comm%handle, mpi_status_ignore, ierror)
5018 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
5019 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_4_size)
5020#else
5021 mark_used(msg)
5022 mark_used(comm)
5023 mark_used(displ_in)
5024#endif
5025 CALL mp_timestop(handle)
5026
5027 END SUBROUTINE mp_shift_im
5028
5029! **************************************************************************************************
5030!> \brief Shift around the data in msg
5031!> \param[in,out] msg Data to shift
5032!> \param[in] comm message passing environment identifier
5033!> \param[in] displ_in displacements (?)
5034!> \par Example
5035!> msg will be moved from rank to rank+displ_in (in a circular way)
5036!> \par Limitations
5037!> * displ_in will be 1 by default (others not tested)
5038!> * the message array needs to be the same size on all processes
5039! **************************************************************************************************
5040 SUBROUTINE mp_shift_i (msg, comm, displ_in)
5041
5042 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5043 CLASS(mp_comm_type), INTENT(IN) :: comm
5044 INTEGER, INTENT(IN), OPTIONAL :: displ_in
5045
5046 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_i'
5047
5048 INTEGER :: handle, ierror
5049#if defined(__parallel)
5050 INTEGER :: displ, left, &
5051 msglen, myrank, nprocs, &
5052 right, tag
5053#endif
5054
5055 ierror = 0
5056 CALL mp_timeset(routinen, handle)
5057
5058#if defined(__parallel)
5059 CALL mpi_comm_rank(comm%handle, myrank, ierror)
5060 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
5061 CALL mpi_comm_size(comm%handle, nprocs, ierror)
5062 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
5063 IF (PRESENT(displ_in)) THEN
5064 displ = displ_in
5065 ELSE
5066 displ = 1
5067 END IF
5068 right = modulo(myrank + displ, nprocs)
5069 left = modulo(myrank - displ, nprocs)
5070 tag = 19
5071 msglen = SIZE(msg)
5072 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer, right, tag, left, &
5073 tag, comm%handle, mpi_status_ignore, ierror)
5074 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
5075 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_4_size)
5076#else
5077 mark_used(msg)
5078 mark_used(comm)
5079 mark_used(displ_in)
5080#endif
5081 CALL mp_timestop(handle)
5082
5083 END SUBROUTINE mp_shift_i
5084
5085! **************************************************************************************************
5086!> \brief All-to-all data exchange, rank-1 data of different sizes
5087!> \param[in] sb Data to send
5088!> \param[in] scount Data counts for data sent to other processes
5089!> \param[in] sdispl Respective data offsets for data sent to process
5090!> \param[in,out] rb Buffer into which to receive data
5091!> \param[in] rcount Data counts for data received from other
5092!> processes
5093!> \param[in] rdispl Respective data offsets for data received from
5094!> other processes
5095!> \param[in] comm Message passing environment identifier
5096!> \par MPI mapping
5097!> mpi_alltoallv
5098!> \par Array sizes
5099!> The scount, rcount, and the sdispl and rdispl arrays have a
5100!> size equal to the number of processes.
5101!> \par Offsets
5102!> Values in sdispl and rdispl start with 0.
5103! **************************************************************************************************
5104 SUBROUTINE mp_alltoall_i11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
5105
5106 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
5107 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
5108 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
5109 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
5110 CLASS(mp_comm_type), INTENT(IN) :: comm
5111
5112 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i11v'
5113
5114 INTEGER :: handle
5115#if defined(__parallel)
5116 INTEGER :: ierr, msglen
5117#else
5118 INTEGER :: i
5119#endif
5120
5121 CALL mp_timeset(routinen, handle)
5122
5123#if defined(__parallel)
5124 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer, &
5125 rb, rcount, rdispl, mpi_integer, comm%handle, ierr)
5126 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
5127 msglen = sum(scount) + sum(rcount)
5128 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5129#else
5130 mark_used(comm)
5131 mark_used(scount)
5132 mark_used(sdispl)
5133 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
5134 DO i = 1, rcount(1)
5135 rb(rdispl(1) + i) = sb(sdispl(1) + i)
5136 END DO
5137#endif
5138 CALL mp_timestop(handle)
5139
5140 END SUBROUTINE mp_alltoall_i11v
5141
5142! **************************************************************************************************
5143!> \brief All-to-all data exchange, rank-2 data of different sizes
5144!> \param sb ...
5145!> \param scount ...
5146!> \param sdispl ...
5147!> \param rb ...
5148!> \param rcount ...
5149!> \param rdispl ...
5150!> \param comm ...
5151!> \par MPI mapping
5152!> mpi_alltoallv
5153!> \note see mp_alltoall_i11v
5154! **************************************************************************************************
5155 SUBROUTINE mp_alltoall_i22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
5156
5157 INTEGER(KIND=int_4), DIMENSION(:, :), &
5158 INTENT(IN), CONTIGUOUS :: sb
5159 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
5160 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, &
5161 INTENT(INOUT) :: rb
5162 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
5163 CLASS(mp_comm_type), INTENT(IN) :: comm
5164
5165 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i22v'
5166
5167 INTEGER :: handle
5168#if defined(__parallel)
5169 INTEGER :: ierr, msglen
5170#endif
5171
5172 CALL mp_timeset(routinen, handle)
5173
5174#if defined(__parallel)
5175 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer, &
5176 rb, rcount, rdispl, mpi_integer, comm%handle, ierr)
5177 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
5178 msglen = sum(scount) + sum(rcount)
5179 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*int_4_size)
5180#else
5181 mark_used(comm)
5182 mark_used(scount)
5183 mark_used(sdispl)
5184 mark_used(rcount)
5185 mark_used(rdispl)
5186 rb = sb
5187#endif
5188 CALL mp_timestop(handle)
5189
5190 END SUBROUTINE mp_alltoall_i22v
5191
5192! **************************************************************************************************
5193!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
5194!> \param[in] sb array with data to send
5195!> \param[out] rb array into which data is received
5196!> \param[in] count number of elements to send/receive (product of the
5197!> extents of the first two dimensions)
5198!> \param[in] comm Message passing environment identifier
5199!> \par Index meaning
5200!> \par The first two indices specify the data while the last index counts
5201!> the processes
5202!> \par Sizes of ranks
5203!> All processes have the same data size.
5204!> \par MPI mapping
5205!> mpi_alltoall
5206! **************************************************************************************************
5207 SUBROUTINE mp_alltoall_i (sb, rb, count, comm)
5208
5209 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
5210 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
5211 INTEGER, INTENT(IN) :: count
5212 CLASS(mp_comm_type), INTENT(IN) :: comm
5213
5214 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i'
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_i
5239
5240! **************************************************************************************************
5241!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
5242!> \param sb ...
5243!> \param rb ...
5244!> \param count ...
5245!> \param commp ...
5246!> \note see mp_alltoall_i
5247! **************************************************************************************************
5248 SUBROUTINE mp_alltoall_i22(sb, rb, count, comm)
5249
5250 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
5251 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
5252 INTEGER, INTENT(IN) :: count
5253 CLASS(mp_comm_type), INTENT(IN) :: comm
5254
5255 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i22'
5256
5257 INTEGER :: handle
5258#if defined(__parallel)
5259 INTEGER :: ierr, msglen, np
5260#endif
5261
5262 CALL mp_timeset(routinen, handle)
5263
5264#if defined(__parallel)
5265 CALL mpi_alltoall(sb, count, mpi_integer, &
5266 rb, count, mpi_integer, comm%handle, ierr)
5267 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5268 CALL mpi_comm_size(comm%handle, np, ierr)
5269 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5270 msglen = 2*SIZE(sb)*np
5271 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5272#else
5273 mark_used(count)
5274 mark_used(comm)
5275 rb = sb
5276#endif
5277 CALL mp_timestop(handle)
5278
5279 END SUBROUTINE mp_alltoall_i22
5280
5281! **************************************************************************************************
5282!> \brief All-to-all data exchange, rank-3 data with equal sizes
5283!> \param sb ...
5284!> \param rb ...
5285!> \param count ...
5286!> \param comm ...
5287!> \note see mp_alltoall_i
5288! **************************************************************************************************
5289 SUBROUTINE mp_alltoall_i33(sb, rb, count, comm)
5290
5291 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
5292 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
5293 INTEGER, INTENT(IN) :: count
5294 CLASS(mp_comm_type), INTENT(IN) :: comm
5295
5296 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i33'
5297
5298 INTEGER :: handle
5299#if defined(__parallel)
5300 INTEGER :: ierr, msglen, np
5301#endif
5302
5303 CALL mp_timeset(routinen, handle)
5304
5305#if defined(__parallel)
5306 CALL mpi_alltoall(sb, count, mpi_integer, &
5307 rb, count, mpi_integer, comm%handle, ierr)
5308 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5309 CALL mpi_comm_size(comm%handle, np, ierr)
5310 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5311 msglen = 2*count*np
5312 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5313#else
5314 mark_used(count)
5315 mark_used(comm)
5316 rb = sb
5317#endif
5318 CALL mp_timestop(handle)
5319
5320 END SUBROUTINE mp_alltoall_i33
5321
5322! **************************************************************************************************
5323!> \brief All-to-all data exchange, rank 4 data, equal sizes
5324!> \param sb ...
5325!> \param rb ...
5326!> \param count ...
5327!> \param comm ...
5328!> \note see mp_alltoall_i
5329! **************************************************************************************************
5330 SUBROUTINE mp_alltoall_i44(sb, rb, count, comm)
5331
5332 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5333 INTENT(IN) :: sb
5334 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5335 INTENT(OUT) :: rb
5336 INTEGER, INTENT(IN) :: count
5337 CLASS(mp_comm_type), INTENT(IN) :: comm
5338
5339 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i44'
5340
5341 INTEGER :: handle
5342#if defined(__parallel)
5343 INTEGER :: ierr, msglen, np
5344#endif
5345
5346 CALL mp_timeset(routinen, handle)
5347
5348#if defined(__parallel)
5349 CALL mpi_alltoall(sb, count, mpi_integer, &
5350 rb, count, mpi_integer, comm%handle, ierr)
5351 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5352 CALL mpi_comm_size(comm%handle, np, ierr)
5353 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5354 msglen = 2*count*np
5355 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5356#else
5357 mark_used(count)
5358 mark_used(comm)
5359 rb = sb
5360#endif
5361 CALL mp_timestop(handle)
5362
5363 END SUBROUTINE mp_alltoall_i44
5364
5365! **************************************************************************************************
5366!> \brief All-to-all data exchange, rank 5 data, equal sizes
5367!> \param sb ...
5368!> \param rb ...
5369!> \param count ...
5370!> \param comm ...
5371!> \note see mp_alltoall_i
5372! **************************************************************************************************
5373 SUBROUTINE mp_alltoall_i55(sb, rb, count, comm)
5374
5375 INTEGER(KIND=int_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
5376 INTENT(IN) :: sb
5377 INTEGER(KIND=int_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
5378 INTENT(OUT) :: rb
5379 INTEGER, INTENT(IN) :: count
5380 CLASS(mp_comm_type), INTENT(IN) :: comm
5381
5382 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i55'
5383
5384 INTEGER :: handle
5385#if defined(__parallel)
5386 INTEGER :: ierr, msglen, np
5387#endif
5388
5389 CALL mp_timeset(routinen, handle)
5390
5391#if defined(__parallel)
5392 CALL mpi_alltoall(sb, count, mpi_integer, &
5393 rb, count, mpi_integer, comm%handle, ierr)
5394 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5395 CALL mpi_comm_size(comm%handle, np, ierr)
5396 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5397 msglen = 2*count*np
5398 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5399#else
5400 mark_used(count)
5401 mark_used(comm)
5402 rb = sb
5403#endif
5404 CALL mp_timestop(handle)
5405
5406 END SUBROUTINE mp_alltoall_i55
5407
5408! **************************************************************************************************
5409!> \brief All-to-all data exchange, rank-4 data to rank-5 data
5410!> \param sb ...
5411!> \param rb ...
5412!> \param count ...
5413!> \param comm ...
5414!> \note see mp_alltoall_i
5415!> \note User must ensure size consistency.
5416! **************************************************************************************************
5417 SUBROUTINE mp_alltoall_i45(sb, rb, count, comm)
5418
5419 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5420 INTENT(IN) :: sb
5421 INTEGER(KIND=int_4), &
5422 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
5423 INTEGER, INTENT(IN) :: count
5424 CLASS(mp_comm_type), INTENT(IN) :: comm
5425
5426 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i45'
5427
5428 INTEGER :: handle
5429#if defined(__parallel)
5430 INTEGER :: ierr, msglen, np
5431#endif
5432
5433 CALL mp_timeset(routinen, handle)
5434
5435#if defined(__parallel)
5436 CALL mpi_alltoall(sb, count, mpi_integer, &
5437 rb, count, mpi_integer, comm%handle, ierr)
5438 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5439 CALL mpi_comm_size(comm%handle, np, ierr)
5440 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5441 msglen = 2*count*np
5442 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5443#else
5444 mark_used(count)
5445 mark_used(comm)
5446 rb = reshape(sb, shape(rb))
5447#endif
5448 CALL mp_timestop(handle)
5449
5450 END SUBROUTINE mp_alltoall_i45
5451
5452! **************************************************************************************************
5453!> \brief All-to-all data exchange, rank-3 data to rank-4 data
5454!> \param sb ...
5455!> \param rb ...
5456!> \param count ...
5457!> \param comm ...
5458!> \note see mp_alltoall_i
5459!> \note User must ensure size consistency.
5460! **************************************************************************************************
5461 SUBROUTINE mp_alltoall_i34(sb, rb, count, comm)
5462
5463 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, &
5464 INTENT(IN) :: sb
5465 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5466 INTENT(OUT) :: rb
5467 INTEGER, INTENT(IN) :: count
5468 CLASS(mp_comm_type), INTENT(IN) :: comm
5469
5470 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i34'
5471
5472 INTEGER :: handle
5473#if defined(__parallel)
5474 INTEGER :: ierr, msglen, np
5475#endif
5476
5477 CALL mp_timeset(routinen, handle)
5478
5479#if defined(__parallel)
5480 CALL mpi_alltoall(sb, count, mpi_integer, &
5481 rb, count, mpi_integer, comm%handle, ierr)
5482 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5483 CALL mpi_comm_size(comm%handle, np, ierr)
5484 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5485 msglen = 2*count*np
5486 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5487#else
5488 mark_used(count)
5489 mark_used(comm)
5490 rb = reshape(sb, shape(rb))
5491#endif
5492 CALL mp_timestop(handle)
5493
5494 END SUBROUTINE mp_alltoall_i34
5495
5496! **************************************************************************************************
5497!> \brief All-to-all data exchange, rank-5 data to rank-4 data
5498!> \param sb ...
5499!> \param rb ...
5500!> \param count ...
5501!> \param comm ...
5502!> \note see mp_alltoall_i
5503!> \note User must ensure size consistency.
5504! **************************************************************************************************
5505 SUBROUTINE mp_alltoall_i54(sb, rb, count, comm)
5506
5507 INTEGER(KIND=int_4), &
5508 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
5509 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5510 INTENT(OUT) :: rb
5511 INTEGER, INTENT(IN) :: count
5512 CLASS(mp_comm_type), INTENT(IN) :: comm
5513
5514 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i54'
5515
5516 INTEGER :: handle
5517#if defined(__parallel)
5518 INTEGER :: ierr, msglen, np
5519#endif
5520
5521 CALL mp_timeset(routinen, handle)
5522
5523#if defined(__parallel)
5524 CALL mpi_alltoall(sb, count, mpi_integer, &
5525 rb, count, mpi_integer, comm%handle, ierr)
5526 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5527 CALL mpi_comm_size(comm%handle, np, ierr)
5528 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5529 msglen = 2*count*np
5530 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5531#else
5532 mark_used(count)
5533 mark_used(comm)
5534 rb = reshape(sb, shape(rb))
5535#endif
5536 CALL mp_timestop(handle)
5537
5538 END SUBROUTINE mp_alltoall_i54
5539
5540! **************************************************************************************************
5541!> \brief Send one datum to another process
5542!> \param[in] msg Scalar to send
5543!> \param[in] dest Destination process
5544!> \param[in] tag Transfer identifier
5545!> \param[in] comm Message passing environment identifier
5546!> \par MPI mapping
5547!> mpi_send
5548! **************************************************************************************************
5549 SUBROUTINE mp_send_i (msg, dest, tag, comm)
5550 INTEGER(KIND=int_4), INTENT(IN) :: msg
5551 INTEGER, INTENT(IN) :: dest, tag
5552 CLASS(mp_comm_type), INTENT(IN) :: comm
5553
5554 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_i'
5555
5556 INTEGER :: handle
5557#if defined(__parallel)
5558 INTEGER :: ierr, msglen
5559#endif
5560
5561 CALL mp_timeset(routinen, handle)
5562
5563#if defined(__parallel)
5564 msglen = 1
5565 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5566 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5567 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5568#else
5569 mark_used(msg)
5570 mark_used(dest)
5571 mark_used(tag)
5572 mark_used(comm)
5573 ! only defined in parallel
5574 cpabort("not in parallel mode")
5575#endif
5576 CALL mp_timestop(handle)
5577 END SUBROUTINE mp_send_i
5578
5579! **************************************************************************************************
5580!> \brief Send rank-1 data to another process
5581!> \param[in] msg Rank-1 data to send
5582!> \param dest ...
5583!> \param tag ...
5584!> \param comm ...
5585!> \note see mp_send_i
5586! **************************************************************************************************
5587 SUBROUTINE mp_send_iv(msg, dest, tag, comm)
5588 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
5589 INTEGER, INTENT(IN) :: dest, tag
5590 CLASS(mp_comm_type), INTENT(IN) :: comm
5591
5592 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_iv'
5593
5594 INTEGER :: handle
5595#if defined(__parallel)
5596 INTEGER :: ierr, msglen
5597#endif
5598
5599 CALL mp_timeset(routinen, handle)
5600
5601#if defined(__parallel)
5602 msglen = SIZE(msg)
5603 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5604 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5605 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5606#else
5607 mark_used(msg)
5608 mark_used(dest)
5609 mark_used(tag)
5610 mark_used(comm)
5611 ! only defined in parallel
5612 cpabort("not in parallel mode")
5613#endif
5614 CALL mp_timestop(handle)
5615 END SUBROUTINE mp_send_iv
5616
5617! **************************************************************************************************
5618!> \brief Send rank-2 data to another process
5619!> \param[in] msg Rank-2 data to send
5620!> \param dest ...
5621!> \param tag ...
5622!> \param comm ...
5623!> \note see mp_send_i
5624! **************************************************************************************************
5625 SUBROUTINE mp_send_im2(msg, dest, tag, comm)
5626 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
5627 INTEGER, INTENT(IN) :: dest, tag
5628 CLASS(mp_comm_type), INTENT(IN) :: comm
5629
5630 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_im2'
5631
5632 INTEGER :: handle
5633#if defined(__parallel)
5634 INTEGER :: ierr, msglen
5635#endif
5636
5637 CALL mp_timeset(routinen, handle)
5638
5639#if defined(__parallel)
5640 msglen = SIZE(msg)
5641 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5642 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5643 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5644#else
5645 mark_used(msg)
5646 mark_used(dest)
5647 mark_used(tag)
5648 mark_used(comm)
5649 ! only defined in parallel
5650 cpabort("not in parallel mode")
5651#endif
5652 CALL mp_timestop(handle)
5653 END SUBROUTINE mp_send_im2
5654
5655! **************************************************************************************************
5656!> \brief Send rank-3 data to another process
5657!> \param[in] msg Rank-3 data to send
5658!> \param dest ...
5659!> \param tag ...
5660!> \param comm ...
5661!> \note see mp_send_i
5662! **************************************************************************************************
5663 SUBROUTINE mp_send_im3(msg, dest, tag, comm)
5664 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
5665 INTEGER, INTENT(IN) :: dest, tag
5666 CLASS(mp_comm_type), INTENT(IN) :: comm
5667
5668 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
5669
5670 INTEGER :: handle
5671#if defined(__parallel)
5672 INTEGER :: ierr, msglen
5673#endif
5674
5675 CALL mp_timeset(routinen, handle)
5676
5677#if defined(__parallel)
5678 msglen = SIZE(msg)
5679 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5680 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5681 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5682#else
5683 mark_used(msg)
5684 mark_used(dest)
5685 mark_used(tag)
5686 mark_used(comm)
5687 ! only defined in parallel
5688 cpabort("not in parallel mode")
5689#endif
5690 CALL mp_timestop(handle)
5691 END SUBROUTINE mp_send_im3
5692
5693! **************************************************************************************************
5694!> \brief Receive one datum from another process
5695!> \param[in,out] msg Place received data into this variable
5696!> \param[in,out] source Process to receive from
5697!> \param[in,out] tag Transfer identifier
5698!> \param[in] comm Message passing environment identifier
5699!> \par MPI mapping
5700!> mpi_send
5701! **************************************************************************************************
5702 SUBROUTINE mp_recv_i (msg, source, tag, comm)
5703 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5704 INTEGER, INTENT(INOUT) :: source, tag
5705 CLASS(mp_comm_type), INTENT(IN) :: comm
5706
5707 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_i'
5708
5709 INTEGER :: handle
5710#if defined(__parallel)
5711 INTEGER :: ierr, msglen
5712 mpi_status_type :: status
5713#endif
5714
5715 CALL mp_timeset(routinen, handle)
5716
5717#if defined(__parallel)
5718 msglen = 1
5719 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5720 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5721 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5722 ELSE
5723 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5724 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5725 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5726 source = status mpi_status_extract(mpi_source)
5727 tag = status mpi_status_extract(mpi_tag)
5728 END IF
5729#else
5730 mark_used(msg)
5731 mark_used(source)
5732 mark_used(tag)
5733 mark_used(comm)
5734 ! only defined in parallel
5735 cpabort("not in parallel mode")
5736#endif
5737 CALL mp_timestop(handle)
5738 END SUBROUTINE mp_recv_i
5739
5740! **************************************************************************************************
5741!> \brief Receive rank-1 data from another process
5742!> \param[in,out] msg Place received data into this rank-1 array
5743!> \param source ...
5744!> \param tag ...
5745!> \param comm ...
5746!> \note see mp_recv_i
5747! **************************************************************************************************
5748 SUBROUTINE mp_recv_iv(msg, source, tag, comm)
5749 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5750 INTEGER, INTENT(INOUT) :: source, tag
5751 CLASS(mp_comm_type), INTENT(IN) :: comm
5752
5753 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_iv'
5754
5755 INTEGER :: handle
5756#if defined(__parallel)
5757 INTEGER :: ierr, msglen
5758 mpi_status_type :: status
5759#endif
5760
5761 CALL mp_timeset(routinen, handle)
5762
5763#if defined(__parallel)
5764 msglen = SIZE(msg)
5765 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5766 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5767 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5768 ELSE
5769 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5770 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5771 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5772 source = status mpi_status_extract(mpi_source)
5773 tag = status mpi_status_extract(mpi_tag)
5774 END IF
5775#else
5776 mark_used(msg)
5777 mark_used(source)
5778 mark_used(tag)
5779 mark_used(comm)
5780 ! only defined in parallel
5781 cpabort("not in parallel mode")
5782#endif
5783 CALL mp_timestop(handle)
5784 END SUBROUTINE mp_recv_iv
5785
5786! **************************************************************************************************
5787!> \brief Receive rank-2 data from another process
5788!> \param[in,out] msg Place received data into this rank-2 array
5789!> \param source ...
5790!> \param tag ...
5791!> \param comm ...
5792!> \note see mp_recv_i
5793! **************************************************************************************************
5794 SUBROUTINE mp_recv_im2(msg, source, tag, comm)
5795 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5796 INTEGER, INTENT(INOUT) :: source, tag
5797 CLASS(mp_comm_type), INTENT(IN) :: comm
5798
5799 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_im2'
5800
5801 INTEGER :: handle
5802#if defined(__parallel)
5803 INTEGER :: ierr, msglen
5804 mpi_status_type :: status
5805#endif
5806
5807 CALL mp_timeset(routinen, handle)
5808
5809#if defined(__parallel)
5810 msglen = SIZE(msg)
5811 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5812 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5813 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5814 ELSE
5815 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5816 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5817 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5818 source = status mpi_status_extract(mpi_source)
5819 tag = status mpi_status_extract(mpi_tag)
5820 END IF
5821#else
5822 mark_used(msg)
5823 mark_used(source)
5824 mark_used(tag)
5825 mark_used(comm)
5826 ! only defined in parallel
5827 cpabort("not in parallel mode")
5828#endif
5829 CALL mp_timestop(handle)
5830 END SUBROUTINE mp_recv_im2
5831
5832! **************************************************************************************************
5833!> \brief Receive rank-3 data from another process
5834!> \param[in,out] msg Place received data into this rank-3 array
5835!> \param source ...
5836!> \param tag ...
5837!> \param comm ...
5838!> \note see mp_recv_i
5839! **************************************************************************************************
5840 SUBROUTINE mp_recv_im3(msg, source, tag, comm)
5841 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
5842 INTEGER, INTENT(INOUT) :: source, tag
5843 CLASS(mp_comm_type), INTENT(IN) :: comm
5844
5845 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_im3'
5846
5847 INTEGER :: handle
5848#if defined(__parallel)
5849 INTEGER :: ierr, msglen
5850 mpi_status_type :: status
5851#endif
5852
5853 CALL mp_timeset(routinen, handle)
5854
5855#if defined(__parallel)
5856 msglen = SIZE(msg)
5857 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5858 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5859 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5860 ELSE
5861 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5862 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5863 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5864 source = status mpi_status_extract(mpi_source)
5865 tag = status mpi_status_extract(mpi_tag)
5866 END IF
5867#else
5868 mark_used(msg)
5869 mark_used(source)
5870 mark_used(tag)
5871 mark_used(comm)
5872 ! only defined in parallel
5873 cpabort("not in parallel mode")
5874#endif
5875 CALL mp_timestop(handle)
5876 END SUBROUTINE mp_recv_im3
5877
5878! **************************************************************************************************
5879!> \brief Broadcasts a datum to all processes.
5880!> \param[in] msg Datum to broadcast
5881!> \param[in] source Processes which broadcasts
5882!> \param[in] comm Message passing environment identifier
5883!> \par MPI mapping
5884!> mpi_bcast
5885! **************************************************************************************************
5886 SUBROUTINE mp_bcast_i (msg, source, comm)
5887 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5888 INTEGER, INTENT(IN) :: source
5889 CLASS(mp_comm_type), INTENT(IN) :: comm
5890
5891 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i'
5892
5893 INTEGER :: handle
5894#if defined(__parallel)
5895 INTEGER :: ierr, msglen
5896#endif
5897
5898 CALL mp_timeset(routinen, handle)
5899
5900#if defined(__parallel)
5901 msglen = 1
5902 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
5903 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5904 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5905#else
5906 mark_used(msg)
5907 mark_used(source)
5908 mark_used(comm)
5909#endif
5910 CALL mp_timestop(handle)
5911 END SUBROUTINE mp_bcast_i
5912
5913! **************************************************************************************************
5914!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
5915!> \param[in] msg Datum to broadcast
5916!> \param[in] comm Message passing environment identifier
5917!> \par MPI mapping
5918!> mpi_bcast
5919! **************************************************************************************************
5920 SUBROUTINE mp_bcast_i_src(msg, comm)
5921 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5922 CLASS(mp_comm_type), INTENT(IN) :: comm
5923
5924 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i_src'
5925
5926 INTEGER :: handle
5927#if defined(__parallel)
5928 INTEGER :: ierr, msglen
5929#endif
5930
5931 CALL mp_timeset(routinen, handle)
5932
5933#if defined(__parallel)
5934 msglen = 1
5935 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
5936 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5937 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5938#else
5939 mark_used(msg)
5940 mark_used(comm)
5941#endif
5942 CALL mp_timestop(handle)
5943 END SUBROUTINE mp_bcast_i_src
5944
5945! **************************************************************************************************
5946!> \brief Broadcasts a datum to all processes.
5947!> \param[in] msg Datum to broadcast
5948!> \param[in] source Processes which broadcasts
5949!> \param[in] comm Message passing environment identifier
5950!> \par MPI mapping
5951!> mpi_bcast
5952! **************************************************************************************************
5953 SUBROUTINE mp_ibcast_i (msg, source, comm, request)
5954 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5955 INTEGER, INTENT(IN) :: source
5956 CLASS(mp_comm_type), INTENT(IN) :: comm
5957 TYPE(mp_request_type), INTENT(OUT) :: request
5958
5959 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_i'
5960
5961 INTEGER :: handle
5962#if defined(__parallel)
5963 INTEGER :: ierr, msglen
5964#endif
5965
5966 CALL mp_timeset(routinen, handle)
5967
5968#if defined(__parallel)
5969 msglen = 1
5970 CALL mpi_ibcast(msg, msglen, mpi_integer, source, comm%handle, request%handle, ierr)
5971 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
5972 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_4_size)
5973#else
5974 mark_used(msg)
5975 mark_used(source)
5976 mark_used(comm)
5977 request = mp_request_null
5978#endif
5979 CALL mp_timestop(handle)
5980 END SUBROUTINE mp_ibcast_i
5981
5982! **************************************************************************************************
5983!> \brief Broadcasts rank-1 data to all processes
5984!> \param[in] msg Data to broadcast
5985!> \param source ...
5986!> \param comm ...
5987!> \note see mp_bcast_i1
5988! **************************************************************************************************
5989 SUBROUTINE mp_bcast_iv(msg, source, comm)
5990 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5991 INTEGER, INTENT(IN) :: source
5992 CLASS(mp_comm_type), INTENT(IN) :: comm
5993
5994 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_iv'
5995
5996 INTEGER :: handle
5997#if defined(__parallel)
5998 INTEGER :: ierr, msglen
5999#endif
6000
6001 CALL mp_timeset(routinen, handle)
6002
6003#if defined(__parallel)
6004 msglen = SIZE(msg)
6005 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
6006 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6007 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6008#else
6009 mark_used(msg)
6010 mark_used(source)
6011 mark_used(comm)
6012#endif
6013 CALL mp_timestop(handle)
6014 END SUBROUTINE mp_bcast_iv
6015
6016! **************************************************************************************************
6017!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
6018!> \param[in] msg Data to broadcast
6019!> \param comm ...
6020!> \note see mp_bcast_i1
6021! **************************************************************************************************
6022 SUBROUTINE mp_bcast_iv_src(msg, comm)
6023 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6024 CLASS(mp_comm_type), INTENT(IN) :: comm
6025
6026 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_iv_src'
6027
6028 INTEGER :: handle
6029#if defined(__parallel)
6030 INTEGER :: ierr, msglen
6031#endif
6032
6033 CALL mp_timeset(routinen, handle)
6034
6035#if defined(__parallel)
6036 msglen = SIZE(msg)
6037 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
6038 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6039 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6040#else
6041 mark_used(msg)
6042 mark_used(comm)
6043#endif
6044 CALL mp_timestop(handle)
6045 END SUBROUTINE mp_bcast_iv_src
6046
6047! **************************************************************************************************
6048!> \brief Broadcasts rank-1 data to all processes
6049!> \param[in] msg Data to broadcast
6050!> \param source ...
6051!> \param comm ...
6052!> \note see mp_bcast_i1
6053! **************************************************************************************************
6054 SUBROUTINE mp_ibcast_iv(msg, source, comm, request)
6055 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6056 INTEGER, INTENT(IN) :: source
6057 CLASS(mp_comm_type), INTENT(IN) :: comm
6058 TYPE(mp_request_type) :: request
6059
6060 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_iv'
6061
6062 INTEGER :: handle
6063#if defined(__parallel)
6064 INTEGER :: ierr, msglen
6065#endif
6066
6067 CALL mp_timeset(routinen, handle)
6068
6069#if defined(__parallel)
6070#if !defined(__GNUC__) || __GNUC__ >= 9
6071 cpassert(is_contiguous(msg))
6072#endif
6073 msglen = SIZE(msg)
6074 CALL mpi_ibcast(msg, msglen, mpi_integer, source, comm%handle, request%handle, ierr)
6075 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
6076 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_4_size)
6077#else
6078 mark_used(msg)
6079 mark_used(source)
6080 mark_used(comm)
6081 request = mp_request_null
6082#endif
6083 CALL mp_timestop(handle)
6084 END SUBROUTINE mp_ibcast_iv
6085
6086! **************************************************************************************************
6087!> \brief Broadcasts rank-2 data to all processes
6088!> \param[in] msg Data to broadcast
6089!> \param source ...
6090!> \param comm ...
6091!> \note see mp_bcast_i1
6092! **************************************************************************************************
6093 SUBROUTINE mp_bcast_im(msg, source, comm)
6094 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6095 INTEGER, INTENT(IN) :: source
6096 CLASS(mp_comm_type), INTENT(IN) :: comm
6097
6098 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_im'
6099
6100 INTEGER :: handle
6101#if defined(__parallel)
6102 INTEGER :: ierr, msglen
6103#endif
6104
6105 CALL mp_timeset(routinen, handle)
6106
6107#if defined(__parallel)
6108 msglen = SIZE(msg)
6109 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
6110 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6111 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6112#else
6113 mark_used(msg)
6114 mark_used(source)
6115 mark_used(comm)
6116#endif
6117 CALL mp_timestop(handle)
6118 END SUBROUTINE mp_bcast_im
6119
6120! **************************************************************************************************
6121!> \brief Broadcasts rank-2 data to all processes
6122!> \param[in] msg Data to broadcast
6123!> \param source ...
6124!> \param comm ...
6125!> \note see mp_bcast_i1
6126! **************************************************************************************************
6127 SUBROUTINE mp_bcast_im_src(msg, comm)
6128 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6129 CLASS(mp_comm_type), INTENT(IN) :: comm
6130
6131 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_im_src'
6132
6133 INTEGER :: handle
6134#if defined(__parallel)
6135 INTEGER :: ierr, msglen
6136#endif
6137
6138 CALL mp_timeset(routinen, handle)
6139
6140#if defined(__parallel)
6141 msglen = SIZE(msg)
6142 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
6143 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6144 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6145#else
6146 mark_used(msg)
6147 mark_used(comm)
6148#endif
6149 CALL mp_timestop(handle)
6150 END SUBROUTINE mp_bcast_im_src
6151
6152! **************************************************************************************************
6153!> \brief Broadcasts rank-3 data to all processes
6154!> \param[in] msg Data to broadcast
6155!> \param source ...
6156!> \param comm ...
6157!> \note see mp_bcast_i1
6158! **************************************************************************************************
6159 SUBROUTINE mp_bcast_i3(msg, source, comm)
6160 INTEGER(KIND=int_4), CONTIGUOUS :: msg(:, :, :)
6161 INTEGER, INTENT(IN) :: source
6162 CLASS(mp_comm_type), INTENT(IN) :: comm
6163
6164 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i3'
6165
6166 INTEGER :: handle
6167#if defined(__parallel)
6168 INTEGER :: ierr, msglen
6169#endif
6170
6171 CALL mp_timeset(routinen, handle)
6172
6173#if defined(__parallel)
6174 msglen = SIZE(msg)
6175 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
6176 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6177 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6178#else
6179 mark_used(msg)
6180 mark_used(source)
6181 mark_used(comm)
6182#endif
6183 CALL mp_timestop(handle)
6184 END SUBROUTINE mp_bcast_i3
6185
6186! **************************************************************************************************
6187!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
6188!> \param[in] msg Data to broadcast
6189!> \param source ...
6190!> \param comm ...
6191!> \note see mp_bcast_i1
6192! **************************************************************************************************
6193 SUBROUTINE mp_bcast_i3_src(msg, comm)
6194 INTEGER(KIND=int_4), CONTIGUOUS :: msg(:, :, :)
6195 CLASS(mp_comm_type), INTENT(IN) :: comm
6196
6197 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i3_src'
6198
6199 INTEGER :: handle
6200#if defined(__parallel)
6201 INTEGER :: ierr, msglen
6202#endif
6203
6204 CALL mp_timeset(routinen, handle)
6205
6206#if defined(__parallel)
6207 msglen = SIZE(msg)
6208 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
6209 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6210 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6211#else
6212 mark_used(msg)
6213 mark_used(comm)
6214#endif
6215 CALL mp_timestop(handle)
6216 END SUBROUTINE mp_bcast_i3_src
6217
6218! **************************************************************************************************
6219!> \brief Sums a datum from all processes with result left on all processes.
6220!> \param[in,out] msg Datum to sum (input) and result (output)
6221!> \param[in] comm Message passing environment identifier
6222!> \par MPI mapping
6223!> mpi_allreduce
6224! **************************************************************************************************
6225 SUBROUTINE mp_sum_i (msg, comm)
6226 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6227 CLASS(mp_comm_type), INTENT(IN) :: comm
6228
6229 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_i'
6230
6231 INTEGER :: handle
6232#if defined(__parallel)
6233 INTEGER :: ierr, msglen
6234#endif
6235
6236 CALL mp_timeset(routinen, handle)
6237
6238#if defined(__parallel)
6239 msglen = 1
6240 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6241 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6242 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6243#else
6244 mark_used(msg)
6245 mark_used(comm)
6246#endif
6247 CALL mp_timestop(handle)
6248 END SUBROUTINE mp_sum_i
6249
6250! **************************************************************************************************
6251!> \brief Element-wise sum of a rank-1 array on all processes.
6252!> \param[in,out] msg Vector to sum and result
6253!> \param comm ...
6254!> \note see mp_sum_i
6255! **************************************************************************************************
6256 SUBROUTINE mp_sum_iv(msg, comm)
6257 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6258 CLASS(mp_comm_type), INTENT(IN) :: comm
6259
6260 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_iv'
6261
6262 INTEGER :: handle
6263#if defined(__parallel)
6264 INTEGER :: ierr, msglen
6265#endif
6266
6267 CALL mp_timeset(routinen, handle)
6268
6269#if defined(__parallel)
6270 msglen = SIZE(msg)
6271 IF (msglen > 0) THEN
6272 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6273 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6274 END IF
6275 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6276#else
6277 mark_used(msg)
6278 mark_used(comm)
6279#endif
6280 CALL mp_timestop(handle)
6281 END SUBROUTINE mp_sum_iv
6282
6283! **************************************************************************************************
6284!> \brief Element-wise sum of a rank-1 array on all processes.
6285!> \param[in,out] msg Vector to sum and result
6286!> \param comm ...
6287!> \note see mp_sum_i
6288! **************************************************************************************************
6289 SUBROUTINE mp_isum_iv(msg, comm, request)
6290 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6291 CLASS(mp_comm_type), INTENT(IN) :: comm
6292 TYPE(mp_request_type), INTENT(OUT) :: request
6293
6294 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_iv'
6295
6296 INTEGER :: handle
6297#if defined(__parallel)
6298 INTEGER :: ierr, msglen
6299#endif
6300
6301 CALL mp_timeset(routinen, handle)
6302
6303#if defined(__parallel)
6304#if !defined(__GNUC__) || __GNUC__ >= 9
6305 cpassert(is_contiguous(msg))
6306#endif
6307 msglen = SIZE(msg)
6308 IF (msglen > 0) THEN
6309 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, request%handle, ierr)
6310 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
6311 ELSE
6312 request = mp_request_null
6313 END IF
6314 CALL add_perf(perf_id=23, count=1, msg_size=msglen*int_4_size)
6315#else
6316 mark_used(msg)
6317 mark_used(comm)
6318 request = mp_request_null
6319#endif
6320 CALL mp_timestop(handle)
6321 END SUBROUTINE mp_isum_iv
6322
6323! **************************************************************************************************
6324!> \brief Element-wise sum of a rank-2 array on all processes.
6325!> \param[in] msg Matrix to sum and result
6326!> \param comm ...
6327!> \note see mp_sum_i
6328! **************************************************************************************************
6329 SUBROUTINE mp_sum_im(msg, comm)
6330 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6331 CLASS(mp_comm_type), INTENT(IN) :: comm
6332
6333 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im'
6334
6335 INTEGER :: handle
6336#if defined(__parallel)
6337 INTEGER, PARAMETER :: max_msg = 2**25
6338 INTEGER :: ierr, m1, msglen, step, msglensum
6339#endif
6340
6341 CALL mp_timeset(routinen, handle)
6342
6343#if defined(__parallel)
6344 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
6345 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
6346 msglensum = 0
6347 DO m1 = lbound(msg, 2), ubound(msg, 2), step
6348 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
6349 msglensum = msglensum + msglen
6350 IF (msglen > 0) THEN
6351 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6352 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6353 END IF
6354 END DO
6355 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_4_size)
6356#else
6357 mark_used(msg)
6358 mark_used(comm)
6359#endif
6360 CALL mp_timestop(handle)
6361 END SUBROUTINE mp_sum_im
6362
6363! **************************************************************************************************
6364!> \brief Element-wise sum of a rank-3 array on all processes.
6365!> \param[in] msg Array to sum and result
6366!> \param comm ...
6367!> \note see mp_sum_i
6368! **************************************************************************************************
6369 SUBROUTINE mp_sum_im3(msg, comm)
6370 INTEGER(KIND=int_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
6371 CLASS(mp_comm_type), INTENT(IN) :: comm
6372
6373 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im3'
6374
6375 INTEGER :: handle
6376#if defined(__parallel)
6377 INTEGER :: ierr, msglen
6378#endif
6379
6380 CALL mp_timeset(routinen, handle)
6381
6382#if defined(__parallel)
6383 msglen = SIZE(msg)
6384 IF (msglen > 0) THEN
6385 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6386 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6387 END IF
6388 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6389#else
6390 mark_used(msg)
6391 mark_used(comm)
6392#endif
6393 CALL mp_timestop(handle)
6394 END SUBROUTINE mp_sum_im3
6395
6396! **************************************************************************************************
6397!> \brief Element-wise sum of a rank-4 array on all processes.
6398!> \param[in] msg Array to sum and result
6399!> \param comm ...
6400!> \note see mp_sum_i
6401! **************************************************************************************************
6402 SUBROUTINE mp_sum_im4(msg, comm)
6403 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
6404 CLASS(mp_comm_type), INTENT(IN) :: comm
6405
6406 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im4'
6407
6408 INTEGER :: handle
6409#if defined(__parallel)
6410 INTEGER :: ierr, msglen
6411#endif
6412
6413 CALL mp_timeset(routinen, handle)
6414
6415#if defined(__parallel)
6416 msglen = SIZE(msg)
6417 IF (msglen > 0) THEN
6418 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6419 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6420 END IF
6421 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6422#else
6423 mark_used(msg)
6424 mark_used(comm)
6425#endif
6426 CALL mp_timestop(handle)
6427 END SUBROUTINE mp_sum_im4
6428
6429! **************************************************************************************************
6430!> \brief Element-wise sum of data from all processes with result left only on
6431!> one.
6432!> \param[in,out] msg Vector to sum (input) and (only on process root)
6433!> result (output)
6434!> \param root ...
6435!> \param[in] comm Message passing environment identifier
6436!> \par MPI mapping
6437!> mpi_reduce
6438! **************************************************************************************************
6439 SUBROUTINE mp_sum_root_iv(msg, root, comm)
6440 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6441 INTEGER, INTENT(IN) :: root
6442 CLASS(mp_comm_type), INTENT(IN) :: comm
6443
6444 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_iv'
6445
6446 INTEGER :: handle
6447#if defined(__parallel)
6448 INTEGER :: ierr, m1, msglen, taskid
6449 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
6450#endif
6451
6452 CALL mp_timeset(routinen, handle)
6453
6454#if defined(__parallel)
6455 msglen = SIZE(msg)
6456 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6457 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6458 IF (msglen > 0) THEN
6459 m1 = SIZE(msg, 1)
6460 ALLOCATE (res(m1))
6461 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_sum, &
6462 root, comm%handle, ierr)
6463 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6464 IF (taskid == root) THEN
6465 msg = res
6466 END IF
6467 DEALLOCATE (res)
6468 END IF
6469 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6470#else
6471 mark_used(msg)
6472 mark_used(root)
6473 mark_used(comm)
6474#endif
6475 CALL mp_timestop(handle)
6476 END SUBROUTINE mp_sum_root_iv
6477
6478! **************************************************************************************************
6479!> \brief Element-wise sum of data from all processes with result left only on
6480!> one.
6481!> \param[in,out] msg Matrix to sum (input) and (only on process root)
6482!> result (output)
6483!> \param root ...
6484!> \param comm ...
6485!> \note see mp_sum_root_iv
6486! **************************************************************************************************
6487 SUBROUTINE mp_sum_root_im(msg, root, comm)
6488 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6489 INTEGER, INTENT(IN) :: root
6490 CLASS(mp_comm_type), INTENT(IN) :: comm
6491
6492 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
6493
6494 INTEGER :: handle
6495#if defined(__parallel)
6496 INTEGER :: ierr, m1, m2, msglen, taskid
6497 INTEGER(KIND=int_4), ALLOCATABLE :: res(:, :)
6498#endif
6499
6500 CALL mp_timeset(routinen, handle)
6501
6502#if defined(__parallel)
6503 msglen = SIZE(msg)
6504 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6505 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6506 IF (msglen > 0) THEN
6507 m1 = SIZE(msg, 1)
6508 m2 = SIZE(msg, 2)
6509 ALLOCATE (res(m1, m2))
6510 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_sum, root, comm%handle, ierr)
6511 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6512 IF (taskid == root) THEN
6513 msg = res
6514 END IF
6515 DEALLOCATE (res)
6516 END IF
6517 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6518#else
6519 mark_used(root)
6520 mark_used(msg)
6521 mark_used(comm)
6522#endif
6523 CALL mp_timestop(handle)
6524 END SUBROUTINE mp_sum_root_im
6525
6526! **************************************************************************************************
6527!> \brief Partial sum of data from all processes with result on each process.
6528!> \param[in] msg Matrix to sum (input)
6529!> \param[out] res Matrix containing result (output)
6530!> \param[in] comm Message passing environment identifier
6531! **************************************************************************************************
6532 SUBROUTINE mp_sum_partial_im(msg, res, comm)
6533 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
6534 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
6535 CLASS(mp_comm_type), INTENT(IN) :: comm
6536
6537 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_im'
6538
6539 INTEGER :: handle
6540#if defined(__parallel)
6541 INTEGER :: ierr, msglen, taskid
6542#endif
6543
6544 CALL mp_timeset(routinen, handle)
6545
6546#if defined(__parallel)
6547 msglen = SIZE(msg)
6548 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6549 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6550 IF (msglen > 0) THEN
6551 CALL mpi_scan(msg, res, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6552 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
6553 END IF
6554 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6555 ! perf_id is same as for other summation routines
6556#else
6557 res = msg
6558 mark_used(comm)
6559#endif
6560 CALL mp_timestop(handle)
6561 END SUBROUTINE mp_sum_partial_im
6562
6563! **************************************************************************************************
6564!> \brief Finds the maximum of a datum with the result left on all processes.
6565!> \param[in,out] msg Find maximum among these data (input) and
6566!> maximum (output)
6567!> \param[in] comm Message passing environment identifier
6568!> \par MPI mapping
6569!> mpi_allreduce
6570! **************************************************************************************************
6571 SUBROUTINE mp_max_i (msg, comm)
6572 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6573 CLASS(mp_comm_type), INTENT(IN) :: comm
6574
6575 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_i'
6576
6577 INTEGER :: handle
6578#if defined(__parallel)
6579 INTEGER :: ierr, msglen
6580#endif
6581
6582 CALL mp_timeset(routinen, handle)
6583
6584#if defined(__parallel)
6585 msglen = 1
6586 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6587 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6588 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6589#else
6590 mark_used(msg)
6591 mark_used(comm)
6592#endif
6593 CALL mp_timestop(handle)
6594 END SUBROUTINE mp_max_i
6595
6596! **************************************************************************************************
6597!> \brief Finds the maximum of a datum with the result left on all processes.
6598!> \param[in,out] msg Find maximum among these data (input) and
6599!> maximum (output)
6600!> \param[in] comm Message passing environment identifier
6601!> \par MPI mapping
6602!> mpi_allreduce
6603! **************************************************************************************************
6604 SUBROUTINE mp_max_root_i (msg, root, comm)
6605 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6606 INTEGER, INTENT(IN) :: root
6607 CLASS(mp_comm_type), INTENT(IN) :: comm
6608
6609 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_i'
6610
6611 INTEGER :: handle
6612#if defined(__parallel)
6613 INTEGER :: ierr, msglen
6614 INTEGER(KIND=int_4) :: res
6615#endif
6616
6617 CALL mp_timeset(routinen, handle)
6618
6619#if defined(__parallel)
6620 msglen = 1
6621 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_max, root, comm%handle, ierr)
6622 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6623 IF (root == comm%mepos) msg = res
6624 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6625#else
6626 mark_used(msg)
6627 mark_used(comm)
6628 mark_used(root)
6629#endif
6630 CALL mp_timestop(handle)
6631 END SUBROUTINE mp_max_root_i
6632
6633! **************************************************************************************************
6634!> \brief Finds the element-wise maximum of a vector with the result left on
6635!> all processes.
6636!> \param[in,out] msg Find maximum among these data (input) and
6637!> maximum (output)
6638!> \param comm ...
6639!> \note see mp_max_i
6640! **************************************************************************************************
6641 SUBROUTINE mp_max_iv(msg, comm)
6642 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6643 CLASS(mp_comm_type), INTENT(IN) :: comm
6644
6645 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_iv'
6646
6647 INTEGER :: handle
6648#if defined(__parallel)
6649 INTEGER :: ierr, msglen
6650#endif
6651
6652 CALL mp_timeset(routinen, handle)
6653
6654#if defined(__parallel)
6655 msglen = SIZE(msg)
6656 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6657 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6658 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6659#else
6660 mark_used(msg)
6661 mark_used(comm)
6662#endif
6663 CALL mp_timestop(handle)
6664 END SUBROUTINE mp_max_iv
6665
6666! **************************************************************************************************
6667!> \brief Finds the element-wise maximum of a vector with the result left on
6668!> all processes.
6669!> \param[in,out] msg Find maximum among these data (input) and
6670!> maximum (output)
6671!> \param comm ...
6672!> \note see mp_max_i
6673! **************************************************************************************************
6674 SUBROUTINE mp_max_root_im(msg, root, comm)
6675 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6676 INTEGER :: root
6677 CLASS(mp_comm_type), INTENT(IN) :: comm
6678
6679 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_im'
6680
6681 INTEGER :: handle
6682#if defined(__parallel)
6683 INTEGER :: ierr, msglen
6684 INTEGER(KIND=int_4) :: res(size(msg, 1), size(msg, 2))
6685#endif
6686
6687 CALL mp_timeset(routinen, handle)
6688
6689#if defined(__parallel)
6690 msglen = SIZE(msg)
6691 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_max, root, comm%handle, ierr)
6692 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6693 IF (root == comm%mepos) msg = res
6694 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6695#else
6696 mark_used(msg)
6697 mark_used(comm)
6698 mark_used(root)
6699#endif
6700 CALL mp_timestop(handle)
6701 END SUBROUTINE mp_max_root_im
6702
6703! **************************************************************************************************
6704!> \brief Finds the minimum of a datum with the result left on all processes.
6705!> \param[in,out] msg Find minimum among these data (input) and
6706!> maximum (output)
6707!> \param[in] comm Message passing environment identifier
6708!> \par MPI mapping
6709!> mpi_allreduce
6710! **************************************************************************************************
6711 SUBROUTINE mp_min_i (msg, comm)
6712 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6713 CLASS(mp_comm_type), INTENT(IN) :: comm
6714
6715 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_i'
6716
6717 INTEGER :: handle
6718#if defined(__parallel)
6719 INTEGER :: ierr, msglen
6720#endif
6721
6722 CALL mp_timeset(routinen, handle)
6723
6724#if defined(__parallel)
6725 msglen = 1
6726 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6727 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6728 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6729#else
6730 mark_used(msg)
6731 mark_used(comm)
6732#endif
6733 CALL mp_timestop(handle)
6734 END SUBROUTINE mp_min_i
6735
6736! **************************************************************************************************
6737!> \brief Finds the element-wise minimum of vector with the result left on
6738!> all processes.
6739!> \param[in,out] msg Find minimum among these data (input) and
6740!> maximum (output)
6741!> \param comm ...
6742!> \par MPI mapping
6743!> mpi_allreduce
6744!> \note see mp_min_i
6745! **************************************************************************************************
6746 SUBROUTINE mp_min_iv(msg, comm)
6747 INTEGER(KIND=int_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
6748 CLASS(mp_comm_type), INTENT(IN) :: comm
6749
6750 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_iv'
6751
6752 INTEGER :: handle
6753#if defined(__parallel)
6754 INTEGER :: ierr, msglen
6755#endif
6756
6757 CALL mp_timeset(routinen, handle)
6758
6759#if defined(__parallel)
6760 msglen = SIZE(msg)
6761 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6762 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6763 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6764#else
6765 mark_used(msg)
6766 mark_used(comm)
6767#endif
6768 CALL mp_timestop(handle)
6769 END SUBROUTINE mp_min_iv
6770
6771! **************************************************************************************************
6772!> \brief Multiplies a set of numbers scattered across a number of processes,
6773!> then replicates the result.
6774!> \param[in,out] msg a number to multiply (input) and result (output)
6775!> \param[in] comm message passing environment identifier
6776!> \par MPI mapping
6777!> mpi_allreduce
6778! **************************************************************************************************
6779 SUBROUTINE mp_prod_i (msg, comm)
6780 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6781 CLASS(mp_comm_type), INTENT(IN) :: comm
6782
6783 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_i'
6784
6785 INTEGER :: handle
6786#if defined(__parallel)
6787 INTEGER :: ierr, msglen
6788#endif
6789
6790 CALL mp_timeset(routinen, handle)
6791
6792#if defined(__parallel)
6793 msglen = 1
6794 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_prod, comm%handle, ierr)
6795 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6796 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6797#else
6798 mark_used(msg)
6799 mark_used(comm)
6800#endif
6801 CALL mp_timestop(handle)
6802 END SUBROUTINE mp_prod_i
6803
6804! **************************************************************************************************
6805!> \brief Scatters data from one processes to all others
6806!> \param[in] msg_scatter Data to scatter (for root process)
6807!> \param[out] msg Received data
6808!> \param[in] root Process which scatters data
6809!> \param[in] comm Message passing environment identifier
6810!> \par MPI mapping
6811!> mpi_scatter
6812! **************************************************************************************************
6813 SUBROUTINE mp_scatter_iv(msg_scatter, msg, root, comm)
6814 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
6815 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
6816 INTEGER, INTENT(IN) :: root
6817 CLASS(mp_comm_type), INTENT(IN) :: comm
6818
6819 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_iv'
6820
6821 INTEGER :: handle
6822#if defined(__parallel)
6823 INTEGER :: ierr, msglen
6824#endif
6825
6826 CALL mp_timeset(routinen, handle)
6827
6828#if defined(__parallel)
6829 msglen = SIZE(msg)
6830 CALL mpi_scatter(msg_scatter, msglen, mpi_integer, msg, &
6831 msglen, mpi_integer, root, comm%handle, ierr)
6832 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
6833 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6834#else
6835 mark_used(root)
6836 mark_used(comm)
6837 msg = msg_scatter
6838#endif
6839 CALL mp_timestop(handle)
6840 END SUBROUTINE mp_scatter_iv
6841
6842! **************************************************************************************************
6843!> \brief Scatters data from one processes to all others
6844!> \param[in] msg_scatter Data to scatter (for root process)
6845!> \param[in] root Process which scatters data
6846!> \param[in] comm Message passing environment identifier
6847!> \par MPI mapping
6848!> mpi_scatter
6849! **************************************************************************************************
6850 SUBROUTINE mp_iscatter_i (msg_scatter, msg, root, comm, request)
6851 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:)
6852 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6853 INTEGER, INTENT(IN) :: root
6854 CLASS(mp_comm_type), INTENT(IN) :: comm
6855 TYPE(mp_request_type), INTENT(OUT) :: request
6856
6857 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_i'
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#if !defined(__GNUC__) || __GNUC__ >= 9
6868 cpassert(is_contiguous(msg_scatter))
6869#endif
6870 msglen = 1
6871 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer, msg, &
6872 msglen, mpi_integer, root, comm%handle, request%handle, ierr)
6873 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
6874 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6875#else
6876 mark_used(root)
6877 mark_used(comm)
6878 msg = msg_scatter(1)
6879 request = mp_request_null
6880#endif
6881 CALL mp_timestop(handle)
6882 END SUBROUTINE mp_iscatter_i
6883
6884! **************************************************************************************************
6885!> \brief Scatters data from one processes to all others
6886!> \param[in] msg_scatter Data to scatter (for root process)
6887!> \param[in] root Process which scatters data
6888!> \param[in] comm Message passing environment identifier
6889!> \par MPI mapping
6890!> mpi_scatter
6891! **************************************************************************************************
6892 SUBROUTINE mp_iscatter_iv2(msg_scatter, msg, root, comm, request)
6893 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:, :)
6894 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6895 INTEGER, INTENT(IN) :: root
6896 CLASS(mp_comm_type), INTENT(IN) :: comm
6897 TYPE(mp_request_type), INTENT(OUT) :: request
6898
6899 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_iv2'
6900
6901 INTEGER :: handle
6902#if defined(__parallel)
6903 INTEGER :: ierr, msglen
6904#endif
6905
6906 CALL mp_timeset(routinen, handle)
6907
6908#if defined(__parallel)
6909#if !defined(__GNUC__) || __GNUC__ >= 9
6910 cpassert(is_contiguous(msg_scatter))
6911#endif
6912 msglen = SIZE(msg)
6913 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer, msg, &
6914 msglen, mpi_integer, root, comm%handle, request%handle, ierr)
6915 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
6916 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6917#else
6918 mark_used(root)
6919 mark_used(comm)
6920 msg(:) = msg_scatter(:, 1)
6921 request = mp_request_null
6922#endif
6923 CALL mp_timestop(handle)
6924 END SUBROUTINE mp_iscatter_iv2
6925
6926! **************************************************************************************************
6927!> \brief Scatters data from one processes to all others
6928!> \param[in] msg_scatter Data to scatter (for root process)
6929!> \param[in] root Process which scatters data
6930!> \param[in] comm Message passing environment identifier
6931!> \par MPI mapping
6932!> mpi_scatter
6933! **************************************************************************************************
6934 SUBROUTINE mp_iscatterv_iv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
6935 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:)
6936 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
6937 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6938 INTEGER, INTENT(IN) :: recvcount, root
6939 CLASS(mp_comm_type), INTENT(IN) :: comm
6940 TYPE(mp_request_type), INTENT(OUT) :: request
6941
6942 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_iv'
6943
6944 INTEGER :: handle
6945#if defined(__parallel)
6946 INTEGER :: ierr
6947#endif
6948
6949 CALL mp_timeset(routinen, handle)
6950
6951#if defined(__parallel)
6952#if !defined(__GNUC__) || __GNUC__ >= 9
6953 cpassert(is_contiguous(msg_scatter))
6954 cpassert(is_contiguous(msg))
6955 cpassert(is_contiguous(sendcounts))
6956 cpassert(is_contiguous(displs))
6957#endif
6958 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_integer, msg, &
6959 recvcount, mpi_integer, root, comm%handle, request%handle, ierr)
6960 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
6961 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6962#else
6963 mark_used(sendcounts)
6964 mark_used(displs)
6965 mark_used(recvcount)
6966 mark_used(root)
6967 mark_used(comm)
6968 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
6969 request = mp_request_null
6970#endif
6971 CALL mp_timestop(handle)
6972 END SUBROUTINE mp_iscatterv_iv
6973
6974! **************************************************************************************************
6975!> \brief Gathers a datum from all processes to one
6976!> \param[in] msg Datum to send to root
6977!> \param[out] msg_gather Received data (on root)
6978!> \param[in] root Process which gathers the data
6979!> \param[in] comm Message passing environment identifier
6980!> \par MPI mapping
6981!> mpi_gather
6982! **************************************************************************************************
6983 SUBROUTINE mp_gather_i (msg, msg_gather, root, comm)
6984 INTEGER(KIND=int_4), INTENT(IN) :: msg
6985 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
6986 INTEGER, INTENT(IN) :: root
6987 CLASS(mp_comm_type), INTENT(IN) :: comm
6988
6989 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_i'
6990
6991 INTEGER :: handle
6992#if defined(__parallel)
6993 INTEGER :: ierr, msglen
6994#endif
6995
6996 CALL mp_timeset(routinen, handle)
6997
6998#if defined(__parallel)
6999 msglen = 1
7000 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7001 msglen, mpi_integer, root, comm%handle, ierr)
7002 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7003 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7004#else
7005 mark_used(root)
7006 mark_used(comm)
7007 msg_gather(1) = msg
7008#endif
7009 CALL mp_timestop(handle)
7010 END SUBROUTINE mp_gather_i
7011
7012! **************************************************************************************************
7013!> \brief Gathers a datum from all processes to one, uses the source process of comm
7014!> \param[in] msg Datum to send to root
7015!> \param[out] msg_gather Received data (on root)
7016!> \param[in] comm Message passing environment identifier
7017!> \par MPI mapping
7018!> mpi_gather
7019! **************************************************************************************************
7020 SUBROUTINE mp_gather_i_src(msg, msg_gather, comm)
7021 INTEGER(KIND=int_4), INTENT(IN) :: msg
7022 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7023 CLASS(mp_comm_type), INTENT(IN) :: comm
7024
7025 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_i_src'
7026
7027 INTEGER :: handle
7028#if defined(__parallel)
7029 INTEGER :: ierr, msglen
7030#endif
7031
7032 CALL mp_timeset(routinen, handle)
7033
7034#if defined(__parallel)
7035 msglen = 1
7036 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7037 msglen, mpi_integer, comm%source, comm%handle, ierr)
7038 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7039 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7040#else
7041 mark_used(comm)
7042 msg_gather(1) = msg
7043#endif
7044 CALL mp_timestop(handle)
7045 END SUBROUTINE mp_gather_i_src
7046
7047! **************************************************************************************************
7048!> \brief Gathers data from all processes to one
7049!> \param[in] msg Datum to send to root
7050!> \param msg_gather ...
7051!> \param root ...
7052!> \param comm ...
7053!> \par Data length
7054!> All data (msg) is equal-sized
7055!> \par MPI mapping
7056!> mpi_gather
7057!> \note see mp_gather_i
7058! **************************************************************************************************
7059 SUBROUTINE mp_gather_iv(msg, msg_gather, root, comm)
7060 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
7061 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7062 INTEGER, INTENT(IN) :: root
7063 CLASS(mp_comm_type), INTENT(IN) :: comm
7064
7065 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_iv'
7066
7067 INTEGER :: handle
7068#if defined(__parallel)
7069 INTEGER :: ierr, msglen
7070#endif
7071
7072 CALL mp_timeset(routinen, handle)
7073
7074#if defined(__parallel)
7075 msglen = SIZE(msg)
7076 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7077 msglen, mpi_integer, root, comm%handle, ierr)
7078 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7079 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7080#else
7081 mark_used(root)
7082 mark_used(comm)
7083 msg_gather = msg
7084#endif
7085 CALL mp_timestop(handle)
7086 END SUBROUTINE mp_gather_iv
7087
7088! **************************************************************************************************
7089!> \brief Gathers data from all processes to one. Gathers from comm%source
7090!> \param[in] msg Datum to send to root
7091!> \param msg_gather ...
7092!> \param comm ...
7093!> \par Data length
7094!> All data (msg) is equal-sized
7095!> \par MPI mapping
7096!> mpi_gather
7097!> \note see mp_gather_i
7098! **************************************************************************************************
7099 SUBROUTINE mp_gather_iv_src(msg, msg_gather, comm)
7100 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
7101 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7102 CLASS(mp_comm_type), INTENT(IN) :: comm
7103
7104 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_iv_src'
7105
7106 INTEGER :: handle
7107#if defined(__parallel)
7108 INTEGER :: ierr, msglen
7109#endif
7110
7111 CALL mp_timeset(routinen, handle)
7112
7113#if defined(__parallel)
7114 msglen = SIZE(msg)
7115 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7116 msglen, mpi_integer, comm%source, comm%handle, ierr)
7117 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7118 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7119#else
7120 mark_used(comm)
7121 msg_gather = msg
7122#endif
7123 CALL mp_timestop(handle)
7124 END SUBROUTINE mp_gather_iv_src
7125
7126! **************************************************************************************************
7127!> \brief Gathers data from all processes to one
7128!> \param[in] msg Datum to send to root
7129!> \param msg_gather ...
7130!> \param root ...
7131!> \param comm ...
7132!> \par Data length
7133!> All data (msg) is equal-sized
7134!> \par MPI mapping
7135!> mpi_gather
7136!> \note see mp_gather_i
7137! **************************************************************************************************
7138 SUBROUTINE mp_gather_im(msg, msg_gather, root, comm)
7139 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
7140 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
7141 INTEGER, INTENT(IN) :: root
7142 CLASS(mp_comm_type), INTENT(IN) :: comm
7143
7144 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_im'
7145
7146 INTEGER :: handle
7147#if defined(__parallel)
7148 INTEGER :: ierr, msglen
7149#endif
7150
7151 CALL mp_timeset(routinen, handle)
7152
7153#if defined(__parallel)
7154 msglen = SIZE(msg)
7155 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7156 msglen, mpi_integer, root, comm%handle, ierr)
7157 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7158 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7159#else
7160 mark_used(root)
7161 mark_used(comm)
7162 msg_gather = msg
7163#endif
7164 CALL mp_timestop(handle)
7165 END SUBROUTINE mp_gather_im
7166
7167! **************************************************************************************************
7168!> \brief Gathers data from all processes to one. Gathers from comm%source
7169!> \param[in] msg Datum to send to root
7170!> \param msg_gather ...
7171!> \param comm ...
7172!> \par Data length
7173!> All data (msg) is equal-sized
7174!> \par MPI mapping
7175!> mpi_gather
7176!> \note see mp_gather_i
7177! **************************************************************************************************
7178 SUBROUTINE mp_gather_im_src(msg, msg_gather, comm)
7179 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
7180 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
7181 CLASS(mp_comm_type), INTENT(IN) :: comm
7182
7183 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_im_src'
7184
7185 INTEGER :: handle
7186#if defined(__parallel)
7187 INTEGER :: ierr, msglen
7188#endif
7189
7190 CALL mp_timeset(routinen, handle)
7191
7192#if defined(__parallel)
7193 msglen = SIZE(msg)
7194 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7195 msglen, mpi_integer, comm%source, comm%handle, ierr)
7196 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7197 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7198#else
7199 mark_used(comm)
7200 msg_gather = msg
7201#endif
7202 CALL mp_timestop(handle)
7203 END SUBROUTINE mp_gather_im_src
7204
7205! **************************************************************************************************
7206!> \brief Gathers data from all processes to one.
7207!> \param[in] sendbuf Data to send to root
7208!> \param[out] recvbuf Received data (on root)
7209!> \param[in] recvcounts Sizes of data received from processes
7210!> \param[in] displs Offsets of data received from processes
7211!> \param[in] root Process which gathers the data
7212!> \param[in] comm Message passing environment identifier
7213!> \par Data length
7214!> Data can have different lengths
7215!> \par Offsets
7216!> Offsets start at 0
7217!> \par MPI mapping
7218!> mpi_gather
7219! **************************************************************************************************
7220 SUBROUTINE mp_gatherv_iv(sendbuf, recvbuf, recvcounts, displs, root, comm)
7221
7222 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
7223 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
7224 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7225 INTEGER, INTENT(IN) :: root
7226 CLASS(mp_comm_type), INTENT(IN) :: comm
7227
7228 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_iv'
7229
7230 INTEGER :: handle
7231#if defined(__parallel)
7232 INTEGER :: ierr, sendcount
7233#endif
7234
7235 CALL mp_timeset(routinen, handle)
7236
7237#if defined(__parallel)
7238 sendcount = SIZE(sendbuf)
7239 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7240 recvbuf, recvcounts, displs, mpi_integer, &
7241 root, comm%handle, ierr)
7242 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7243 CALL add_perf(perf_id=4, &
7244 count=1, &
7245 msg_size=sendcount*int_4_size)
7246#else
7247 mark_used(recvcounts)
7248 mark_used(root)
7249 mark_used(comm)
7250 recvbuf(1 + displs(1):) = sendbuf
7251#endif
7252 CALL mp_timestop(handle)
7253 END SUBROUTINE mp_gatherv_iv
7254
7255! **************************************************************************************************
7256!> \brief Gathers data from all processes to one. Gathers from comm%source
7257!> \param[in] sendbuf Data to send to root
7258!> \param[out] recvbuf Received data (on root)
7259!> \param[in] recvcounts Sizes of data received from processes
7260!> \param[in] displs Offsets of data received from processes
7261!> \param[in] comm Message passing environment identifier
7262!> \par Data length
7263!> Data can have different lengths
7264!> \par Offsets
7265!> Offsets start at 0
7266!> \par MPI mapping
7267!> mpi_gather
7268! **************************************************************************************************
7269 SUBROUTINE mp_gatherv_iv_src(sendbuf, recvbuf, recvcounts, displs, comm)
7270
7271 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
7272 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
7273 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7274 CLASS(mp_comm_type), INTENT(IN) :: comm
7275
7276 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_iv_src'
7277
7278 INTEGER :: handle
7279#if defined(__parallel)
7280 INTEGER :: ierr, sendcount
7281#endif
7282
7283 CALL mp_timeset(routinen, handle)
7284
7285#if defined(__parallel)
7286 sendcount = SIZE(sendbuf)
7287 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7288 recvbuf, recvcounts, displs, mpi_integer, &
7289 comm%source, comm%handle, ierr)
7290 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7291 CALL add_perf(perf_id=4, &
7292 count=1, &
7293 msg_size=sendcount*int_4_size)
7294#else
7295 mark_used(recvcounts)
7296 mark_used(comm)
7297 recvbuf(1 + displs(1):) = sendbuf
7298#endif
7299 CALL mp_timestop(handle)
7300 END SUBROUTINE mp_gatherv_iv_src
7301
7302! **************************************************************************************************
7303!> \brief Gathers data from all processes to one.
7304!> \param[in] sendbuf Data to send to root
7305!> \param[out] recvbuf Received data (on root)
7306!> \param[in] recvcounts Sizes of data received from processes
7307!> \param[in] displs Offsets of data received from processes
7308!> \param[in] root Process which gathers the data
7309!> \param[in] comm Message passing environment identifier
7310!> \par Data length
7311!> Data can have different lengths
7312!> \par Offsets
7313!> Offsets start at 0
7314!> \par MPI mapping
7315!> mpi_gather
7316! **************************************************************************************************
7317 SUBROUTINE mp_gatherv_im2(sendbuf, recvbuf, recvcounts, displs, root, comm)
7318
7319 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
7320 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
7321 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7322 INTEGER, INTENT(IN) :: root
7323 CLASS(mp_comm_type), INTENT(IN) :: comm
7324
7325 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_im2'
7326
7327 INTEGER :: handle
7328#if defined(__parallel)
7329 INTEGER :: ierr, sendcount
7330#endif
7331
7332 CALL mp_timeset(routinen, handle)
7333
7334#if defined(__parallel)
7335 sendcount = SIZE(sendbuf)
7336 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7337 recvbuf, recvcounts, displs, mpi_integer, &
7338 root, comm%handle, ierr)
7339 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7340 CALL add_perf(perf_id=4, &
7341 count=1, &
7342 msg_size=sendcount*int_4_size)
7343#else
7344 mark_used(recvcounts)
7345 mark_used(root)
7346 mark_used(comm)
7347 recvbuf(:, 1 + displs(1):) = sendbuf
7348#endif
7349 CALL mp_timestop(handle)
7350 END SUBROUTINE mp_gatherv_im2
7351
7352! **************************************************************************************************
7353!> \brief Gathers data from all processes to one.
7354!> \param[in] sendbuf Data to send to root
7355!> \param[out] recvbuf Received data (on root)
7356!> \param[in] recvcounts Sizes of data received from processes
7357!> \param[in] displs Offsets of data received from processes
7358!> \param[in] comm Message passing environment identifier
7359!> \par Data length
7360!> Data can have different lengths
7361!> \par Offsets
7362!> Offsets start at 0
7363!> \par MPI mapping
7364!> mpi_gather
7365! **************************************************************************************************
7366 SUBROUTINE mp_gatherv_im2_src(sendbuf, recvbuf, recvcounts, displs, comm)
7367
7368 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
7369 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
7370 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7371 CLASS(mp_comm_type), INTENT(IN) :: comm
7372
7373 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_im2_src'
7374
7375 INTEGER :: handle
7376#if defined(__parallel)
7377 INTEGER :: ierr, sendcount
7378#endif
7379
7380 CALL mp_timeset(routinen, handle)
7381
7382#if defined(__parallel)
7383 sendcount = SIZE(sendbuf)
7384 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7385 recvbuf, recvcounts, displs, mpi_integer, &
7386 comm%source, comm%handle, ierr)
7387 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7388 CALL add_perf(perf_id=4, &
7389 count=1, &
7390 msg_size=sendcount*int_4_size)
7391#else
7392 mark_used(recvcounts)
7393 mark_used(comm)
7394 recvbuf(:, 1 + displs(1):) = sendbuf
7395#endif
7396 CALL mp_timestop(handle)
7397 END SUBROUTINE mp_gatherv_im2_src
7398
7399! **************************************************************************************************
7400!> \brief Gathers data from all processes to one.
7401!> \param[in] sendbuf Data to send to root
7402!> \param[out] recvbuf Received data (on root)
7403!> \param[in] recvcounts Sizes of data received from processes
7404!> \param[in] displs Offsets of data received from processes
7405!> \param[in] root Process which gathers the data
7406!> \param[in] comm Message passing environment identifier
7407!> \par Data length
7408!> Data can have different lengths
7409!> \par Offsets
7410!> Offsets start at 0
7411!> \par MPI mapping
7412!> mpi_gather
7413! **************************************************************************************************
7414 SUBROUTINE mp_igatherv_iv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
7415 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: sendbuf
7416 INTEGER(KIND=int_4), DIMENSION(:), INTENT(OUT) :: recvbuf
7417 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7418 INTEGER, INTENT(IN) :: sendcount, root
7419 CLASS(mp_comm_type), INTENT(IN) :: comm
7420 TYPE(mp_request_type), INTENT(OUT) :: request
7421
7422 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_iv'
7423
7424 INTEGER :: handle
7425#if defined(__parallel)
7426 INTEGER :: ierr
7427#endif
7428
7429 CALL mp_timeset(routinen, handle)
7430
7431#if defined(__parallel)
7432#if !defined(__GNUC__) || __GNUC__ >= 9
7433 cpassert(is_contiguous(sendbuf))
7434 cpassert(is_contiguous(recvbuf))
7435 cpassert(is_contiguous(recvcounts))
7436 cpassert(is_contiguous(displs))
7437#endif
7438 CALL mpi_igatherv(sendbuf, sendcount, mpi_integer, &
7439 recvbuf, recvcounts, displs, mpi_integer, &
7440 root, comm%handle, request%handle, ierr)
7441 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7442 CALL add_perf(perf_id=24, &
7443 count=1, &
7444 msg_size=sendcount*int_4_size)
7445#else
7446 mark_used(sendcount)
7447 mark_used(recvcounts)
7448 mark_used(root)
7449 mark_used(comm)
7450 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
7451 request = mp_request_null
7452#endif
7453 CALL mp_timestop(handle)
7454 END SUBROUTINE mp_igatherv_iv
7455
7456! **************************************************************************************************
7457!> \brief Gathers a datum from all processes and all processes receive the
7458!> same data
7459!> \param[in] msgout Datum to send
7460!> \param[out] msgin Received data
7461!> \param[in] comm Message passing environment identifier
7462!> \par Data size
7463!> All processes send equal-sized data
7464!> \par MPI mapping
7465!> mpi_allgather
7466! **************************************************************************************************
7467 SUBROUTINE mp_allgather_i (msgout, msgin, comm)
7468 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7469 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
7470 CLASS(mp_comm_type), INTENT(IN) :: comm
7471
7472 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i'
7473
7474 INTEGER :: handle
7475#if defined(__parallel)
7476 INTEGER :: ierr, rcount, scount
7477#endif
7478
7479 CALL mp_timeset(routinen, handle)
7480
7481#if defined(__parallel)
7482 scount = 1
7483 rcount = 1
7484 CALL mpi_allgather(msgout, scount, mpi_integer, &
7485 msgin, rcount, mpi_integer, &
7486 comm%handle, ierr)
7487 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7488#else
7489 mark_used(comm)
7490 msgin = msgout
7491#endif
7492 CALL mp_timestop(handle)
7493 END SUBROUTINE mp_allgather_i
7494
7495! **************************************************************************************************
7496!> \brief Gathers a datum from all processes and all processes receive the
7497!> same data
7498!> \param[in] msgout Datum to send
7499!> \param[out] msgin Received data
7500!> \param[in] comm Message passing environment identifier
7501!> \par Data size
7502!> All processes send equal-sized data
7503!> \par MPI mapping
7504!> mpi_allgather
7505! **************************************************************************************************
7506 SUBROUTINE mp_allgather_i2(msgout, msgin, comm)
7507 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7508 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7509 CLASS(mp_comm_type), INTENT(IN) :: comm
7510
7511 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i2'
7512
7513 INTEGER :: handle
7514#if defined(__parallel)
7515 INTEGER :: ierr, rcount, scount
7516#endif
7517
7518 CALL mp_timeset(routinen, handle)
7519
7520#if defined(__parallel)
7521 scount = 1
7522 rcount = 1
7523 CALL mpi_allgather(msgout, scount, mpi_integer, &
7524 msgin, rcount, mpi_integer, &
7525 comm%handle, ierr)
7526 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7527#else
7528 mark_used(comm)
7529 msgin = msgout
7530#endif
7531 CALL mp_timestop(handle)
7532 END SUBROUTINE mp_allgather_i2
7533
7534! **************************************************************************************************
7535!> \brief Gathers a datum from all processes and all processes receive the
7536!> same data
7537!> \param[in] msgout Datum to send
7538!> \param[out] msgin Received data
7539!> \param[in] comm Message passing environment identifier
7540!> \par Data size
7541!> All processes send equal-sized data
7542!> \par MPI mapping
7543!> mpi_allgather
7544! **************************************************************************************************
7545 SUBROUTINE mp_iallgather_i (msgout, msgin, comm, request)
7546 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7547 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7548 CLASS(mp_comm_type), INTENT(IN) :: comm
7549 TYPE(mp_request_type), INTENT(OUT) :: request
7550
7551 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i'
7552
7553 INTEGER :: handle
7554#if defined(__parallel)
7555 INTEGER :: ierr, rcount, scount
7556#endif
7557
7558 CALL mp_timeset(routinen, handle)
7559
7560#if defined(__parallel)
7561#if !defined(__GNUC__) || __GNUC__ >= 9
7562 cpassert(is_contiguous(msgin))
7563#endif
7564 scount = 1
7565 rcount = 1
7566 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7567 msgin, rcount, mpi_integer, &
7568 comm%handle, request%handle, ierr)
7569 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7570#else
7571 mark_used(comm)
7572 msgin = msgout
7573 request = mp_request_null
7574#endif
7575 CALL mp_timestop(handle)
7576 END SUBROUTINE mp_iallgather_i
7577
7578! **************************************************************************************************
7579!> \brief Gathers vector data from all processes and all processes receive the
7580!> same data
7581!> \param[in] msgout Rank-1 data to send
7582!> \param[out] msgin Received data
7583!> \param[in] comm Message passing environment identifier
7584!> \par Data size
7585!> All processes send equal-sized data
7586!> \par Ranks
7587!> The last rank counts the processes
7588!> \par MPI mapping
7589!> mpi_allgather
7590! **************************************************************************************************
7591 SUBROUTINE mp_allgather_i12(msgout, msgin, comm)
7592 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:)
7593 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7594 CLASS(mp_comm_type), INTENT(IN) :: comm
7595
7596 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i12'
7597
7598 INTEGER :: handle
7599#if defined(__parallel)
7600 INTEGER :: ierr, rcount, scount
7601#endif
7602
7603 CALL mp_timeset(routinen, handle)
7604
7605#if defined(__parallel)
7606 scount = SIZE(msgout(:))
7607 rcount = scount
7608 CALL mpi_allgather(msgout, scount, mpi_integer, &
7609 msgin, rcount, mpi_integer, &
7610 comm%handle, ierr)
7611 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7612#else
7613 mark_used(comm)
7614 msgin(:, 1) = msgout(:)
7615#endif
7616 CALL mp_timestop(handle)
7617 END SUBROUTINE mp_allgather_i12
7618
7619! **************************************************************************************************
7620!> \brief Gathers matrix data from all processes and all processes receive the
7621!> same data
7622!> \param[in] msgout Rank-2 data to send
7623!> \param msgin ...
7624!> \param comm ...
7625!> \note see mp_allgather_i12
7626! **************************************************************************************************
7627 SUBROUTINE mp_allgather_i23(msgout, msgin, comm)
7628 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
7629 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
7630 CLASS(mp_comm_type), INTENT(IN) :: comm
7631
7632 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i23'
7633
7634 INTEGER :: handle
7635#if defined(__parallel)
7636 INTEGER :: ierr, rcount, scount
7637#endif
7638
7639 CALL mp_timeset(routinen, handle)
7640
7641#if defined(__parallel)
7642 scount = SIZE(msgout(:, :))
7643 rcount = scount
7644 CALL mpi_allgather(msgout, scount, mpi_integer, &
7645 msgin, rcount, mpi_integer, &
7646 comm%handle, ierr)
7647 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7648#else
7649 mark_used(comm)
7650 msgin(:, :, 1) = msgout(:, :)
7651#endif
7652 CALL mp_timestop(handle)
7653 END SUBROUTINE mp_allgather_i23
7654
7655! **************************************************************************************************
7656!> \brief Gathers rank-3 data from all processes and all processes receive the
7657!> same data
7658!> \param[in] msgout Rank-3 data to send
7659!> \param msgin ...
7660!> \param comm ...
7661!> \note see mp_allgather_i12
7662! **************************************************************************************************
7663 SUBROUTINE mp_allgather_i34(msgout, msgin, comm)
7664 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
7665 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
7666 CLASS(mp_comm_type), INTENT(IN) :: comm
7667
7668 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i34'
7669
7670 INTEGER :: handle
7671#if defined(__parallel)
7672 INTEGER :: ierr, rcount, scount
7673#endif
7674
7675 CALL mp_timeset(routinen, handle)
7676
7677#if defined(__parallel)
7678 scount = SIZE(msgout(:, :, :))
7679 rcount = scount
7680 CALL mpi_allgather(msgout, scount, mpi_integer, &
7681 msgin, rcount, mpi_integer, &
7682 comm%handle, ierr)
7683 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7684#else
7685 mark_used(comm)
7686 msgin(:, :, :, 1) = msgout(:, :, :)
7687#endif
7688 CALL mp_timestop(handle)
7689 END SUBROUTINE mp_allgather_i34
7690
7691! **************************************************************************************************
7692!> \brief Gathers rank-2 data from all processes and all processes receive the
7693!> same data
7694!> \param[in] msgout Rank-2 data to send
7695!> \param msgin ...
7696!> \param comm ...
7697!> \note see mp_allgather_i12
7698! **************************************************************************************************
7699 SUBROUTINE mp_allgather_i22(msgout, msgin, comm)
7700 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
7701 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7702 CLASS(mp_comm_type), INTENT(IN) :: comm
7703
7704 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i22'
7705
7706 INTEGER :: handle
7707#if defined(__parallel)
7708 INTEGER :: ierr, rcount, scount
7709#endif
7710
7711 CALL mp_timeset(routinen, handle)
7712
7713#if defined(__parallel)
7714 scount = SIZE(msgout(:, :))
7715 rcount = scount
7716 CALL mpi_allgather(msgout, scount, mpi_integer, &
7717 msgin, rcount, mpi_integer, &
7718 comm%handle, ierr)
7719 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7720#else
7721 mark_used(comm)
7722 msgin(:, :) = msgout(:, :)
7723#endif
7724 CALL mp_timestop(handle)
7725 END SUBROUTINE mp_allgather_i22
7726
7727! **************************************************************************************************
7728!> \brief Gathers rank-1 data from all processes and all processes receive the
7729!> same data
7730!> \param[in] msgout Rank-1 data to send
7731!> \param msgin ...
7732!> \param comm ...
7733!> \param request ...
7734!> \note see mp_allgather_i11
7735! **************************************************************************************************
7736 SUBROUTINE mp_iallgather_i11(msgout, msgin, comm, request)
7737 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7738 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7739 CLASS(mp_comm_type), INTENT(IN) :: comm
7740 TYPE(mp_request_type), INTENT(OUT) :: request
7741
7742 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i11'
7743
7744 INTEGER :: handle
7745#if defined(__parallel)
7746 INTEGER :: ierr, rcount, scount
7747#endif
7748
7749 CALL mp_timeset(routinen, handle)
7750
7751#if defined(__parallel)
7752#if !defined(__GNUC__) || __GNUC__ >= 9
7753 cpassert(is_contiguous(msgout))
7754 cpassert(is_contiguous(msgin))
7755#endif
7756 scount = SIZE(msgout(:))
7757 rcount = scount
7758 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7759 msgin, rcount, mpi_integer, &
7760 comm%handle, request%handle, ierr)
7761 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7762#else
7763 mark_used(comm)
7764 msgin = msgout
7765 request = mp_request_null
7766#endif
7767 CALL mp_timestop(handle)
7768 END SUBROUTINE mp_iallgather_i11
7769
7770! **************************************************************************************************
7771!> \brief Gathers rank-2 data from all processes and all processes receive the
7772!> same data
7773!> \param[in] msgout Rank-2 data to send
7774!> \param msgin ...
7775!> \param comm ...
7776!> \param request ...
7777!> \note see mp_allgather_i12
7778! **************************************************************************************************
7779 SUBROUTINE mp_iallgather_i13(msgout, msgin, comm, request)
7780 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7781 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :)
7782 CLASS(mp_comm_type), INTENT(IN) :: comm
7783 TYPE(mp_request_type), INTENT(OUT) :: request
7784
7785 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i13'
7786
7787 INTEGER :: handle
7788#if defined(__parallel)
7789 INTEGER :: ierr, rcount, scount
7790#endif
7791
7792 CALL mp_timeset(routinen, handle)
7793
7794#if defined(__parallel)
7795#if !defined(__GNUC__) || __GNUC__ >= 9
7796 cpassert(is_contiguous(msgout))
7797 cpassert(is_contiguous(msgin))
7798#endif
7799
7800 scount = SIZE(msgout(:))
7801 rcount = scount
7802 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7803 msgin, rcount, mpi_integer, &
7804 comm%handle, request%handle, ierr)
7805 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7806#else
7807 mark_used(comm)
7808 msgin(:, 1, 1) = msgout(:)
7809 request = mp_request_null
7810#endif
7811 CALL mp_timestop(handle)
7812 END SUBROUTINE mp_iallgather_i13
7813
7814! **************************************************************************************************
7815!> \brief Gathers rank-2 data from all processes and all processes receive the
7816!> same data
7817!> \param[in] msgout Rank-2 data to send
7818!> \param msgin ...
7819!> \param comm ...
7820!> \param request ...
7821!> \note see mp_allgather_i12
7822! **************************************************************************************************
7823 SUBROUTINE mp_iallgather_i22(msgout, msgin, comm, request)
7824 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :)
7825 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :)
7826 CLASS(mp_comm_type), INTENT(IN) :: comm
7827 TYPE(mp_request_type), INTENT(OUT) :: request
7828
7829 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i22'
7830
7831 INTEGER :: handle
7832#if defined(__parallel)
7833 INTEGER :: ierr, rcount, scount
7834#endif
7835
7836 CALL mp_timeset(routinen, handle)
7837
7838#if defined(__parallel)
7839#if !defined(__GNUC__) || __GNUC__ >= 9
7840 cpassert(is_contiguous(msgout))
7841 cpassert(is_contiguous(msgin))
7842#endif
7843
7844 scount = SIZE(msgout(:, :))
7845 rcount = scount
7846 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7847 msgin, rcount, mpi_integer, &
7848 comm%handle, request%handle, ierr)
7849 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7850#else
7851 mark_used(comm)
7852 msgin(:, :) = msgout(:, :)
7853 request = mp_request_null
7854#endif
7855 CALL mp_timestop(handle)
7856 END SUBROUTINE mp_iallgather_i22
7857
7858! **************************************************************************************************
7859!> \brief Gathers rank-2 data from all processes and all processes receive the
7860!> same data
7861!> \param[in] msgout Rank-2 data to send
7862!> \param msgin ...
7863!> \param comm ...
7864!> \param request ...
7865!> \note see mp_allgather_i12
7866! **************************************************************************************************
7867 SUBROUTINE mp_iallgather_i24(msgout, msgin, comm, request)
7868 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :)
7869 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :, :)
7870 CLASS(mp_comm_type), INTENT(IN) :: comm
7871 TYPE(mp_request_type), INTENT(OUT) :: request
7872
7873 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i24'
7874
7875 INTEGER :: handle
7876#if defined(__parallel)
7877 INTEGER :: ierr, rcount, scount
7878#endif
7879
7880 CALL mp_timeset(routinen, handle)
7881
7882#if defined(__parallel)
7883#if !defined(__GNUC__) || __GNUC__ >= 9
7884 cpassert(is_contiguous(msgout))
7885 cpassert(is_contiguous(msgin))
7886#endif
7887
7888 scount = SIZE(msgout(:, :))
7889 rcount = scount
7890 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7891 msgin, rcount, mpi_integer, &
7892 comm%handle, request%handle, ierr)
7893 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7894#else
7895 mark_used(comm)
7896 msgin(:, :, 1, 1) = msgout(:, :)
7897 request = mp_request_null
7898#endif
7899 CALL mp_timestop(handle)
7900 END SUBROUTINE mp_iallgather_i24
7901
7902! **************************************************************************************************
7903!> \brief Gathers rank-3 data from all processes and all processes receive the
7904!> same data
7905!> \param[in] msgout Rank-3 data to send
7906!> \param msgin ...
7907!> \param comm ...
7908!> \param request ...
7909!> \note see mp_allgather_i12
7910! **************************************************************************************************
7911 SUBROUTINE mp_iallgather_i33(msgout, msgin, comm, request)
7912 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :, :)
7913 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :)
7914 CLASS(mp_comm_type), INTENT(IN) :: comm
7915 TYPE(mp_request_type), INTENT(OUT) :: request
7916
7917 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i33'
7918
7919 INTEGER :: handle
7920#if defined(__parallel)
7921 INTEGER :: ierr, rcount, scount
7922#endif
7923
7924 CALL mp_timeset(routinen, handle)
7925
7926#if defined(__parallel)
7927#if !defined(__GNUC__) || __GNUC__ >= 9
7928 cpassert(is_contiguous(msgout))
7929 cpassert(is_contiguous(msgin))
7930#endif
7931
7932 scount = SIZE(msgout(:, :, :))
7933 rcount = scount
7934 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7935 msgin, rcount, mpi_integer, &
7936 comm%handle, request%handle, ierr)
7937 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7938#else
7939 mark_used(comm)
7940 msgin(:, :, :) = msgout(:, :, :)
7941 request = mp_request_null
7942#endif
7943 CALL mp_timestop(handle)
7944 END SUBROUTINE mp_iallgather_i33
7945
7946! **************************************************************************************************
7947!> \brief Gathers vector data from all processes and all processes receive the
7948!> same data
7949!> \param[in] msgout Rank-1 data to send
7950!> \param[out] msgin Received data
7951!> \param[in] rcount Size of sent data for every process
7952!> \param[in] rdispl Offset of sent data for every process
7953!> \param[in] comm Message passing environment identifier
7954!> \par Data size
7955!> Processes can send different-sized data
7956!> \par Ranks
7957!> The last rank counts the processes
7958!> \par Offsets
7959!> Offsets are from 0
7960!> \par MPI mapping
7961!> mpi_allgather
7962! **************************************************************************************************
7963 SUBROUTINE mp_allgatherv_iv(msgout, msgin, rcount, rdispl, comm)
7964 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
7965 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
7966 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
7967 CLASS(mp_comm_type), INTENT(IN) :: comm
7968
7969 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_iv'
7970
7971 INTEGER :: handle
7972#if defined(__parallel)
7973 INTEGER :: ierr, scount
7974#endif
7975
7976 CALL mp_timeset(routinen, handle)
7977
7978#if defined(__parallel)
7979 scount = SIZE(msgout)
7980 CALL mpi_allgatherv(msgout, scount, mpi_integer, msgin, rcount, &
7981 rdispl, mpi_integer, comm%handle, ierr)
7982 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
7983#else
7984 mark_used(rcount)
7985 mark_used(rdispl)
7986 mark_used(comm)
7987 msgin = msgout
7988#endif
7989 CALL mp_timestop(handle)
7990 END SUBROUTINE mp_allgatherv_iv
7991
7992! **************************************************************************************************
7993!> \brief Gathers vector data from all processes and all processes receive the
7994!> same data
7995!> \param[in] msgout Rank-1 data to send
7996!> \param[out] msgin Received data
7997!> \param[in] rcount Size of sent data for every process
7998!> \param[in] rdispl Offset of sent data for every process
7999!> \param[in] comm Message passing environment identifier
8000!> \par Data size
8001!> Processes can send different-sized data
8002!> \par Ranks
8003!> The last rank counts the processes
8004!> \par Offsets
8005!> Offsets are from 0
8006!> \par MPI mapping
8007!> mpi_allgather
8008! **************************************************************************************************
8009 SUBROUTINE mp_allgatherv_im2(msgout, msgin, rcount, rdispl, comm)
8010 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
8011 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
8012 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
8013 CLASS(mp_comm_type), INTENT(IN) :: comm
8014
8015 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_iv'
8016
8017 INTEGER :: handle
8018#if defined(__parallel)
8019 INTEGER :: ierr, scount
8020#endif
8021
8022 CALL mp_timeset(routinen, handle)
8023
8024#if defined(__parallel)
8025 scount = SIZE(msgout)
8026 CALL mpi_allgatherv(msgout, scount, mpi_integer, msgin, rcount, &
8027 rdispl, mpi_integer, comm%handle, ierr)
8028 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
8029#else
8030 mark_used(rcount)
8031 mark_used(rdispl)
8032 mark_used(comm)
8033 msgin = msgout
8034#endif
8035 CALL mp_timestop(handle)
8036 END SUBROUTINE mp_allgatherv_im2
8037
8038! **************************************************************************************************
8039!> \brief Gathers vector data from all processes and all processes receive the
8040!> same data
8041!> \param[in] msgout Rank-1 data to send
8042!> \param[out] msgin Received data
8043!> \param[in] rcount Size of sent data for every process
8044!> \param[in] rdispl Offset of sent data for every process
8045!> \param[in] comm Message passing environment identifier
8046!> \par Data size
8047!> Processes can send different-sized data
8048!> \par Ranks
8049!> The last rank counts the processes
8050!> \par Offsets
8051!> Offsets are from 0
8052!> \par MPI mapping
8053!> mpi_allgather
8054! **************************************************************************************************
8055 SUBROUTINE mp_iallgatherv_iv(msgout, msgin, rcount, rdispl, comm, request)
8056 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
8057 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
8058 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
8059 CLASS(mp_comm_type), INTENT(IN) :: comm
8060 TYPE(mp_request_type), INTENT(OUT) :: request
8061
8062 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_iv'
8063
8064 INTEGER :: handle
8065#if defined(__parallel)
8066 INTEGER :: ierr, scount, rsize
8067#endif
8068
8069 CALL mp_timeset(routinen, handle)
8070
8071#if defined(__parallel)
8072#if !defined(__GNUC__) || __GNUC__ >= 9
8073 cpassert(is_contiguous(msgout))
8074 cpassert(is_contiguous(msgin))
8075 cpassert(is_contiguous(rcount))
8076 cpassert(is_contiguous(rdispl))
8077#endif
8078
8079 scount = SIZE(msgout)
8080 rsize = SIZE(rcount)
8081 CALL mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, &
8082 rdispl, comm, request, ierr)
8083 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
8084#else
8085 mark_used(rcount)
8086 mark_used(rdispl)
8087 mark_used(comm)
8088 msgin = msgout
8089 request = mp_request_null
8090#endif
8091 CALL mp_timestop(handle)
8092 END SUBROUTINE mp_iallgatherv_iv
8093
8094! **************************************************************************************************
8095!> \brief Gathers vector data from all processes and all processes receive the
8096!> same data
8097!> \param[in] msgout Rank-1 data to send
8098!> \param[out] msgin Received data
8099!> \param[in] rcount Size of sent data for every process
8100!> \param[in] rdispl Offset of sent data for every process
8101!> \param[in] comm Message passing environment identifier
8102!> \par Data size
8103!> Processes can send different-sized data
8104!> \par Ranks
8105!> The last rank counts the processes
8106!> \par Offsets
8107!> Offsets are from 0
8108!> \par MPI mapping
8109!> mpi_allgather
8110! **************************************************************************************************
8111 SUBROUTINE mp_iallgatherv_iv2(msgout, msgin, rcount, rdispl, comm, request)
8112 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
8113 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
8114 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
8115 CLASS(mp_comm_type), INTENT(IN) :: comm
8116 TYPE(mp_request_type), INTENT(OUT) :: request
8117
8118 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_iv2'
8119
8120 INTEGER :: handle
8121#if defined(__parallel)
8122 INTEGER :: ierr, scount, rsize
8123#endif
8124
8125 CALL mp_timeset(routinen, handle)
8126
8127#if defined(__parallel)
8128#if !defined(__GNUC__) || __GNUC__ >= 9
8129 cpassert(is_contiguous(msgout))
8130 cpassert(is_contiguous(msgin))
8131 cpassert(is_contiguous(rcount))
8132 cpassert(is_contiguous(rdispl))
8133#endif
8134
8135 scount = SIZE(msgout)
8136 rsize = SIZE(rcount)
8137 CALL mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, &
8138 rdispl, comm, request, ierr)
8139 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
8140#else
8141 mark_used(rcount)
8142 mark_used(rdispl)
8143 mark_used(comm)
8144 msgin = msgout
8145 request = mp_request_null
8146#endif
8147 CALL mp_timestop(handle)
8148 END SUBROUTINE mp_iallgatherv_iv2
8149
8150! **************************************************************************************************
8151!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
8152!> the issue is with the rank of rcount and rdispl
8153!> \param count ...
8154!> \param array_of_requests ...
8155!> \param array_of_statuses ...
8156!> \param ierr ...
8157!> \author Alfio Lazzaro
8158! **************************************************************************************************
8159#if defined(__parallel)
8160 SUBROUTINE mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
8161 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
8162 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
8163 INTEGER, INTENT(IN) :: rsize
8164 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
8165 CLASS(mp_comm_type), INTENT(IN) :: comm
8166 TYPE(mp_request_type), INTENT(OUT) :: request
8167 INTEGER, INTENT(INOUT) :: ierr
8168
8169 CALL mpi_iallgatherv(msgout, scount, mpi_integer, msgin, rcount, &
8170 rdispl, mpi_integer, comm%handle, request%handle, ierr)
8171
8172 END SUBROUTINE mp_iallgatherv_iv_internal
8173#endif
8174
8175! **************************************************************************************************
8176!> \brief Sums a vector and partitions the result among processes
8177!> \param[in] msgout Data to sum
8178!> \param[out] msgin Received portion of summed data
8179!> \param[in] rcount Partition sizes of the summed data for
8180!> every process
8181!> \param[in] comm Message passing environment identifier
8182! **************************************************************************************************
8183 SUBROUTINE mp_sum_scatter_iv(msgout, msgin, rcount, comm)
8184 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
8185 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
8186 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
8187 CLASS(mp_comm_type), INTENT(IN) :: comm
8188
8189 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_iv'
8190
8191 INTEGER :: handle
8192#if defined(__parallel)
8193 INTEGER :: ierr
8194#endif
8195
8196 CALL mp_timeset(routinen, handle)
8197
8198#if defined(__parallel)
8199 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_integer, mpi_sum, &
8200 comm%handle, ierr)
8201 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
8202
8203 CALL add_perf(perf_id=3, count=1, &
8204 msg_size=rcount(1)*2*int_4_size)
8205#else
8206 mark_used(rcount)
8207 mark_used(comm)
8208 msgin = msgout(:, 1)
8209#endif
8210 CALL mp_timestop(handle)
8211 END SUBROUTINE mp_sum_scatter_iv
8212
8213! **************************************************************************************************
8214!> \brief Sends and receives vector data
8215!> \param[in] msgin Data to send
8216!> \param[in] dest Process to send data to
8217!> \param[out] msgout Received data
8218!> \param[in] source Process from which to receive
8219!> \param[in] comm Message passing environment identifier
8220!> \param[in] tag Send and recv tag (default: 0)
8221! **************************************************************************************************
8222 SUBROUTINE mp_sendrecv_i (msgin, dest, msgout, source, comm, tag)
8223 INTEGER(KIND=int_4), INTENT(IN) :: msgin
8224 INTEGER, INTENT(IN) :: dest
8225 INTEGER(KIND=int_4), INTENT(OUT) :: msgout
8226 INTEGER, INTENT(IN) :: source
8227 CLASS(mp_comm_type), INTENT(IN) :: comm
8228 INTEGER, INTENT(IN), OPTIONAL :: tag
8229
8230 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_i'
8231
8232 INTEGER :: handle
8233#if defined(__parallel)
8234 INTEGER :: ierr, msglen_in, msglen_out, &
8235 recv_tag, send_tag
8236#endif
8237
8238 CALL mp_timeset(routinen, handle)
8239
8240#if defined(__parallel)
8241 msglen_in = 1
8242 msglen_out = 1
8243 send_tag = 0 ! cannot think of something better here, this might be dangerous
8244 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8245 IF (PRESENT(tag)) THEN
8246 send_tag = tag
8247 recv_tag = tag
8248 END IF
8249 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8250 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8251 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8252 CALL add_perf(perf_id=7, count=1, &
8253 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8254#else
8255 mark_used(dest)
8256 mark_used(source)
8257 mark_used(comm)
8258 mark_used(tag)
8259 msgout = msgin
8260#endif
8261 CALL mp_timestop(handle)
8262 END SUBROUTINE mp_sendrecv_i
8263
8264! **************************************************************************************************
8265!> \brief Sends and receives vector data
8266!> \param[in] msgin Data to send
8267!> \param[in] dest Process to send data to
8268!> \param[out] msgout Received data
8269!> \param[in] source Process from which to receive
8270!> \param[in] comm Message passing environment identifier
8271!> \param[in] tag Send and recv tag (default: 0)
8272! **************************************************************************************************
8273 SUBROUTINE mp_sendrecv_iv(msgin, dest, msgout, source, comm, tag)
8274 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
8275 INTEGER, INTENT(IN) :: dest
8276 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
8277 INTEGER, INTENT(IN) :: source
8278 CLASS(mp_comm_type), INTENT(IN) :: comm
8279 INTEGER, INTENT(IN), OPTIONAL :: tag
8280
8281 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_iv'
8282
8283 INTEGER :: handle
8284#if defined(__parallel)
8285 INTEGER :: ierr, msglen_in, msglen_out, &
8286 recv_tag, send_tag
8287#endif
8288
8289 CALL mp_timeset(routinen, handle)
8290
8291#if defined(__parallel)
8292 msglen_in = SIZE(msgin)
8293 msglen_out = SIZE(msgout)
8294 send_tag = 0 ! cannot think of something better here, this might be dangerous
8295 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8296 IF (PRESENT(tag)) THEN
8297 send_tag = tag
8298 recv_tag = tag
8299 END IF
8300 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8301 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8302 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8303 CALL add_perf(perf_id=7, count=1, &
8304 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8305#else
8306 mark_used(dest)
8307 mark_used(source)
8308 mark_used(comm)
8309 mark_used(tag)
8310 msgout = msgin
8311#endif
8312 CALL mp_timestop(handle)
8313 END SUBROUTINE mp_sendrecv_iv
8314
8315! **************************************************************************************************
8316!> \brief Sends and receives matrix data
8317!> \param msgin ...
8318!> \param dest ...
8319!> \param msgout ...
8320!> \param source ...
8321!> \param comm ...
8322!> \param tag ...
8323!> \note see mp_sendrecv_iv
8324! **************************************************************************************************
8325 SUBROUTINE mp_sendrecv_im2(msgin, dest, msgout, source, comm, tag)
8326 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
8327 INTEGER, INTENT(IN) :: dest
8328 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
8329 INTEGER, INTENT(IN) :: source
8330 CLASS(mp_comm_type), INTENT(IN) :: comm
8331 INTEGER, INTENT(IN), OPTIONAL :: tag
8332
8333 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im2'
8334
8335 INTEGER :: handle
8336#if defined(__parallel)
8337 INTEGER :: ierr, msglen_in, msglen_out, &
8338 recv_tag, send_tag
8339#endif
8340
8341 CALL mp_timeset(routinen, handle)
8342
8343#if defined(__parallel)
8344 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
8345 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
8346 send_tag = 0 ! cannot think of something better here, this might be dangerous
8347 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8348 IF (PRESENT(tag)) THEN
8349 send_tag = tag
8350 recv_tag = tag
8351 END IF
8352 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8353 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8354 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8355 CALL add_perf(perf_id=7, count=1, &
8356 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8357#else
8358 mark_used(dest)
8359 mark_used(source)
8360 mark_used(comm)
8361 mark_used(tag)
8362 msgout = msgin
8363#endif
8364 CALL mp_timestop(handle)
8365 END SUBROUTINE mp_sendrecv_im2
8366
8367! **************************************************************************************************
8368!> \brief Sends and receives rank-3 data
8369!> \param msgin ...
8370!> \param dest ...
8371!> \param msgout ...
8372!> \param source ...
8373!> \param comm ...
8374!> \note see mp_sendrecv_iv
8375! **************************************************************************************************
8376 SUBROUTINE mp_sendrecv_im3(msgin, dest, msgout, source, comm, tag)
8377 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
8378 INTEGER, INTENT(IN) :: dest
8379 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
8380 INTEGER, INTENT(IN) :: source
8381 CLASS(mp_comm_type), INTENT(IN) :: comm
8382 INTEGER, INTENT(IN), OPTIONAL :: tag
8383
8384 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im3'
8385
8386 INTEGER :: handle
8387#if defined(__parallel)
8388 INTEGER :: ierr, msglen_in, msglen_out, &
8389 recv_tag, send_tag
8390#endif
8391
8392 CALL mp_timeset(routinen, handle)
8393
8394#if defined(__parallel)
8395 msglen_in = SIZE(msgin)
8396 msglen_out = SIZE(msgout)
8397 send_tag = 0 ! cannot think of something better here, this might be dangerous
8398 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8399 IF (PRESENT(tag)) THEN
8400 send_tag = tag
8401 recv_tag = tag
8402 END IF
8403 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8404 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8405 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8406 CALL add_perf(perf_id=7, count=1, &
8407 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8408#else
8409 mark_used(dest)
8410 mark_used(source)
8411 mark_used(comm)
8412 mark_used(tag)
8413 msgout = msgin
8414#endif
8415 CALL mp_timestop(handle)
8416 END SUBROUTINE mp_sendrecv_im3
8417
8418! **************************************************************************************************
8419!> \brief Sends and receives rank-4 data
8420!> \param msgin ...
8421!> \param dest ...
8422!> \param msgout ...
8423!> \param source ...
8424!> \param comm ...
8425!> \note see mp_sendrecv_iv
8426! **************************************************************************************************
8427 SUBROUTINE mp_sendrecv_im4(msgin, dest, msgout, source, comm, tag)
8428 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
8429 INTEGER, INTENT(IN) :: dest
8430 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
8431 INTEGER, INTENT(IN) :: source
8432 CLASS(mp_comm_type), INTENT(IN) :: comm
8433 INTEGER, INTENT(IN), OPTIONAL :: tag
8434
8435 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im4'
8436
8437 INTEGER :: handle
8438#if defined(__parallel)
8439 INTEGER :: ierr, msglen_in, msglen_out, &
8440 recv_tag, send_tag
8441#endif
8442
8443 CALL mp_timeset(routinen, handle)
8444
8445#if defined(__parallel)
8446 msglen_in = SIZE(msgin)
8447 msglen_out = SIZE(msgout)
8448 send_tag = 0 ! cannot think of something better here, this might be dangerous
8449 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8450 IF (PRESENT(tag)) THEN
8451 send_tag = tag
8452 recv_tag = tag
8453 END IF
8454 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8455 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8456 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8457 CALL add_perf(perf_id=7, count=1, &
8458 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8459#else
8460 mark_used(dest)
8461 mark_used(source)
8462 mark_used(comm)
8463 mark_used(tag)
8464 msgout = msgin
8465#endif
8466 CALL mp_timestop(handle)
8467 END SUBROUTINE mp_sendrecv_im4
8468
8469! **************************************************************************************************
8470!> \brief Non-blocking send and receive of a scalar
8471!> \param[in] msgin Scalar data to send
8472!> \param[in] dest Which process to send to
8473!> \param[out] msgout Receive data into this pointer
8474!> \param[in] source Process to receive from
8475!> \param[in] comm Message passing environment identifier
8476!> \param[out] send_request Request handle for the send
8477!> \param[out] recv_request Request handle for the receive
8478!> \param[in] tag (optional) tag to differentiate requests
8479!> \par Implementation
8480!> Calls mpi_isend and mpi_irecv.
8481!> \par History
8482!> 02.2005 created [Alfio Lazzaro]
8483! **************************************************************************************************
8484 SUBROUTINE mp_isendrecv_i (msgin, dest, msgout, source, comm, send_request, &
8485 recv_request, tag)
8486 INTEGER(KIND=int_4), INTENT(IN) :: msgin
8487 INTEGER, INTENT(IN) :: dest
8488 INTEGER(KIND=int_4), INTENT(INOUT) :: msgout
8489 INTEGER, INTENT(IN) :: source
8490 CLASS(mp_comm_type), INTENT(IN) :: comm
8491 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
8492 INTEGER, INTENT(in), OPTIONAL :: tag
8493
8494 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_i'
8495
8496 INTEGER :: handle
8497#if defined(__parallel)
8498 INTEGER :: ierr, my_tag
8499#endif
8500
8501 CALL mp_timeset(routinen, handle)
8502
8503#if defined(__parallel)
8504 my_tag = 0
8505 IF (PRESENT(tag)) my_tag = tag
8506
8507 CALL mpi_irecv(msgout, 1, mpi_integer, source, my_tag, &
8508 comm%handle, recv_request%handle, ierr)
8509 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8510
8511 CALL mpi_isend(msgin, 1, mpi_integer, dest, my_tag, &
8512 comm%handle, send_request%handle, ierr)
8513 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8514
8515 CALL add_perf(perf_id=8, count=1, msg_size=2*int_4_size)
8516#else
8517 mark_used(dest)
8518 mark_used(source)
8519 mark_used(comm)
8520 mark_used(tag)
8521 send_request = mp_request_null
8522 recv_request = mp_request_null
8523 msgout = msgin
8524#endif
8525 CALL mp_timestop(handle)
8526 END SUBROUTINE mp_isendrecv_i
8527
8528! **************************************************************************************************
8529!> \brief Non-blocking send and receive of a vector
8530!> \param[in] msgin Vector data to send
8531!> \param[in] dest Which process to send to
8532!> \param[out] msgout Receive data into this pointer
8533!> \param[in] source Process to receive from
8534!> \param[in] comm Message passing environment identifier
8535!> \param[out] send_request Request handle for the send
8536!> \param[out] recv_request Request handle for the receive
8537!> \param[in] tag (optional) tag to differentiate requests
8538!> \par Implementation
8539!> Calls mpi_isend and mpi_irecv.
8540!> \par History
8541!> 11.2004 created [Joost VandeVondele]
8542!> \note
8543!> arrays can be pointers or assumed shape, but they must be contiguous!
8544! **************************************************************************************************
8545 SUBROUTINE mp_isendrecv_iv(msgin, dest, msgout, source, comm, send_request, &
8546 recv_request, tag)
8547 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: msgin
8548 INTEGER, INTENT(IN) :: dest
8549 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT) :: msgout
8550 INTEGER, INTENT(IN) :: source
8551 CLASS(mp_comm_type), INTENT(IN) :: comm
8552 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
8553 INTEGER, INTENT(in), OPTIONAL :: tag
8554
8555 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_iv'
8556
8557 INTEGER :: handle
8558#if defined(__parallel)
8559 INTEGER :: ierr, msglen, my_tag
8560 INTEGER(KIND=int_4) :: foo
8561#endif
8562
8563 CALL mp_timeset(routinen, handle)
8564
8565#if defined(__parallel)
8566#if !defined(__GNUC__) || __GNUC__ >= 9
8567 cpassert(is_contiguous(msgout))
8568 cpassert(is_contiguous(msgin))
8569#endif
8570
8571 my_tag = 0
8572 IF (PRESENT(tag)) my_tag = tag
8573
8574 msglen = SIZE(msgout, 1)
8575 IF (msglen > 0) THEN
8576 CALL mpi_irecv(msgout(1), msglen, mpi_integer, source, my_tag, &
8577 comm%handle, recv_request%handle, ierr)
8578 ELSE
8579 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8580 comm%handle, recv_request%handle, ierr)
8581 END IF
8582 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8583
8584 msglen = SIZE(msgin, 1)
8585 IF (msglen > 0) THEN
8586 CALL mpi_isend(msgin(1), msglen, mpi_integer, dest, my_tag, &
8587 comm%handle, send_request%handle, ierr)
8588 ELSE
8589 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8590 comm%handle, send_request%handle, ierr)
8591 END IF
8592 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8593
8594 msglen = (msglen + SIZE(msgout, 1) + 1)/2
8595 CALL add_perf(perf_id=8, count=1, msg_size=msglen*int_4_size)
8596#else
8597 mark_used(dest)
8598 mark_used(source)
8599 mark_used(comm)
8600 mark_used(tag)
8601 send_request = mp_request_null
8602 recv_request = mp_request_null
8603 msgout = msgin
8604#endif
8605 CALL mp_timestop(handle)
8606 END SUBROUTINE mp_isendrecv_iv
8607
8608! **************************************************************************************************
8609!> \brief Non-blocking send of vector data
8610!> \param msgin ...
8611!> \param dest ...
8612!> \param comm ...
8613!> \param request ...
8614!> \param tag ...
8615!> \par History
8616!> 08.2003 created [f&j]
8617!> \note see mp_isendrecv_iv
8618!> \note
8619!> arrays can be pointers or assumed shape, but they must be contiguous!
8620! **************************************************************************************************
8621 SUBROUTINE mp_isend_iv(msgin, dest, comm, request, tag)
8622 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: msgin
8623 INTEGER, INTENT(IN) :: dest
8624 CLASS(mp_comm_type), INTENT(IN) :: comm
8625 TYPE(mp_request_type), INTENT(out) :: request
8626 INTEGER, INTENT(in), OPTIONAL :: tag
8627
8628 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_iv'
8629
8630 INTEGER :: handle, ierr
8631#if defined(__parallel)
8632 INTEGER :: msglen, my_tag
8633 INTEGER(KIND=int_4) :: foo(1)
8634#endif
8635
8636 CALL mp_timeset(routinen, handle)
8637
8638#if defined(__parallel)
8639#if !defined(__GNUC__) || __GNUC__ >= 9
8640 cpassert(is_contiguous(msgin))
8641#endif
8642 my_tag = 0
8643 IF (PRESENT(tag)) my_tag = tag
8644
8645 msglen = SIZE(msgin)
8646 IF (msglen > 0) THEN
8647 CALL mpi_isend(msgin(1), msglen, mpi_integer, dest, my_tag, &
8648 comm%handle, request%handle, ierr)
8649 ELSE
8650 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8651 comm%handle, request%handle, ierr)
8652 END IF
8653 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8654
8655 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8656#else
8657 mark_used(msgin)
8658 mark_used(dest)
8659 mark_used(comm)
8660 mark_used(request)
8661 mark_used(tag)
8662 ierr = 1
8663 request = mp_request_null
8664 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8665#endif
8666 CALL mp_timestop(handle)
8667 END SUBROUTINE mp_isend_iv
8668
8669! **************************************************************************************************
8670!> \brief Non-blocking send of matrix data
8671!> \param msgin ...
8672!> \param dest ...
8673!> \param comm ...
8674!> \param request ...
8675!> \param tag ...
8676!> \par History
8677!> 2009-11-25 [UB] Made type-generic for templates
8678!> \author fawzi
8679!> \note see mp_isendrecv_iv
8680!> \note see mp_isend_iv
8681!> \note
8682!> arrays can be pointers or assumed shape, but they must be contiguous!
8683! **************************************************************************************************
8684 SUBROUTINE mp_isend_im2(msgin, dest, comm, request, tag)
8685 INTEGER(KIND=int_4), DIMENSION(:, :), INTENT(IN) :: msgin
8686 INTEGER, INTENT(IN) :: dest
8687 CLASS(mp_comm_type), INTENT(IN) :: comm
8688 TYPE(mp_request_type), INTENT(out) :: request
8689 INTEGER, INTENT(in), OPTIONAL :: tag
8690
8691 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im2'
8692
8693 INTEGER :: handle, ierr
8694#if defined(__parallel)
8695 INTEGER :: msglen, my_tag
8696 INTEGER(KIND=int_4) :: foo(1)
8697#endif
8698
8699 CALL mp_timeset(routinen, handle)
8700
8701#if defined(__parallel)
8702#if !defined(__GNUC__) || __GNUC__ >= 9
8703 cpassert(is_contiguous(msgin))
8704#endif
8705
8706 my_tag = 0
8707 IF (PRESENT(tag)) my_tag = tag
8708
8709 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
8710 IF (msglen > 0) THEN
8711 CALL mpi_isend(msgin(1, 1), msglen, mpi_integer, dest, my_tag, &
8712 comm%handle, request%handle, ierr)
8713 ELSE
8714 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8715 comm%handle, request%handle, ierr)
8716 END IF
8717 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8718
8719 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8720#else
8721 mark_used(msgin)
8722 mark_used(dest)
8723 mark_used(comm)
8724 mark_used(request)
8725 mark_used(tag)
8726 ierr = 1
8727 request = mp_request_null
8728 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8729#endif
8730 CALL mp_timestop(handle)
8731 END SUBROUTINE mp_isend_im2
8732
8733! **************************************************************************************************
8734!> \brief Non-blocking send of rank-3 data
8735!> \param msgin ...
8736!> \param dest ...
8737!> \param comm ...
8738!> \param request ...
8739!> \param tag ...
8740!> \par History
8741!> 9.2008 added _rm3 subroutine [Iain Bethune]
8742!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
8743!> 2009-11-25 [UB] Made type-generic for templates
8744!> \author fawzi
8745!> \note see mp_isendrecv_iv
8746!> \note see mp_isend_iv
8747!> \note
8748!> arrays can be pointers or assumed shape, but they must be contiguous!
8749! **************************************************************************************************
8750 SUBROUTINE mp_isend_im3(msgin, dest, comm, request, tag)
8751 INTEGER(KIND=int_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
8752 INTEGER, INTENT(IN) :: dest
8753 CLASS(mp_comm_type), INTENT(IN) :: comm
8754 TYPE(mp_request_type), INTENT(out) :: request
8755 INTEGER, INTENT(in), OPTIONAL :: tag
8756
8757 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im3'
8758
8759 INTEGER :: handle, ierr
8760#if defined(__parallel)
8761 INTEGER :: msglen, my_tag
8762 INTEGER(KIND=int_4) :: foo(1)
8763#endif
8764
8765 CALL mp_timeset(routinen, handle)
8766
8767#if defined(__parallel)
8768#if !defined(__GNUC__) || __GNUC__ >= 9
8769 cpassert(is_contiguous(msgin))
8770#endif
8771
8772 my_tag = 0
8773 IF (PRESENT(tag)) my_tag = tag
8774
8775 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
8776 IF (msglen > 0) THEN
8777 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_integer, dest, my_tag, &
8778 comm%handle, request%handle, ierr)
8779 ELSE
8780 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8781 comm%handle, request%handle, ierr)
8782 END IF
8783 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8784
8785 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8786#else
8787 mark_used(msgin)
8788 mark_used(dest)
8789 mark_used(comm)
8790 mark_used(request)
8791 mark_used(tag)
8792 ierr = 1
8793 request = mp_request_null
8794 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8795#endif
8796 CALL mp_timestop(handle)
8797 END SUBROUTINE mp_isend_im3
8798
8799! **************************************************************************************************
8800!> \brief Non-blocking send of rank-4 data
8801!> \param msgin the input message
8802!> \param dest the destination processor
8803!> \param comm the communicator object
8804!> \param request the communication request id
8805!> \param tag the message tag
8806!> \par History
8807!> 2.2016 added _im4 subroutine [Nico Holmberg]
8808!> \author fawzi
8809!> \note see mp_isend_iv
8810!> \note
8811!> arrays can be pointers or assumed shape, but they must be contiguous!
8812! **************************************************************************************************
8813 SUBROUTINE mp_isend_im4(msgin, dest, comm, request, tag)
8814 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
8815 INTEGER, INTENT(IN) :: dest
8816 CLASS(mp_comm_type), INTENT(IN) :: comm
8817 TYPE(mp_request_type), INTENT(out) :: request
8818 INTEGER, INTENT(in), OPTIONAL :: tag
8819
8820 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im4'
8821
8822 INTEGER :: handle, ierr
8823#if defined(__parallel)
8824 INTEGER :: msglen, my_tag
8825 INTEGER(KIND=int_4) :: foo(1)
8826#endif
8827
8828 CALL mp_timeset(routinen, handle)
8829
8830#if defined(__parallel)
8831#if !defined(__GNUC__) || __GNUC__ >= 9
8832 cpassert(is_contiguous(msgin))
8833#endif
8834
8835 my_tag = 0
8836 IF (PRESENT(tag)) my_tag = tag
8837
8838 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
8839 IF (msglen > 0) THEN
8840 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_integer, dest, my_tag, &
8841 comm%handle, request%handle, ierr)
8842 ELSE
8843 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8844 comm%handle, request%handle, ierr)
8845 END IF
8846 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8847
8848 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8849#else
8850 mark_used(msgin)
8851 mark_used(dest)
8852 mark_used(comm)
8853 mark_used(request)
8854 mark_used(tag)
8855 ierr = 1
8856 request = mp_request_null
8857 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8858#endif
8859 CALL mp_timestop(handle)
8860 END SUBROUTINE mp_isend_im4
8861
8862! **************************************************************************************************
8863!> \brief Non-blocking receive of vector data
8864!> \param msgout ...
8865!> \param source ...
8866!> \param comm ...
8867!> \param request ...
8868!> \param tag ...
8869!> \par History
8870!> 08.2003 created [f&j]
8871!> 2009-11-25 [UB] Made type-generic for templates
8872!> \note see mp_isendrecv_iv
8873!> \note
8874!> arrays can be pointers or assumed shape, but they must be contiguous!
8875! **************************************************************************************************
8876 SUBROUTINE mp_irecv_iv(msgout, source, comm, request, tag)
8877 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT) :: msgout
8878 INTEGER, INTENT(IN) :: source
8879 CLASS(mp_comm_type), INTENT(IN) :: comm
8880 TYPE(mp_request_type), INTENT(out) :: request
8881 INTEGER, INTENT(in), OPTIONAL :: tag
8882
8883 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_iv'
8884
8885 INTEGER :: handle
8886#if defined(__parallel)
8887 INTEGER :: ierr, msglen, my_tag
8888 INTEGER(KIND=int_4) :: foo(1)
8889#endif
8890
8891 CALL mp_timeset(routinen, handle)
8892
8893#if defined(__parallel)
8894#if !defined(__GNUC__) || __GNUC__ >= 9
8895 cpassert(is_contiguous(msgout))
8896#endif
8897
8898 my_tag = 0
8899 IF (PRESENT(tag)) my_tag = tag
8900
8901 msglen = SIZE(msgout)
8902 IF (msglen > 0) THEN
8903 CALL mpi_irecv(msgout(1), msglen, mpi_integer, source, my_tag, &
8904 comm%handle, request%handle, ierr)
8905 ELSE
8906 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8907 comm%handle, request%handle, ierr)
8908 END IF
8909 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8910
8911 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8912#else
8913 cpabort("mp_irecv called in non parallel case")
8914 mark_used(msgout)
8915 mark_used(source)
8916 mark_used(comm)
8917 mark_used(tag)
8918 request = mp_request_null
8919#endif
8920 CALL mp_timestop(handle)
8921 END SUBROUTINE mp_irecv_iv
8922
8923! **************************************************************************************************
8924!> \brief Non-blocking receive of matrix data
8925!> \param msgout ...
8926!> \param source ...
8927!> \param comm ...
8928!> \param request ...
8929!> \param tag ...
8930!> \par History
8931!> 2009-11-25 [UB] Made type-generic for templates
8932!> \author fawzi
8933!> \note see mp_isendrecv_iv
8934!> \note see mp_irecv_iv
8935!> \note
8936!> arrays can be pointers or assumed shape, but they must be contiguous!
8937! **************************************************************************************************
8938 SUBROUTINE mp_irecv_im2(msgout, source, comm, request, tag)
8939 INTEGER(KIND=int_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
8940 INTEGER, INTENT(IN) :: source
8941 CLASS(mp_comm_type), INTENT(IN) :: comm
8942 TYPE(mp_request_type), INTENT(out) :: request
8943 INTEGER, INTENT(in), OPTIONAL :: tag
8944
8945 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im2'
8946
8947 INTEGER :: handle
8948#if defined(__parallel)
8949 INTEGER :: ierr, msglen, my_tag
8950 INTEGER(KIND=int_4) :: foo(1)
8951#endif
8952
8953 CALL mp_timeset(routinen, handle)
8954
8955#if defined(__parallel)
8956#if !defined(__GNUC__) || __GNUC__ >= 9
8957 cpassert(is_contiguous(msgout))
8958#endif
8959
8960 my_tag = 0
8961 IF (PRESENT(tag)) my_tag = tag
8962
8963 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
8964 IF (msglen > 0) THEN
8965 CALL mpi_irecv(msgout(1, 1), msglen, mpi_integer, source, my_tag, &
8966 comm%handle, request%handle, ierr)
8967 ELSE
8968 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8969 comm%handle, request%handle, ierr)
8970 END IF
8971 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8972
8973 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8974#else
8975 mark_used(msgout)
8976 mark_used(source)
8977 mark_used(comm)
8978 mark_used(tag)
8979 request = mp_request_null
8980 cpabort("mp_irecv called in non parallel case")
8981#endif
8982 CALL mp_timestop(handle)
8983 END SUBROUTINE mp_irecv_im2
8984
8985! **************************************************************************************************
8986!> \brief Non-blocking send of rank-3 data
8987!> \param msgout ...
8988!> \param source ...
8989!> \param comm ...
8990!> \param request ...
8991!> \param tag ...
8992!> \par History
8993!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
8994!> 2009-11-25 [UB] Made type-generic for templates
8995!> \author fawzi
8996!> \note see mp_isendrecv_iv
8997!> \note see mp_irecv_iv
8998!> \note
8999!> arrays can be pointers or assumed shape, but they must be contiguous!
9000! **************************************************************************************************
9001 SUBROUTINE mp_irecv_im3(msgout, source, comm, request, tag)
9002 INTEGER(KIND=int_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
9003 INTEGER, INTENT(IN) :: source
9004 CLASS(mp_comm_type), INTENT(IN) :: comm
9005 TYPE(mp_request_type), INTENT(out) :: request
9006 INTEGER, INTENT(in), OPTIONAL :: tag
9007
9008 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im3'
9009
9010 INTEGER :: handle
9011#if defined(__parallel)
9012 INTEGER :: ierr, msglen, my_tag
9013 INTEGER(KIND=int_4) :: foo(1)
9014#endif
9015
9016 CALL mp_timeset(routinen, handle)
9017
9018#if defined(__parallel)
9019#if !defined(__GNUC__) || __GNUC__ >= 9
9020 cpassert(is_contiguous(msgout))
9021#endif
9022
9023 my_tag = 0
9024 IF (PRESENT(tag)) my_tag = tag
9025
9026 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
9027 IF (msglen > 0) THEN
9028 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_integer, source, my_tag, &
9029 comm%handle, request%handle, ierr)
9030 ELSE
9031 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
9032 comm%handle, request%handle, ierr)
9033 END IF
9034 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
9035
9036 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
9037#else
9038 mark_used(msgout)
9039 mark_used(source)
9040 mark_used(comm)
9041 mark_used(tag)
9042 request = mp_request_null
9043 cpabort("mp_irecv called in non parallel case")
9044#endif
9045 CALL mp_timestop(handle)
9046 END SUBROUTINE mp_irecv_im3
9047
9048! **************************************************************************************************
9049!> \brief Non-blocking receive of rank-4 data
9050!> \param msgout the output message
9051!> \param source the source processor
9052!> \param comm the communicator object
9053!> \param request the communication request id
9054!> \param tag the message tag
9055!> \par History
9056!> 2.2016 added _im4 subroutine [Nico Holmberg]
9057!> \author fawzi
9058!> \note see mp_irecv_iv
9059!> \note
9060!> arrays can be pointers or assumed shape, but they must be contiguous!
9061! **************************************************************************************************
9062 SUBROUTINE mp_irecv_im4(msgout, source, comm, request, tag)
9063 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
9064 INTEGER, INTENT(IN) :: source
9065 CLASS(mp_comm_type), INTENT(IN) :: comm
9066 TYPE(mp_request_type), INTENT(out) :: request
9067 INTEGER, INTENT(in), OPTIONAL :: tag
9068
9069 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im4'
9070
9071 INTEGER :: handle
9072#if defined(__parallel)
9073 INTEGER :: ierr, msglen, my_tag
9074 INTEGER(KIND=int_4) :: foo(1)
9075#endif
9076
9077 CALL mp_timeset(routinen, handle)
9078
9079#if defined(__parallel)
9080#if !defined(__GNUC__) || __GNUC__ >= 9
9081 cpassert(is_contiguous(msgout))
9082#endif
9083
9084 my_tag = 0
9085 IF (PRESENT(tag)) my_tag = tag
9086
9087 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
9088 IF (msglen > 0) THEN
9089 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_integer, source, my_tag, &
9090 comm%handle, request%handle, ierr)
9091 ELSE
9092 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
9093 comm%handle, request%handle, ierr)
9094 END IF
9095 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
9096
9097 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
9098#else
9099 mark_used(msgout)
9100 mark_used(source)
9101 mark_used(comm)
9102 mark_used(tag)
9103 request = mp_request_null
9104 cpabort("mp_irecv called in non parallel case")
9105#endif
9106 CALL mp_timestop(handle)
9107 END SUBROUTINE mp_irecv_im4
9108
9109! **************************************************************************************************
9110!> \brief Window initialization function for vector data
9111!> \param base ...
9112!> \param comm ...
9113!> \param win ...
9114!> \par History
9115!> 02.2015 created [Alfio Lazzaro]
9116!> \note
9117!> arrays can be pointers or assumed shape, but they must be contiguous!
9118! **************************************************************************************************
9119 SUBROUTINE mp_win_create_iv(base, comm, win)
9120 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
9121 TYPE(mp_comm_type), INTENT(IN) :: comm
9122 CLASS(mp_win_type), INTENT(INOUT) :: win
9123
9124 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_iv'
9125
9126 INTEGER :: handle
9127#if defined(__parallel)
9128 INTEGER :: ierr
9129 INTEGER(kind=mpi_address_kind) :: len
9130 INTEGER(KIND=int_4) :: foo(1)
9131#endif
9132
9133 CALL mp_timeset(routinen, handle)
9134
9135#if defined(__parallel)
9136
9137 len = SIZE(base)*int_4_size
9138 IF (len > 0) THEN
9139 CALL mpi_win_create(base(1), len, int_4_size, mpi_info_null, comm%handle, win%handle, ierr)
9140 ELSE
9141 CALL mpi_win_create(foo, len, int_4_size, mpi_info_null, comm%handle, win%handle, ierr)
9142 END IF
9143 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
9144
9145 CALL add_perf(perf_id=20, count=1)
9146#else
9147 mark_used(base)
9148 mark_used(comm)
9149 win%handle = mp_win_null_handle
9150#endif
9151 CALL mp_timestop(handle)
9152 END SUBROUTINE mp_win_create_iv
9153
9154! **************************************************************************************************
9155!> \brief Single-sided get function for vector data
9156!> \param base ...
9157!> \param comm ...
9158!> \param win ...
9159!> \par History
9160!> 02.2015 created [Alfio Lazzaro]
9161!> \note
9162!> arrays can be pointers or assumed shape, but they must be contiguous!
9163! **************************************************************************************************
9164 SUBROUTINE mp_rget_iv(base, source, win, win_data, myproc, disp, request, &
9165 origin_datatype, target_datatype)
9166 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
9167 INTEGER, INTENT(IN) :: source
9168 CLASS(mp_win_type), INTENT(IN) :: win
9169 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: win_data
9170 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
9171 TYPE(mp_request_type), INTENT(OUT) :: request
9172 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
9173
9174 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_iv'
9175
9176 INTEGER :: handle
9177#if defined(__parallel)
9178 INTEGER :: ierr, len, &
9179 origin_len, target_len
9180 LOGICAL :: do_local_copy
9181 INTEGER(kind=mpi_address_kind) :: disp_aint
9182 mpi_data_type :: handle_origin_datatype, handle_target_datatype
9183#endif
9184
9185 CALL mp_timeset(routinen, handle)
9186
9187#if defined(__parallel)
9188 len = SIZE(base)
9189 disp_aint = 0
9190 IF (PRESENT(disp)) THEN
9191 disp_aint = int(disp, kind=mpi_address_kind)
9192 END IF
9193 handle_origin_datatype = mpi_integer
9194 origin_len = len
9195 IF (PRESENT(origin_datatype)) THEN
9196 handle_origin_datatype = origin_datatype%type_handle
9197 origin_len = 1
9198 END IF
9199 handle_target_datatype = mpi_integer
9200 target_len = len
9201 IF (PRESENT(target_datatype)) THEN
9202 handle_target_datatype = target_datatype%type_handle
9203 target_len = 1
9204 END IF
9205 IF (len > 0) THEN
9206 do_local_copy = .false.
9207 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
9208 IF (myproc .EQ. source) do_local_copy = .true.
9209 END IF
9210 IF (do_local_copy) THEN
9211 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
9212 base(:) = win_data(disp_aint + 1:disp_aint + len)
9213 !$OMP END PARALLEL WORKSHARE
9214 request = mp_request_null
9215 ierr = 0
9216 ELSE
9217 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
9218 target_len, handle_target_datatype, win%handle, request%handle, ierr)
9219 END IF
9220 ELSE
9221 request = mp_request_null
9222 ierr = 0
9223 END IF
9224 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
9225
9226 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*int_4_size)
9227#else
9228 mark_used(source)
9229 mark_used(win)
9230 mark_used(myproc)
9231 mark_used(origin_datatype)
9232 mark_used(target_datatype)
9233
9234 request = mp_request_null
9235 !
9236 IF (PRESENT(disp)) THEN
9237 base(:) = win_data(disp + 1:disp + SIZE(base))
9238 ELSE
9239 base(:) = win_data(:SIZE(base))
9240 END IF
9241
9242#endif
9243 CALL mp_timestop(handle)
9244 END SUBROUTINE mp_rget_iv
9245
9246! **************************************************************************************************
9247!> \brief ...
9248!> \param count ...
9249!> \param lengths ...
9250!> \param displs ...
9251!> \return ...
9252! ***************************************************************************
9253 FUNCTION mp_type_indexed_make_i (count, lengths, displs) &
9254 result(type_descriptor)
9255 INTEGER, INTENT(IN) :: count
9256 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
9257 TYPE(mp_type_descriptor_type) :: type_descriptor
9258
9259 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_i'
9260
9261 INTEGER :: handle
9262#if defined(__parallel)
9263 INTEGER :: ierr
9264#endif
9265
9266 CALL mp_timeset(routinen, handle)
9267
9268#if defined(__parallel)
9269 CALL mpi_type_indexed(count, lengths, displs, mpi_integer, &
9270 type_descriptor%type_handle, ierr)
9271 IF (ierr /= 0) &
9272 cpabort("MPI_Type_Indexed @ "//routinen)
9273 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
9274 IF (ierr /= 0) &
9275 cpabort("MPI_Type_commit @ "//routinen)
9276#else
9277 type_descriptor%type_handle = 17
9278#endif
9279 type_descriptor%length = count
9280 NULLIFY (type_descriptor%subtype)
9281 type_descriptor%vector_descriptor(1:2) = 1
9282 type_descriptor%has_indexing = .true.
9283 type_descriptor%index_descriptor%index => lengths
9284 type_descriptor%index_descriptor%chunks => displs
9285
9286 CALL mp_timestop(handle)
9287
9288 END FUNCTION mp_type_indexed_make_i
9289
9290! **************************************************************************************************
9291!> \brief Allocates special parallel memory
9292!> \param[in] DATA pointer to integer array to allocate
9293!> \param[in] len number of integers to allocate
9294!> \param[out] stat (optional) allocation status result
9295!> \author UB
9296! **************************************************************************************************
9297 SUBROUTINE mp_allocate_i (DATA, len, stat)
9298 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
9299 INTEGER, INTENT(IN) :: len
9300 INTEGER, INTENT(OUT), OPTIONAL :: stat
9301
9302 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_i'
9303
9304 INTEGER :: handle, ierr
9305
9306 CALL mp_timeset(routinen, handle)
9307
9308#if defined(__parallel)
9309 NULLIFY (data)
9310 CALL mp_alloc_mem(DATA, len, stat=ierr)
9311 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
9312 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
9313 CALL add_perf(perf_id=15, count=1)
9314#else
9315 ALLOCATE (DATA(len), stat=ierr)
9316 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
9317 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
9318#endif
9319 IF (PRESENT(stat)) stat = ierr
9320 CALL mp_timestop(handle)
9321 END SUBROUTINE mp_allocate_i
9322
9323! **************************************************************************************************
9324!> \brief Deallocates special parallel memory
9325!> \param[in] DATA pointer to special memory to deallocate
9326!> \param stat ...
9327!> \author UB
9328! **************************************************************************************************
9329 SUBROUTINE mp_deallocate_i (DATA, stat)
9330 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
9331 INTEGER, INTENT(OUT), OPTIONAL :: stat
9332
9333 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_i'
9334
9335 INTEGER :: handle
9336#if defined(__parallel)
9337 INTEGER :: ierr
9338#endif
9339
9340 CALL mp_timeset(routinen, handle)
9341
9342#if defined(__parallel)
9343 CALL mp_free_mem(DATA, ierr)
9344 IF (PRESENT(stat)) THEN
9345 stat = ierr
9346 ELSE
9347 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
9348 END IF
9349 NULLIFY (data)
9350 CALL add_perf(perf_id=15, count=1)
9351#else
9352 DEALLOCATE (data)
9353 IF (PRESENT(stat)) stat = 0
9354#endif
9355 CALL mp_timestop(handle)
9356 END SUBROUTINE mp_deallocate_i
9357
9358! **************************************************************************************************
9359!> \brief (parallel) Blocking individual file write using explicit offsets
9360!> (serial) Unformatted stream write
9361!> \param[in] fh file handle (file storage unit)
9362!> \param[in] offset file offset (position)
9363!> \param[in] msg data to be written to the file
9364!> \param msglen ...
9365!> \par MPI-I/O mapping mpi_file_write_at
9366!> \par STREAM-I/O mapping WRITE
9367!> \param[in](optional) msglen number of the elements of data
9368! **************************************************************************************************
9369 SUBROUTINE mp_file_write_at_iv(fh, offset, msg, msglen)
9370 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
9371 CLASS(mp_file_type), INTENT(IN) :: fh
9372 INTEGER, INTENT(IN), OPTIONAL :: msglen
9373 INTEGER(kind=file_offset), INTENT(IN) :: offset
9374
9375 INTEGER :: msg_len
9376#if defined(__parallel)
9377 INTEGER :: ierr
9378#endif
9379
9380 msg_len = SIZE(msg)
9381 IF (PRESENT(msglen)) msg_len = msglen
9382#if defined(__parallel)
9383 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9384 IF (ierr .NE. 0) &
9385 cpabort("mpi_file_write_at_iv @ mp_file_write_at_iv")
9386#else
9387 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9388#endif
9389 END SUBROUTINE mp_file_write_at_iv
9390
9391! **************************************************************************************************
9392!> \brief ...
9393!> \param fh ...
9394!> \param offset ...
9395!> \param msg ...
9396! **************************************************************************************************
9397 SUBROUTINE mp_file_write_at_i (fh, offset, msg)
9398 INTEGER(KIND=int_4), INTENT(IN) :: msg
9399 CLASS(mp_file_type), INTENT(IN) :: fh
9400 INTEGER(kind=file_offset), INTENT(IN) :: offset
9401
9402#if defined(__parallel)
9403 INTEGER :: ierr
9404
9405 ierr = 0
9406 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9407 IF (ierr .NE. 0) &
9408 cpabort("mpi_file_write_at_i @ mp_file_write_at_i")
9409#else
9410 WRITE (unit=fh%handle, pos=offset + 1) msg
9411#endif
9412 END SUBROUTINE mp_file_write_at_i
9413
9414! **************************************************************************************************
9415!> \brief (parallel) Blocking collective file write using explicit offsets
9416!> (serial) Unformatted stream write
9417!> \param fh ...
9418!> \param offset ...
9419!> \param msg ...
9420!> \param msglen ...
9421!> \par MPI-I/O mapping mpi_file_write_at_all
9422!> \par STREAM-I/O mapping WRITE
9423! **************************************************************************************************
9424 SUBROUTINE mp_file_write_at_all_iv(fh, offset, msg, msglen)
9425 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
9426 CLASS(mp_file_type), INTENT(IN) :: fh
9427 INTEGER, INTENT(IN), OPTIONAL :: msglen
9428 INTEGER(kind=file_offset), INTENT(IN) :: offset
9429
9430 INTEGER :: msg_len
9431#if defined(__parallel)
9432 INTEGER :: ierr
9433#endif
9434
9435 msg_len = SIZE(msg)
9436 IF (PRESENT(msglen)) msg_len = msglen
9437#if defined(__parallel)
9438 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9439 IF (ierr .NE. 0) &
9440 cpabort("mpi_file_write_at_all_iv @ mp_file_write_at_all_iv")
9441#else
9442 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9443#endif
9444 END SUBROUTINE mp_file_write_at_all_iv
9445
9446! **************************************************************************************************
9447!> \brief ...
9448!> \param fh ...
9449!> \param offset ...
9450!> \param msg ...
9451! **************************************************************************************************
9452 SUBROUTINE mp_file_write_at_all_i (fh, offset, msg)
9453 INTEGER(KIND=int_4), INTENT(IN) :: msg
9454 CLASS(mp_file_type), INTENT(IN) :: fh
9455 INTEGER(kind=file_offset), INTENT(IN) :: offset
9456
9457#if defined(__parallel)
9458 INTEGER :: ierr
9459
9460 ierr = 0
9461 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9462 IF (ierr .NE. 0) &
9463 cpabort("mpi_file_write_at_all_i @ mp_file_write_at_all_i")
9464#else
9465 WRITE (unit=fh%handle, pos=offset + 1) msg
9466#endif
9467 END SUBROUTINE mp_file_write_at_all_i
9468
9469! **************************************************************************************************
9470!> \brief (parallel) Blocking individual file read using explicit offsets
9471!> (serial) Unformatted stream read
9472!> \param[in] fh file handle (file storage unit)
9473!> \param[in] offset file offset (position)
9474!> \param[out] msg data to be read from the file
9475!> \param msglen ...
9476!> \par MPI-I/O mapping mpi_file_read_at
9477!> \par STREAM-I/O mapping READ
9478!> \param[in](optional) msglen number of elements of data
9479! **************************************************************************************************
9480 SUBROUTINE mp_file_read_at_iv(fh, offset, msg, msglen)
9481 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msg(:)
9482 CLASS(mp_file_type), INTENT(IN) :: fh
9483 INTEGER, INTENT(IN), OPTIONAL :: msglen
9484 INTEGER(kind=file_offset), INTENT(IN) :: offset
9485
9486 INTEGER :: msg_len
9487#if defined(__parallel)
9488 INTEGER :: ierr
9489#endif
9490
9491 msg_len = SIZE(msg)
9492 IF (PRESENT(msglen)) msg_len = msglen
9493#if defined(__parallel)
9494 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9495 IF (ierr .NE. 0) &
9496 cpabort("mpi_file_read_at_iv @ mp_file_read_at_iv")
9497#else
9498 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9499#endif
9500 END SUBROUTINE mp_file_read_at_iv
9501
9502! **************************************************************************************************
9503!> \brief ...
9504!> \param fh ...
9505!> \param offset ...
9506!> \param msg ...
9507! **************************************************************************************************
9508 SUBROUTINE mp_file_read_at_i (fh, offset, msg)
9509 INTEGER(KIND=int_4), INTENT(OUT) :: msg
9510 CLASS(mp_file_type), INTENT(IN) :: fh
9511 INTEGER(kind=file_offset), INTENT(IN) :: offset
9512
9513#if defined(__parallel)
9514 INTEGER :: ierr
9515
9516 ierr = 0
9517 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9518 IF (ierr .NE. 0) &
9519 cpabort("mpi_file_read_at_i @ mp_file_read_at_i")
9520#else
9521 READ (unit=fh%handle, pos=offset + 1) msg
9522#endif
9523 END SUBROUTINE mp_file_read_at_i
9524
9525! **************************************************************************************************
9526!> \brief (parallel) Blocking collective file read using explicit offsets
9527!> (serial) Unformatted stream read
9528!> \param fh ...
9529!> \param offset ...
9530!> \param msg ...
9531!> \param msglen ...
9532!> \par MPI-I/O mapping mpi_file_read_at_all
9533!> \par STREAM-I/O mapping READ
9534! **************************************************************************************************
9535 SUBROUTINE mp_file_read_at_all_iv(fh, offset, msg, msglen)
9536 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msg(:)
9537 CLASS(mp_file_type), INTENT(IN) :: fh
9538 INTEGER, INTENT(IN), OPTIONAL :: msglen
9539 INTEGER(kind=file_offset), INTENT(IN) :: offset
9540
9541 INTEGER :: msg_len
9542#if defined(__parallel)
9543 INTEGER :: ierr
9544#endif
9545
9546 msg_len = SIZE(msg)
9547 IF (PRESENT(msglen)) msg_len = msglen
9548#if defined(__parallel)
9549 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9550 IF (ierr .NE. 0) &
9551 cpabort("mpi_file_read_at_all_iv @ mp_file_read_at_all_iv")
9552#else
9553 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9554#endif
9555 END SUBROUTINE mp_file_read_at_all_iv
9556
9557! **************************************************************************************************
9558!> \brief ...
9559!> \param fh ...
9560!> \param offset ...
9561!> \param msg ...
9562! **************************************************************************************************
9563 SUBROUTINE mp_file_read_at_all_i (fh, offset, msg)
9564 INTEGER(KIND=int_4), INTENT(OUT) :: msg
9565 CLASS(mp_file_type), INTENT(IN) :: fh
9566 INTEGER(kind=file_offset), INTENT(IN) :: offset
9567
9568#if defined(__parallel)
9569 INTEGER :: ierr
9570
9571 ierr = 0
9572 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9573 IF (ierr .NE. 0) &
9574 cpabort("mpi_file_read_at_all_i @ mp_file_read_at_all_i")
9575#else
9576 READ (unit=fh%handle, pos=offset + 1) msg
9577#endif
9578 END SUBROUTINE mp_file_read_at_all_i
9579
9580! **************************************************************************************************
9581!> \brief ...
9582!> \param ptr ...
9583!> \param vector_descriptor ...
9584!> \param index_descriptor ...
9585!> \return ...
9586! **************************************************************************************************
9587 FUNCTION mp_type_make_i (ptr, &
9588 vector_descriptor, index_descriptor) &
9589 result(type_descriptor)
9590 INTEGER(KIND=int_4), DIMENSION(:), TARGET, asynchronous :: ptr
9591 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
9592 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
9593 TYPE(mp_type_descriptor_type) :: type_descriptor
9594
9595 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_i'
9596
9597#if defined(__parallel)
9598 INTEGER :: ierr
9599#endif
9600
9601 NULLIFY (type_descriptor%subtype)
9602 type_descriptor%length = SIZE(ptr)
9603#if defined(__parallel)
9604 type_descriptor%type_handle = mpi_integer
9605 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
9606 IF (ierr /= 0) &
9607 cpabort("MPI_Get_address @ "//routinen)
9608#else
9609 type_descriptor%type_handle = 17
9610#endif
9611 type_descriptor%vector_descriptor(1:2) = 1
9612 type_descriptor%has_indexing = .false.
9613 type_descriptor%data_i => ptr
9614 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
9615 cpabort(routinen//": Vectors and indices NYI")
9616 END IF
9617 END FUNCTION mp_type_make_i
9618
9619! **************************************************************************************************
9620!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
9621!> as the Fortran version returns an integer, which we take to be a C_PTR
9622!> \param DATA data array to allocate
9623!> \param[in] len length (in data elements) of data array allocation
9624!> \param[out] stat (optional) allocation status result
9625! **************************************************************************************************
9626 SUBROUTINE mp_alloc_mem_i (DATA, len, stat)
9627 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: data
9628 INTEGER, INTENT(IN) :: len
9629 INTEGER, INTENT(OUT), OPTIONAL :: stat
9630
9631#if defined(__parallel)
9632 INTEGER :: size, ierr, length, &
9633 mp_res
9634 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
9635 TYPE(c_ptr) :: mp_baseptr
9636 mpi_info_type :: mp_info
9637
9638 length = max(len, 1)
9639 CALL mpi_type_size(mpi_integer, size, ierr)
9640 mp_size = int(length, kind=mpi_address_kind)*size
9641 IF (mp_size .GT. mp_max_memory_size) THEN
9642 cpabort("MPI cannot allocate more than 2 GiByte")
9643 END IF
9644 mp_info = mpi_info_null
9645 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
9646 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
9647 IF (PRESENT(stat)) stat = mp_res
9648#else
9649 INTEGER :: length, mystat
9650 length = max(len, 1)
9651 IF (PRESENT(stat)) THEN
9652 ALLOCATE (DATA(length), stat=mystat)
9653 stat = mystat ! show to convention checker that stat is used
9654 ELSE
9655 ALLOCATE (DATA(length))
9656 END IF
9657#endif
9658 END SUBROUTINE mp_alloc_mem_i
9659
9660! **************************************************************************************************
9661!> \brief Deallocates am array, ... this is hackish
9662!> as the Fortran version takes an integer, which we hope to get by reference
9663!> \param DATA data array to allocate
9664!> \param[out] stat (optional) allocation status result
9665! **************************************************************************************************
9666 SUBROUTINE mp_free_mem_i (DATA, stat)
9667 INTEGER(KIND=int_4), DIMENSION(:), &
9668 POINTER, asynchronous :: data
9669 INTEGER, INTENT(OUT), OPTIONAL :: stat
9670
9671#if defined(__parallel)
9672 INTEGER :: mp_res
9673 CALL mpi_free_mem(DATA, mp_res)
9674 IF (PRESENT(stat)) stat = mp_res
9675#else
9676 DEALLOCATE (data)
9677 IF (PRESENT(stat)) stat = 0
9678#endif
9679 END SUBROUTINE mp_free_mem_i
9680! **************************************************************************************************
9681!> \brief Shift around the data in msg
9682!> \param[in,out] msg Rank-2 data to shift
9683!> \param[in] comm message passing environment identifier
9684!> \param[in] displ_in displacements (?)
9685!> \par Example
9686!> msg will be moved from rank to rank+displ_in (in a circular way)
9687!> \par Limitations
9688!> * displ_in will be 1 by default (others not tested)
9689!> * the message array needs to be the same size on all processes
9690! **************************************************************************************************
9691 SUBROUTINE mp_shift_lm(msg, comm, displ_in)
9692
9693 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
9694 CLASS(mp_comm_type), INTENT(IN) :: comm
9695 INTEGER, INTENT(IN), OPTIONAL :: displ_in
9696
9697 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_lm'
9698
9699 INTEGER :: handle, ierror
9700#if defined(__parallel)
9701 INTEGER :: displ, left, &
9702 msglen, myrank, nprocs, &
9703 right, tag
9704#endif
9705
9706 ierror = 0
9707 CALL mp_timeset(routinen, handle)
9708
9709#if defined(__parallel)
9710 CALL mpi_comm_rank(comm%handle, myrank, ierror)
9711 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
9712 CALL mpi_comm_size(comm%handle, nprocs, ierror)
9713 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
9714 IF (PRESENT(displ_in)) THEN
9715 displ = displ_in
9716 ELSE
9717 displ = 1
9718 END IF
9719 right = modulo(myrank + displ, nprocs)
9720 left = modulo(myrank - displ, nprocs)
9721 tag = 17
9722 msglen = SIZE(msg)
9723 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer8, right, tag, left, tag, &
9724 comm%handle, mpi_status_ignore, ierror)
9725 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
9726 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_8_size)
9727#else
9728 mark_used(msg)
9729 mark_used(comm)
9730 mark_used(displ_in)
9731#endif
9732 CALL mp_timestop(handle)
9733
9734 END SUBROUTINE mp_shift_lm
9735
9736! **************************************************************************************************
9737!> \brief Shift around the data in msg
9738!> \param[in,out] msg Data to shift
9739!> \param[in] comm message passing environment identifier
9740!> \param[in] displ_in displacements (?)
9741!> \par Example
9742!> msg will be moved from rank to rank+displ_in (in a circular way)
9743!> \par Limitations
9744!> * displ_in will be 1 by default (others not tested)
9745!> * the message array needs to be the same size on all processes
9746! **************************************************************************************************
9747 SUBROUTINE mp_shift_l (msg, comm, displ_in)
9748
9749 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
9750 CLASS(mp_comm_type), INTENT(IN) :: comm
9751 INTEGER, INTENT(IN), OPTIONAL :: displ_in
9752
9753 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_l'
9754
9755 INTEGER :: handle, ierror
9756#if defined(__parallel)
9757 INTEGER :: displ, left, &
9758 msglen, myrank, nprocs, &
9759 right, tag
9760#endif
9761
9762 ierror = 0
9763 CALL mp_timeset(routinen, handle)
9764
9765#if defined(__parallel)
9766 CALL mpi_comm_rank(comm%handle, myrank, ierror)
9767 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
9768 CALL mpi_comm_size(comm%handle, nprocs, ierror)
9769 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
9770 IF (PRESENT(displ_in)) THEN
9771 displ = displ_in
9772 ELSE
9773 displ = 1
9774 END IF
9775 right = modulo(myrank + displ, nprocs)
9776 left = modulo(myrank - displ, nprocs)
9777 tag = 19
9778 msglen = SIZE(msg)
9779 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer8, right, tag, left, &
9780 tag, comm%handle, mpi_status_ignore, ierror)
9781 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
9782 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_8_size)
9783#else
9784 mark_used(msg)
9785 mark_used(comm)
9786 mark_used(displ_in)
9787#endif
9788 CALL mp_timestop(handle)
9789
9790 END SUBROUTINE mp_shift_l
9791
9792! **************************************************************************************************
9793!> \brief All-to-all data exchange, rank-1 data of different sizes
9794!> \param[in] sb Data to send
9795!> \param[in] scount Data counts for data sent to other processes
9796!> \param[in] sdispl Respective data offsets for data sent to process
9797!> \param[in,out] rb Buffer into which to receive data
9798!> \param[in] rcount Data counts for data received from other
9799!> processes
9800!> \param[in] rdispl Respective data offsets for data received from
9801!> other processes
9802!> \param[in] comm Message passing environment identifier
9803!> \par MPI mapping
9804!> mpi_alltoallv
9805!> \par Array sizes
9806!> The scount, rcount, and the sdispl and rdispl arrays have a
9807!> size equal to the number of processes.
9808!> \par Offsets
9809!> Values in sdispl and rdispl start with 0.
9810! **************************************************************************************************
9811 SUBROUTINE mp_alltoall_l11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
9812
9813 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
9814 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
9815 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
9816 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
9817 CLASS(mp_comm_type), INTENT(IN) :: comm
9818
9819 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l11v'
9820
9821 INTEGER :: handle
9822#if defined(__parallel)
9823 INTEGER :: ierr, msglen
9824#else
9825 INTEGER :: i
9826#endif
9827
9828 CALL mp_timeset(routinen, handle)
9829
9830#if defined(__parallel)
9831 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer8, &
9832 rb, rcount, rdispl, mpi_integer8, comm%handle, ierr)
9833 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
9834 msglen = sum(scount) + sum(rcount)
9835 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9836#else
9837 mark_used(comm)
9838 mark_used(scount)
9839 mark_used(sdispl)
9840 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
9841 DO i = 1, rcount(1)
9842 rb(rdispl(1) + i) = sb(sdispl(1) + i)
9843 END DO
9844#endif
9845 CALL mp_timestop(handle)
9846
9847 END SUBROUTINE mp_alltoall_l11v
9848
9849! **************************************************************************************************
9850!> \brief All-to-all data exchange, rank-2 data of different sizes
9851!> \param sb ...
9852!> \param scount ...
9853!> \param sdispl ...
9854!> \param rb ...
9855!> \param rcount ...
9856!> \param rdispl ...
9857!> \param comm ...
9858!> \par MPI mapping
9859!> mpi_alltoallv
9860!> \note see mp_alltoall_l11v
9861! **************************************************************************************************
9862 SUBROUTINE mp_alltoall_l22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
9863
9864 INTEGER(KIND=int_8), DIMENSION(:, :), &
9865 INTENT(IN), CONTIGUOUS :: sb
9866 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
9867 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, &
9868 INTENT(INOUT) :: rb
9869 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
9870 CLASS(mp_comm_type), INTENT(IN) :: comm
9871
9872 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l22v'
9873
9874 INTEGER :: handle
9875#if defined(__parallel)
9876 INTEGER :: ierr, msglen
9877#endif
9878
9879 CALL mp_timeset(routinen, handle)
9880
9881#if defined(__parallel)
9882 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer8, &
9883 rb, rcount, rdispl, mpi_integer8, comm%handle, ierr)
9884 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
9885 msglen = sum(scount) + sum(rcount)
9886 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*int_8_size)
9887#else
9888 mark_used(comm)
9889 mark_used(scount)
9890 mark_used(sdispl)
9891 mark_used(rcount)
9892 mark_used(rdispl)
9893 rb = sb
9894#endif
9895 CALL mp_timestop(handle)
9896
9897 END SUBROUTINE mp_alltoall_l22v
9898
9899! **************************************************************************************************
9900!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
9901!> \param[in] sb array with data to send
9902!> \param[out] rb array into which data is received
9903!> \param[in] count number of elements to send/receive (product of the
9904!> extents of the first two dimensions)
9905!> \param[in] comm Message passing environment identifier
9906!> \par Index meaning
9907!> \par The first two indices specify the data while the last index counts
9908!> the processes
9909!> \par Sizes of ranks
9910!> All processes have the same data size.
9911!> \par MPI mapping
9912!> mpi_alltoall
9913! **************************************************************************************************
9914 SUBROUTINE mp_alltoall_l (sb, rb, count, comm)
9915
9916 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
9917 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
9918 INTEGER, INTENT(IN) :: count
9919 CLASS(mp_comm_type), INTENT(IN) :: comm
9920
9921 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l'
9922
9923 INTEGER :: handle
9924#if defined(__parallel)
9925 INTEGER :: ierr, msglen, np
9926#endif
9927
9928 CALL mp_timeset(routinen, handle)
9929
9930#if defined(__parallel)
9931 CALL mpi_alltoall(sb, count, mpi_integer8, &
9932 rb, count, mpi_integer8, comm%handle, ierr)
9933 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9934 CALL mpi_comm_size(comm%handle, np, ierr)
9935 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9936 msglen = 2*count*np
9937 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9938#else
9939 mark_used(count)
9940 mark_used(comm)
9941 rb = sb
9942#endif
9943 CALL mp_timestop(handle)
9944
9945 END SUBROUTINE mp_alltoall_l
9946
9947! **************************************************************************************************
9948!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
9949!> \param sb ...
9950!> \param rb ...
9951!> \param count ...
9952!> \param commp ...
9953!> \note see mp_alltoall_l
9954! **************************************************************************************************
9955 SUBROUTINE mp_alltoall_l22(sb, rb, count, comm)
9956
9957 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
9958 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
9959 INTEGER, INTENT(IN) :: count
9960 CLASS(mp_comm_type), INTENT(IN) :: comm
9961
9962 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l22'
9963
9964 INTEGER :: handle
9965#if defined(__parallel)
9966 INTEGER :: ierr, msglen, np
9967#endif
9968
9969 CALL mp_timeset(routinen, handle)
9970
9971#if defined(__parallel)
9972 CALL mpi_alltoall(sb, count, mpi_integer8, &
9973 rb, count, mpi_integer8, comm%handle, ierr)
9974 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9975 CALL mpi_comm_size(comm%handle, np, ierr)
9976 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9977 msglen = 2*SIZE(sb)*np
9978 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9979#else
9980 mark_used(count)
9981 mark_used(comm)
9982 rb = sb
9983#endif
9984 CALL mp_timestop(handle)
9985
9986 END SUBROUTINE mp_alltoall_l22
9987
9988! **************************************************************************************************
9989!> \brief All-to-all data exchange, rank-3 data with equal sizes
9990!> \param sb ...
9991!> \param rb ...
9992!> \param count ...
9993!> \param comm ...
9994!> \note see mp_alltoall_l
9995! **************************************************************************************************
9996 SUBROUTINE mp_alltoall_l33(sb, rb, count, comm)
9997
9998 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
9999 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
10000 INTEGER, INTENT(IN) :: count
10001 CLASS(mp_comm_type), INTENT(IN) :: comm
10002
10003 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l33'
10004
10005 INTEGER :: handle
10006#if defined(__parallel)
10007 INTEGER :: ierr, msglen, np
10008#endif
10009
10010 CALL mp_timeset(routinen, handle)
10011
10012#if defined(__parallel)
10013 CALL mpi_alltoall(sb, count, mpi_integer8, &
10014 rb, count, mpi_integer8, comm%handle, ierr)
10015 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10016 CALL mpi_comm_size(comm%handle, np, ierr)
10017 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10018 msglen = 2*count*np
10019 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10020#else
10021 mark_used(count)
10022 mark_used(comm)
10023 rb = sb
10024#endif
10025 CALL mp_timestop(handle)
10026
10027 END SUBROUTINE mp_alltoall_l33
10028
10029! **************************************************************************************************
10030!> \brief All-to-all data exchange, rank 4 data, equal sizes
10031!> \param sb ...
10032!> \param rb ...
10033!> \param count ...
10034!> \param comm ...
10035!> \note see mp_alltoall_l
10036! **************************************************************************************************
10037 SUBROUTINE mp_alltoall_l44(sb, rb, count, comm)
10038
10039 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10040 INTENT(IN) :: sb
10041 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10042 INTENT(OUT) :: rb
10043 INTEGER, INTENT(IN) :: count
10044 CLASS(mp_comm_type), INTENT(IN) :: comm
10045
10046 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l44'
10047
10048 INTEGER :: handle
10049#if defined(__parallel)
10050 INTEGER :: ierr, msglen, np
10051#endif
10052
10053 CALL mp_timeset(routinen, handle)
10054
10055#if defined(__parallel)
10056 CALL mpi_alltoall(sb, count, mpi_integer8, &
10057 rb, count, mpi_integer8, comm%handle, ierr)
10058 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10059 CALL mpi_comm_size(comm%handle, np, ierr)
10060 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10061 msglen = 2*count*np
10062 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10063#else
10064 mark_used(count)
10065 mark_used(comm)
10066 rb = sb
10067#endif
10068 CALL mp_timestop(handle)
10069
10070 END SUBROUTINE mp_alltoall_l44
10071
10072! **************************************************************************************************
10073!> \brief All-to-all data exchange, rank 5 data, equal sizes
10074!> \param sb ...
10075!> \param rb ...
10076!> \param count ...
10077!> \param comm ...
10078!> \note see mp_alltoall_l
10079! **************************************************************************************************
10080 SUBROUTINE mp_alltoall_l55(sb, rb, count, comm)
10081
10082 INTEGER(KIND=int_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
10083 INTENT(IN) :: sb
10084 INTEGER(KIND=int_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
10085 INTENT(OUT) :: rb
10086 INTEGER, INTENT(IN) :: count
10087 CLASS(mp_comm_type), INTENT(IN) :: comm
10088
10089 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l55'
10090
10091 INTEGER :: handle
10092#if defined(__parallel)
10093 INTEGER :: ierr, msglen, np
10094#endif
10095
10096 CALL mp_timeset(routinen, handle)
10097
10098#if defined(__parallel)
10099 CALL mpi_alltoall(sb, count, mpi_integer8, &
10100 rb, count, mpi_integer8, comm%handle, ierr)
10101 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10102 CALL mpi_comm_size(comm%handle, np, ierr)
10103 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10104 msglen = 2*count*np
10105 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10106#else
10107 mark_used(count)
10108 mark_used(comm)
10109 rb = sb
10110#endif
10111 CALL mp_timestop(handle)
10112
10113 END SUBROUTINE mp_alltoall_l55
10114
10115! **************************************************************************************************
10116!> \brief All-to-all data exchange, rank-4 data to rank-5 data
10117!> \param sb ...
10118!> \param rb ...
10119!> \param count ...
10120!> \param comm ...
10121!> \note see mp_alltoall_l
10122!> \note User must ensure size consistency.
10123! **************************************************************************************************
10124 SUBROUTINE mp_alltoall_l45(sb, rb, count, comm)
10125
10126 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10127 INTENT(IN) :: sb
10128 INTEGER(KIND=int_8), &
10129 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
10130 INTEGER, INTENT(IN) :: count
10131 CLASS(mp_comm_type), INTENT(IN) :: comm
10132
10133 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l45'
10134
10135 INTEGER :: handle
10136#if defined(__parallel)
10137 INTEGER :: ierr, msglen, np
10138#endif
10139
10140 CALL mp_timeset(routinen, handle)
10141
10142#if defined(__parallel)
10143 CALL mpi_alltoall(sb, count, mpi_integer8, &
10144 rb, count, mpi_integer8, comm%handle, ierr)
10145 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10146 CALL mpi_comm_size(comm%handle, np, ierr)
10147 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10148 msglen = 2*count*np
10149 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10150#else
10151 mark_used(count)
10152 mark_used(comm)
10153 rb = reshape(sb, shape(rb))
10154#endif
10155 CALL mp_timestop(handle)
10156
10157 END SUBROUTINE mp_alltoall_l45
10158
10159! **************************************************************************************************
10160!> \brief All-to-all data exchange, rank-3 data to rank-4 data
10161!> \param sb ...
10162!> \param rb ...
10163!> \param count ...
10164!> \param comm ...
10165!> \note see mp_alltoall_l
10166!> \note User must ensure size consistency.
10167! **************************************************************************************************
10168 SUBROUTINE mp_alltoall_l34(sb, rb, count, comm)
10169
10170 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, &
10171 INTENT(IN) :: sb
10172 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10173 INTENT(OUT) :: rb
10174 INTEGER, INTENT(IN) :: count
10175 CLASS(mp_comm_type), INTENT(IN) :: comm
10176
10177 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l34'
10178
10179 INTEGER :: handle
10180#if defined(__parallel)
10181 INTEGER :: ierr, msglen, np
10182#endif
10183
10184 CALL mp_timeset(routinen, handle)
10185
10186#if defined(__parallel)
10187 CALL mpi_alltoall(sb, count, mpi_integer8, &
10188 rb, count, mpi_integer8, comm%handle, ierr)
10189 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10190 CALL mpi_comm_size(comm%handle, np, ierr)
10191 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10192 msglen = 2*count*np
10193 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10194#else
10195 mark_used(count)
10196 mark_used(comm)
10197 rb = reshape(sb, shape(rb))
10198#endif
10199 CALL mp_timestop(handle)
10200
10201 END SUBROUTINE mp_alltoall_l34
10202
10203! **************************************************************************************************
10204!> \brief All-to-all data exchange, rank-5 data to rank-4 data
10205!> \param sb ...
10206!> \param rb ...
10207!> \param count ...
10208!> \param comm ...
10209!> \note see mp_alltoall_l
10210!> \note User must ensure size consistency.
10211! **************************************************************************************************
10212 SUBROUTINE mp_alltoall_l54(sb, rb, count, comm)
10213
10214 INTEGER(KIND=int_8), &
10215 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
10216 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10217 INTENT(OUT) :: rb
10218 INTEGER, INTENT(IN) :: count
10219 CLASS(mp_comm_type), INTENT(IN) :: comm
10220
10221 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l54'
10222
10223 INTEGER :: handle
10224#if defined(__parallel)
10225 INTEGER :: ierr, msglen, np
10226#endif
10227
10228 CALL mp_timeset(routinen, handle)
10229
10230#if defined(__parallel)
10231 CALL mpi_alltoall(sb, count, mpi_integer8, &
10232 rb, count, mpi_integer8, comm%handle, ierr)
10233 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10234 CALL mpi_comm_size(comm%handle, np, ierr)
10235 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10236 msglen = 2*count*np
10237 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10238#else
10239 mark_used(count)
10240 mark_used(comm)
10241 rb = reshape(sb, shape(rb))
10242#endif
10243 CALL mp_timestop(handle)
10244
10245 END SUBROUTINE mp_alltoall_l54
10246
10247! **************************************************************************************************
10248!> \brief Send one datum to another process
10249!> \param[in] msg Scalar to send
10250!> \param[in] dest Destination process
10251!> \param[in] tag Transfer identifier
10252!> \param[in] comm Message passing environment identifier
10253!> \par MPI mapping
10254!> mpi_send
10255! **************************************************************************************************
10256 SUBROUTINE mp_send_l (msg, dest, tag, comm)
10257 INTEGER(KIND=int_8), INTENT(IN) :: msg
10258 INTEGER, INTENT(IN) :: dest, tag
10259 CLASS(mp_comm_type), INTENT(IN) :: comm
10260
10261 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_l'
10262
10263 INTEGER :: handle
10264#if defined(__parallel)
10265 INTEGER :: ierr, msglen
10266#endif
10267
10268 CALL mp_timeset(routinen, handle)
10269
10270#if defined(__parallel)
10271 msglen = 1
10272 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10273 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10274 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10275#else
10276 mark_used(msg)
10277 mark_used(dest)
10278 mark_used(tag)
10279 mark_used(comm)
10280 ! only defined in parallel
10281 cpabort("not in parallel mode")
10282#endif
10283 CALL mp_timestop(handle)
10284 END SUBROUTINE mp_send_l
10285
10286! **************************************************************************************************
10287!> \brief Send rank-1 data to another process
10288!> \param[in] msg Rank-1 data to send
10289!> \param dest ...
10290!> \param tag ...
10291!> \param comm ...
10292!> \note see mp_send_l
10293! **************************************************************************************************
10294 SUBROUTINE mp_send_lv(msg, dest, tag, comm)
10295 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
10296 INTEGER, INTENT(IN) :: dest, tag
10297 CLASS(mp_comm_type), INTENT(IN) :: comm
10298
10299 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_lv'
10300
10301 INTEGER :: handle
10302#if defined(__parallel)
10303 INTEGER :: ierr, msglen
10304#endif
10305
10306 CALL mp_timeset(routinen, handle)
10307
10308#if defined(__parallel)
10309 msglen = SIZE(msg)
10310 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10311 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10312 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10313#else
10314 mark_used(msg)
10315 mark_used(dest)
10316 mark_used(tag)
10317 mark_used(comm)
10318 ! only defined in parallel
10319 cpabort("not in parallel mode")
10320#endif
10321 CALL mp_timestop(handle)
10322 END SUBROUTINE mp_send_lv
10323
10324! **************************************************************************************************
10325!> \brief Send rank-2 data to another process
10326!> \param[in] msg Rank-2 data to send
10327!> \param dest ...
10328!> \param tag ...
10329!> \param comm ...
10330!> \note see mp_send_l
10331! **************************************************************************************************
10332 SUBROUTINE mp_send_lm2(msg, dest, tag, comm)
10333 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
10334 INTEGER, INTENT(IN) :: dest, tag
10335 CLASS(mp_comm_type), INTENT(IN) :: comm
10336
10337 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_lm2'
10338
10339 INTEGER :: handle
10340#if defined(__parallel)
10341 INTEGER :: ierr, msglen
10342#endif
10343
10344 CALL mp_timeset(routinen, handle)
10345
10346#if defined(__parallel)
10347 msglen = SIZE(msg)
10348 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10349 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10350 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10351#else
10352 mark_used(msg)
10353 mark_used(dest)
10354 mark_used(tag)
10355 mark_used(comm)
10356 ! only defined in parallel
10357 cpabort("not in parallel mode")
10358#endif
10359 CALL mp_timestop(handle)
10360 END SUBROUTINE mp_send_lm2
10361
10362! **************************************************************************************************
10363!> \brief Send rank-3 data to another process
10364!> \param[in] msg Rank-3 data to send
10365!> \param dest ...
10366!> \param tag ...
10367!> \param comm ...
10368!> \note see mp_send_l
10369! **************************************************************************************************
10370 SUBROUTINE mp_send_lm3(msg, dest, tag, comm)
10371 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
10372 INTEGER, INTENT(IN) :: dest, tag
10373 CLASS(mp_comm_type), INTENT(IN) :: comm
10374
10375 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
10376
10377 INTEGER :: handle
10378#if defined(__parallel)
10379 INTEGER :: ierr, msglen
10380#endif
10381
10382 CALL mp_timeset(routinen, handle)
10383
10384#if defined(__parallel)
10385 msglen = SIZE(msg)
10386 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10387 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10388 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10389#else
10390 mark_used(msg)
10391 mark_used(dest)
10392 mark_used(tag)
10393 mark_used(comm)
10394 ! only defined in parallel
10395 cpabort("not in parallel mode")
10396#endif
10397 CALL mp_timestop(handle)
10398 END SUBROUTINE mp_send_lm3
10399
10400! **************************************************************************************************
10401!> \brief Receive one datum from another process
10402!> \param[in,out] msg Place received data into this variable
10403!> \param[in,out] source Process to receive from
10404!> \param[in,out] tag Transfer identifier
10405!> \param[in] comm Message passing environment identifier
10406!> \par MPI mapping
10407!> mpi_send
10408! **************************************************************************************************
10409 SUBROUTINE mp_recv_l (msg, source, tag, comm)
10410 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10411 INTEGER, INTENT(INOUT) :: source, tag
10412 CLASS(mp_comm_type), INTENT(IN) :: comm
10413
10414 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_l'
10415
10416 INTEGER :: handle
10417#if defined(__parallel)
10418 INTEGER :: ierr, msglen
10419 mpi_status_type :: status
10420#endif
10421
10422 CALL mp_timeset(routinen, handle)
10423
10424#if defined(__parallel)
10425 msglen = 1
10426 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10427 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10428 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10429 ELSE
10430 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10431 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10432 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10433 source = status mpi_status_extract(mpi_source)
10434 tag = status mpi_status_extract(mpi_tag)
10435 END IF
10436#else
10437 mark_used(msg)
10438 mark_used(source)
10439 mark_used(tag)
10440 mark_used(comm)
10441 ! only defined in parallel
10442 cpabort("not in parallel mode")
10443#endif
10444 CALL mp_timestop(handle)
10445 END SUBROUTINE mp_recv_l
10446
10447! **************************************************************************************************
10448!> \brief Receive rank-1 data from another process
10449!> \param[in,out] msg Place received data into this rank-1 array
10450!> \param source ...
10451!> \param tag ...
10452!> \param comm ...
10453!> \note see mp_recv_l
10454! **************************************************************************************************
10455 SUBROUTINE mp_recv_lv(msg, source, tag, comm)
10456 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10457 INTEGER, INTENT(INOUT) :: source, tag
10458 CLASS(mp_comm_type), INTENT(IN) :: comm
10459
10460 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lv'
10461
10462 INTEGER :: handle
10463#if defined(__parallel)
10464 INTEGER :: ierr, msglen
10465 mpi_status_type :: status
10466#endif
10467
10468 CALL mp_timeset(routinen, handle)
10469
10470#if defined(__parallel)
10471 msglen = SIZE(msg)
10472 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10473 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10474 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10475 ELSE
10476 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10477 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10478 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10479 source = status mpi_status_extract(mpi_source)
10480 tag = status mpi_status_extract(mpi_tag)
10481 END IF
10482#else
10483 mark_used(msg)
10484 mark_used(source)
10485 mark_used(tag)
10486 mark_used(comm)
10487 ! only defined in parallel
10488 cpabort("not in parallel mode")
10489#endif
10490 CALL mp_timestop(handle)
10491 END SUBROUTINE mp_recv_lv
10492
10493! **************************************************************************************************
10494!> \brief Receive rank-2 data from another process
10495!> \param[in,out] msg Place received data into this rank-2 array
10496!> \param source ...
10497!> \param tag ...
10498!> \param comm ...
10499!> \note see mp_recv_l
10500! **************************************************************************************************
10501 SUBROUTINE mp_recv_lm2(msg, source, tag, comm)
10502 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10503 INTEGER, INTENT(INOUT) :: source, tag
10504 CLASS(mp_comm_type), INTENT(IN) :: comm
10505
10506 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lm2'
10507
10508 INTEGER :: handle
10509#if defined(__parallel)
10510 INTEGER :: ierr, msglen
10511 mpi_status_type :: status
10512#endif
10513
10514 CALL mp_timeset(routinen, handle)
10515
10516#if defined(__parallel)
10517 msglen = SIZE(msg)
10518 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10519 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10520 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10521 ELSE
10522 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10523 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10524 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10525 source = status mpi_status_extract(mpi_source)
10526 tag = status mpi_status_extract(mpi_tag)
10527 END IF
10528#else
10529 mark_used(msg)
10530 mark_used(source)
10531 mark_used(tag)
10532 mark_used(comm)
10533 ! only defined in parallel
10534 cpabort("not in parallel mode")
10535#endif
10536 CALL mp_timestop(handle)
10537 END SUBROUTINE mp_recv_lm2
10538
10539! **************************************************************************************************
10540!> \brief Receive rank-3 data from another process
10541!> \param[in,out] msg Place received data into this rank-3 array
10542!> \param source ...
10543!> \param tag ...
10544!> \param comm ...
10545!> \note see mp_recv_l
10546! **************************************************************************************************
10547 SUBROUTINE mp_recv_lm3(msg, source, tag, comm)
10548 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
10549 INTEGER, INTENT(INOUT) :: source, tag
10550 CLASS(mp_comm_type), INTENT(IN) :: comm
10551
10552 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lm3'
10553
10554 INTEGER :: handle
10555#if defined(__parallel)
10556 INTEGER :: ierr, msglen
10557 mpi_status_type :: status
10558#endif
10559
10560 CALL mp_timeset(routinen, handle)
10561
10562#if defined(__parallel)
10563 msglen = SIZE(msg)
10564 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10565 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10566 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10567 ELSE
10568 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10569 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10570 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10571 source = status mpi_status_extract(mpi_source)
10572 tag = status mpi_status_extract(mpi_tag)
10573 END IF
10574#else
10575 mark_used(msg)
10576 mark_used(source)
10577 mark_used(tag)
10578 mark_used(comm)
10579 ! only defined in parallel
10580 cpabort("not in parallel mode")
10581#endif
10582 CALL mp_timestop(handle)
10583 END SUBROUTINE mp_recv_lm3
10584
10585! **************************************************************************************************
10586!> \brief Broadcasts a datum to all processes.
10587!> \param[in] msg Datum to broadcast
10588!> \param[in] source Processes which broadcasts
10589!> \param[in] comm Message passing environment identifier
10590!> \par MPI mapping
10591!> mpi_bcast
10592! **************************************************************************************************
10593 SUBROUTINE mp_bcast_l (msg, source, comm)
10594 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10595 INTEGER, INTENT(IN) :: source
10596 CLASS(mp_comm_type), INTENT(IN) :: comm
10597
10598 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l'
10599
10600 INTEGER :: handle
10601#if defined(__parallel)
10602 INTEGER :: ierr, msglen
10603#endif
10604
10605 CALL mp_timeset(routinen, handle)
10606
10607#if defined(__parallel)
10608 msglen = 1
10609 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10610 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10611 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10612#else
10613 mark_used(msg)
10614 mark_used(source)
10615 mark_used(comm)
10616#endif
10617 CALL mp_timestop(handle)
10618 END SUBROUTINE mp_bcast_l
10619
10620! **************************************************************************************************
10621!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
10622!> \param[in] msg Datum to broadcast
10623!> \param[in] comm Message passing environment identifier
10624!> \par MPI mapping
10625!> mpi_bcast
10626! **************************************************************************************************
10627 SUBROUTINE mp_bcast_l_src(msg, comm)
10628 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10629 CLASS(mp_comm_type), INTENT(IN) :: comm
10630
10631 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l_src'
10632
10633 INTEGER :: handle
10634#if defined(__parallel)
10635 INTEGER :: ierr, msglen
10636#endif
10637
10638 CALL mp_timeset(routinen, handle)
10639
10640#if defined(__parallel)
10641 msglen = 1
10642 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10643 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10644 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10645#else
10646 mark_used(msg)
10647 mark_used(comm)
10648#endif
10649 CALL mp_timestop(handle)
10650 END SUBROUTINE mp_bcast_l_src
10651
10652! **************************************************************************************************
10653!> \brief Broadcasts a datum to all processes.
10654!> \param[in] msg Datum to broadcast
10655!> \param[in] source Processes which broadcasts
10656!> \param[in] comm Message passing environment identifier
10657!> \par MPI mapping
10658!> mpi_bcast
10659! **************************************************************************************************
10660 SUBROUTINE mp_ibcast_l (msg, source, comm, request)
10661 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10662 INTEGER, INTENT(IN) :: source
10663 CLASS(mp_comm_type), INTENT(IN) :: comm
10664 TYPE(mp_request_type), INTENT(OUT) :: request
10665
10666 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_l'
10667
10668 INTEGER :: handle
10669#if defined(__parallel)
10670 INTEGER :: ierr, msglen
10671#endif
10672
10673 CALL mp_timeset(routinen, handle)
10674
10675#if defined(__parallel)
10676 msglen = 1
10677 CALL mpi_ibcast(msg, msglen, mpi_integer8, source, comm%handle, request%handle, ierr)
10678 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
10679 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_8_size)
10680#else
10681 mark_used(msg)
10682 mark_used(source)
10683 mark_used(comm)
10684 request = mp_request_null
10685#endif
10686 CALL mp_timestop(handle)
10687 END SUBROUTINE mp_ibcast_l
10688
10689! **************************************************************************************************
10690!> \brief Broadcasts rank-1 data to all processes
10691!> \param[in] msg Data to broadcast
10692!> \param source ...
10693!> \param comm ...
10694!> \note see mp_bcast_l1
10695! **************************************************************************************************
10696 SUBROUTINE mp_bcast_lv(msg, source, comm)
10697 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10698 INTEGER, INTENT(IN) :: source
10699 CLASS(mp_comm_type), INTENT(IN) :: comm
10700
10701 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lv'
10702
10703 INTEGER :: handle
10704#if defined(__parallel)
10705 INTEGER :: ierr, msglen
10706#endif
10707
10708 CALL mp_timeset(routinen, handle)
10709
10710#if defined(__parallel)
10711 msglen = SIZE(msg)
10712 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10713 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10714 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10715#else
10716 mark_used(msg)
10717 mark_used(source)
10718 mark_used(comm)
10719#endif
10720 CALL mp_timestop(handle)
10721 END SUBROUTINE mp_bcast_lv
10722
10723! **************************************************************************************************
10724!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
10725!> \param[in] msg Data to broadcast
10726!> \param comm ...
10727!> \note see mp_bcast_l1
10728! **************************************************************************************************
10729 SUBROUTINE mp_bcast_lv_src(msg, comm)
10730 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10731 CLASS(mp_comm_type), INTENT(IN) :: comm
10732
10733 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lv_src'
10734
10735 INTEGER :: handle
10736#if defined(__parallel)
10737 INTEGER :: ierr, msglen
10738#endif
10739
10740 CALL mp_timeset(routinen, handle)
10741
10742#if defined(__parallel)
10743 msglen = SIZE(msg)
10744 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10745 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10746 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10747#else
10748 mark_used(msg)
10749 mark_used(comm)
10750#endif
10751 CALL mp_timestop(handle)
10752 END SUBROUTINE mp_bcast_lv_src
10753
10754! **************************************************************************************************
10755!> \brief Broadcasts rank-1 data to all processes
10756!> \param[in] msg Data to broadcast
10757!> \param source ...
10758!> \param comm ...
10759!> \note see mp_bcast_l1
10760! **************************************************************************************************
10761 SUBROUTINE mp_ibcast_lv(msg, source, comm, request)
10762 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
10763 INTEGER, INTENT(IN) :: source
10764 CLASS(mp_comm_type), INTENT(IN) :: comm
10765 TYPE(mp_request_type) :: request
10766
10767 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_lv'
10768
10769 INTEGER :: handle
10770#if defined(__parallel)
10771 INTEGER :: ierr, msglen
10772#endif
10773
10774 CALL mp_timeset(routinen, handle)
10775
10776#if defined(__parallel)
10777#if !defined(__GNUC__) || __GNUC__ >= 9
10778 cpassert(is_contiguous(msg))
10779#endif
10780 msglen = SIZE(msg)
10781 CALL mpi_ibcast(msg, msglen, mpi_integer8, source, comm%handle, request%handle, ierr)
10782 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
10783 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_8_size)
10784#else
10785 mark_used(msg)
10786 mark_used(source)
10787 mark_used(comm)
10788 request = mp_request_null
10789#endif
10790 CALL mp_timestop(handle)
10791 END SUBROUTINE mp_ibcast_lv
10792
10793! **************************************************************************************************
10794!> \brief Broadcasts rank-2 data to all processes
10795!> \param[in] msg Data to broadcast
10796!> \param source ...
10797!> \param comm ...
10798!> \note see mp_bcast_l1
10799! **************************************************************************************************
10800 SUBROUTINE mp_bcast_lm(msg, source, comm)
10801 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10802 INTEGER, INTENT(IN) :: source
10803 CLASS(mp_comm_type), INTENT(IN) :: comm
10804
10805 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lm'
10806
10807 INTEGER :: handle
10808#if defined(__parallel)
10809 INTEGER :: ierr, msglen
10810#endif
10811
10812 CALL mp_timeset(routinen, handle)
10813
10814#if defined(__parallel)
10815 msglen = SIZE(msg)
10816 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10817 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10818 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10819#else
10820 mark_used(msg)
10821 mark_used(source)
10822 mark_used(comm)
10823#endif
10824 CALL mp_timestop(handle)
10825 END SUBROUTINE mp_bcast_lm
10826
10827! **************************************************************************************************
10828!> \brief Broadcasts rank-2 data to all processes
10829!> \param[in] msg Data to broadcast
10830!> \param source ...
10831!> \param comm ...
10832!> \note see mp_bcast_l1
10833! **************************************************************************************************
10834 SUBROUTINE mp_bcast_lm_src(msg, comm)
10835 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10836 CLASS(mp_comm_type), INTENT(IN) :: comm
10837
10838 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lm_src'
10839
10840 INTEGER :: handle
10841#if defined(__parallel)
10842 INTEGER :: ierr, msglen
10843#endif
10844
10845 CALL mp_timeset(routinen, handle)
10846
10847#if defined(__parallel)
10848 msglen = SIZE(msg)
10849 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10850 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10851 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10852#else
10853 mark_used(msg)
10854 mark_used(comm)
10855#endif
10856 CALL mp_timestop(handle)
10857 END SUBROUTINE mp_bcast_lm_src
10858
10859! **************************************************************************************************
10860!> \brief Broadcasts rank-3 data to all processes
10861!> \param[in] msg Data to broadcast
10862!> \param source ...
10863!> \param comm ...
10864!> \note see mp_bcast_l1
10865! **************************************************************************************************
10866 SUBROUTINE mp_bcast_l3(msg, source, comm)
10867 INTEGER(KIND=int_8), CONTIGUOUS :: msg(:, :, :)
10868 INTEGER, INTENT(IN) :: source
10869 CLASS(mp_comm_type), INTENT(IN) :: comm
10870
10871 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l3'
10872
10873 INTEGER :: handle
10874#if defined(__parallel)
10875 INTEGER :: ierr, msglen
10876#endif
10877
10878 CALL mp_timeset(routinen, handle)
10879
10880#if defined(__parallel)
10881 msglen = SIZE(msg)
10882 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10883 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10884 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10885#else
10886 mark_used(msg)
10887 mark_used(source)
10888 mark_used(comm)
10889#endif
10890 CALL mp_timestop(handle)
10891 END SUBROUTINE mp_bcast_l3
10892
10893! **************************************************************************************************
10894!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
10895!> \param[in] msg Data to broadcast
10896!> \param source ...
10897!> \param comm ...
10898!> \note see mp_bcast_l1
10899! **************************************************************************************************
10900 SUBROUTINE mp_bcast_l3_src(msg, comm)
10901 INTEGER(KIND=int_8), CONTIGUOUS :: msg(:, :, :)
10902 CLASS(mp_comm_type), INTENT(IN) :: comm
10903
10904 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l3_src'
10905
10906 INTEGER :: handle
10907#if defined(__parallel)
10908 INTEGER :: ierr, msglen
10909#endif
10910
10911 CALL mp_timeset(routinen, handle)
10912
10913#if defined(__parallel)
10914 msglen = SIZE(msg)
10915 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10916 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10917 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10918#else
10919 mark_used(msg)
10920 mark_used(comm)
10921#endif
10922 CALL mp_timestop(handle)
10923 END SUBROUTINE mp_bcast_l3_src
10924
10925! **************************************************************************************************
10926!> \brief Sums a datum from all processes with result left on all processes.
10927!> \param[in,out] msg Datum to sum (input) and result (output)
10928!> \param[in] comm Message passing environment identifier
10929!> \par MPI mapping
10930!> mpi_allreduce
10931! **************************************************************************************************
10932 SUBROUTINE mp_sum_l (msg, comm)
10933 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10934 CLASS(mp_comm_type), INTENT(IN) :: comm
10935
10936 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_l'
10937
10938 INTEGER :: handle
10939#if defined(__parallel)
10940 INTEGER :: ierr, msglen
10941#endif
10942
10943 CALL mp_timeset(routinen, handle)
10944
10945#if defined(__parallel)
10946 msglen = 1
10947 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10948 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10949 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10950#else
10951 mark_used(msg)
10952 mark_used(comm)
10953#endif
10954 CALL mp_timestop(handle)
10955 END SUBROUTINE mp_sum_l
10956
10957! **************************************************************************************************
10958!> \brief Element-wise sum of a rank-1 array on all processes.
10959!> \param[in,out] msg Vector to sum and result
10960!> \param comm ...
10961!> \note see mp_sum_l
10962! **************************************************************************************************
10963 SUBROUTINE mp_sum_lv(msg, comm)
10964 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10965 CLASS(mp_comm_type), INTENT(IN) :: comm
10966
10967 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lv'
10968
10969 INTEGER :: handle
10970#if defined(__parallel)
10971 INTEGER :: ierr, msglen
10972#endif
10973
10974 CALL mp_timeset(routinen, handle)
10975
10976#if defined(__parallel)
10977 msglen = SIZE(msg)
10978 IF (msglen > 0) THEN
10979 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10980 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10981 END IF
10982 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10983#else
10984 mark_used(msg)
10985 mark_used(comm)
10986#endif
10987 CALL mp_timestop(handle)
10988 END SUBROUTINE mp_sum_lv
10989
10990! **************************************************************************************************
10991!> \brief Element-wise sum of a rank-1 array on all processes.
10992!> \param[in,out] msg Vector to sum and result
10993!> \param comm ...
10994!> \note see mp_sum_l
10995! **************************************************************************************************
10996 SUBROUTINE mp_isum_lv(msg, comm, request)
10997 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
10998 CLASS(mp_comm_type), INTENT(IN) :: comm
10999 TYPE(mp_request_type), INTENT(OUT) :: request
11000
11001 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_lv'
11002
11003 INTEGER :: handle
11004#if defined(__parallel)
11005 INTEGER :: ierr, msglen
11006#endif
11007
11008 CALL mp_timeset(routinen, handle)
11009
11010#if defined(__parallel)
11011#if !defined(__GNUC__) || __GNUC__ >= 9
11012 cpassert(is_contiguous(msg))
11013#endif
11014 msglen = SIZE(msg)
11015 IF (msglen > 0) THEN
11016 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, request%handle, ierr)
11017 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
11018 ELSE
11019 request = mp_request_null
11020 END IF
11021 CALL add_perf(perf_id=23, count=1, msg_size=msglen*int_8_size)
11022#else
11023 mark_used(msg)
11024 mark_used(comm)
11025 request = mp_request_null
11026#endif
11027 CALL mp_timestop(handle)
11028 END SUBROUTINE mp_isum_lv
11029
11030! **************************************************************************************************
11031!> \brief Element-wise sum of a rank-2 array on all processes.
11032!> \param[in] msg Matrix to sum and result
11033!> \param comm ...
11034!> \note see mp_sum_l
11035! **************************************************************************************************
11036 SUBROUTINE mp_sum_lm(msg, comm)
11037 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11038 CLASS(mp_comm_type), INTENT(IN) :: comm
11039
11040 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm'
11041
11042 INTEGER :: handle
11043#if defined(__parallel)
11044 INTEGER, PARAMETER :: max_msg = 2**25
11045 INTEGER :: ierr, m1, msglen, step, msglensum
11046#endif
11047
11048 CALL mp_timeset(routinen, handle)
11049
11050#if defined(__parallel)
11051 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
11052 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
11053 msglensum = 0
11054 DO m1 = lbound(msg, 2), ubound(msg, 2), step
11055 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
11056 msglensum = msglensum + msglen
11057 IF (msglen > 0) THEN
11058 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11059 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11060 END IF
11061 END DO
11062 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_8_size)
11063#else
11064 mark_used(msg)
11065 mark_used(comm)
11066#endif
11067 CALL mp_timestop(handle)
11068 END SUBROUTINE mp_sum_lm
11069
11070! **************************************************************************************************
11071!> \brief Element-wise sum of a rank-3 array on all processes.
11072!> \param[in] msg Array to sum and result
11073!> \param comm ...
11074!> \note see mp_sum_l
11075! **************************************************************************************************
11076 SUBROUTINE mp_sum_lm3(msg, comm)
11077 INTEGER(KIND=int_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
11078 CLASS(mp_comm_type), INTENT(IN) :: comm
11079
11080 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm3'
11081
11082 INTEGER :: handle
11083#if defined(__parallel)
11084 INTEGER :: ierr, msglen
11085#endif
11086
11087 CALL mp_timeset(routinen, handle)
11088
11089#if defined(__parallel)
11090 msglen = SIZE(msg)
11091 IF (msglen > 0) THEN
11092 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11093 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11094 END IF
11095 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11096#else
11097 mark_used(msg)
11098 mark_used(comm)
11099#endif
11100 CALL mp_timestop(handle)
11101 END SUBROUTINE mp_sum_lm3
11102
11103! **************************************************************************************************
11104!> \brief Element-wise sum of a rank-4 array on all processes.
11105!> \param[in] msg Array to sum and result
11106!> \param comm ...
11107!> \note see mp_sum_l
11108! **************************************************************************************************
11109 SUBROUTINE mp_sum_lm4(msg, comm)
11110 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
11111 CLASS(mp_comm_type), INTENT(IN) :: comm
11112
11113 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm4'
11114
11115 INTEGER :: handle
11116#if defined(__parallel)
11117 INTEGER :: ierr, msglen
11118#endif
11119
11120 CALL mp_timeset(routinen, handle)
11121
11122#if defined(__parallel)
11123 msglen = SIZE(msg)
11124 IF (msglen > 0) THEN
11125 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11126 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11127 END IF
11128 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11129#else
11130 mark_used(msg)
11131 mark_used(comm)
11132#endif
11133 CALL mp_timestop(handle)
11134 END SUBROUTINE mp_sum_lm4
11135
11136! **************************************************************************************************
11137!> \brief Element-wise sum of data from all processes with result left only on
11138!> one.
11139!> \param[in,out] msg Vector to sum (input) and (only on process root)
11140!> result (output)
11141!> \param root ...
11142!> \param[in] comm Message passing environment identifier
11143!> \par MPI mapping
11144!> mpi_reduce
11145! **************************************************************************************************
11146 SUBROUTINE mp_sum_root_lv(msg, root, comm)
11147 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
11148 INTEGER, INTENT(IN) :: root
11149 CLASS(mp_comm_type), INTENT(IN) :: comm
11150
11151 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_lv'
11152
11153 INTEGER :: handle
11154#if defined(__parallel)
11155 INTEGER :: ierr, m1, msglen, taskid
11156 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
11157#endif
11158
11159 CALL mp_timeset(routinen, handle)
11160
11161#if defined(__parallel)
11162 msglen = SIZE(msg)
11163 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11164 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11165 IF (msglen > 0) THEN
11166 m1 = SIZE(msg, 1)
11167 ALLOCATE (res(m1))
11168 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_sum, &
11169 root, comm%handle, ierr)
11170 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11171 IF (taskid == root) THEN
11172 msg = res
11173 END IF
11174 DEALLOCATE (res)
11175 END IF
11176 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11177#else
11178 mark_used(msg)
11179 mark_used(root)
11180 mark_used(comm)
11181#endif
11182 CALL mp_timestop(handle)
11183 END SUBROUTINE mp_sum_root_lv
11184
11185! **************************************************************************************************
11186!> \brief Element-wise sum of data from all processes with result left only on
11187!> one.
11188!> \param[in,out] msg Matrix to sum (input) and (only on process root)
11189!> result (output)
11190!> \param root ...
11191!> \param comm ...
11192!> \note see mp_sum_root_lv
11193! **************************************************************************************************
11194 SUBROUTINE mp_sum_root_lm(msg, root, comm)
11195 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11196 INTEGER, INTENT(IN) :: root
11197 CLASS(mp_comm_type), INTENT(IN) :: comm
11198
11199 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
11200
11201 INTEGER :: handle
11202#if defined(__parallel)
11203 INTEGER :: ierr, m1, m2, msglen, taskid
11204 INTEGER(KIND=int_8), ALLOCATABLE :: res(:, :)
11205#endif
11206
11207 CALL mp_timeset(routinen, handle)
11208
11209#if defined(__parallel)
11210 msglen = SIZE(msg)
11211 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11212 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11213 IF (msglen > 0) THEN
11214 m1 = SIZE(msg, 1)
11215 m2 = SIZE(msg, 2)
11216 ALLOCATE (res(m1, m2))
11217 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_sum, root, comm%handle, ierr)
11218 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11219 IF (taskid == root) THEN
11220 msg = res
11221 END IF
11222 DEALLOCATE (res)
11223 END IF
11224 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11225#else
11226 mark_used(root)
11227 mark_used(msg)
11228 mark_used(comm)
11229#endif
11230 CALL mp_timestop(handle)
11231 END SUBROUTINE mp_sum_root_lm
11232
11233! **************************************************************************************************
11234!> \brief Partial sum of data from all processes with result on each process.
11235!> \param[in] msg Matrix to sum (input)
11236!> \param[out] res Matrix containing result (output)
11237!> \param[in] comm Message passing environment identifier
11238! **************************************************************************************************
11239 SUBROUTINE mp_sum_partial_lm(msg, res, comm)
11240 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11241 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
11242 CLASS(mp_comm_type), INTENT(IN) :: comm
11243
11244 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_lm'
11245
11246 INTEGER :: handle
11247#if defined(__parallel)
11248 INTEGER :: ierr, msglen, taskid
11249#endif
11250
11251 CALL mp_timeset(routinen, handle)
11252
11253#if defined(__parallel)
11254 msglen = SIZE(msg)
11255 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11256 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11257 IF (msglen > 0) THEN
11258 CALL mpi_scan(msg, res, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11259 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
11260 END IF
11261 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11262 ! perf_id is same as for other summation routines
11263#else
11264 res = msg
11265 mark_used(comm)
11266#endif
11267 CALL mp_timestop(handle)
11268 END SUBROUTINE mp_sum_partial_lm
11269
11270! **************************************************************************************************
11271!> \brief Finds the maximum of a datum with the result left on all processes.
11272!> \param[in,out] msg Find maximum among these data (input) and
11273!> maximum (output)
11274!> \param[in] comm Message passing environment identifier
11275!> \par MPI mapping
11276!> mpi_allreduce
11277! **************************************************************************************************
11278 SUBROUTINE mp_max_l (msg, comm)
11279 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11280 CLASS(mp_comm_type), INTENT(IN) :: comm
11281
11282 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_l'
11283
11284 INTEGER :: handle
11285#if defined(__parallel)
11286 INTEGER :: ierr, msglen
11287#endif
11288
11289 CALL mp_timeset(routinen, handle)
11290
11291#if defined(__parallel)
11292 msglen = 1
11293 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11294 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11295 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11296#else
11297 mark_used(msg)
11298 mark_used(comm)
11299#endif
11300 CALL mp_timestop(handle)
11301 END SUBROUTINE mp_max_l
11302
11303! **************************************************************************************************
11304!> \brief Finds the maximum of a datum with the result left on all processes.
11305!> \param[in,out] msg Find maximum among these data (input) and
11306!> maximum (output)
11307!> \param[in] comm Message passing environment identifier
11308!> \par MPI mapping
11309!> mpi_allreduce
11310! **************************************************************************************************
11311 SUBROUTINE mp_max_root_l (msg, root, comm)
11312 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11313 INTEGER, INTENT(IN) :: root
11314 CLASS(mp_comm_type), INTENT(IN) :: comm
11315
11316 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_l'
11317
11318 INTEGER :: handle
11319#if defined(__parallel)
11320 INTEGER :: ierr, msglen
11321 INTEGER(KIND=int_8) :: res
11322#endif
11323
11324 CALL mp_timeset(routinen, handle)
11325
11326#if defined(__parallel)
11327 msglen = 1
11328 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_max, root, comm%handle, ierr)
11329 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11330 IF (root == comm%mepos) msg = res
11331 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11332#else
11333 mark_used(msg)
11334 mark_used(comm)
11335 mark_used(root)
11336#endif
11337 CALL mp_timestop(handle)
11338 END SUBROUTINE mp_max_root_l
11339
11340! **************************************************************************************************
11341!> \brief Finds the element-wise maximum of a vector with the result left on
11342!> all processes.
11343!> \param[in,out] msg Find maximum among these data (input) and
11344!> maximum (output)
11345!> \param comm ...
11346!> \note see mp_max_l
11347! **************************************************************************************************
11348 SUBROUTINE mp_max_lv(msg, comm)
11349 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
11350 CLASS(mp_comm_type), INTENT(IN) :: comm
11351
11352 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_lv'
11353
11354 INTEGER :: handle
11355#if defined(__parallel)
11356 INTEGER :: ierr, msglen
11357#endif
11358
11359 CALL mp_timeset(routinen, handle)
11360
11361#if defined(__parallel)
11362 msglen = SIZE(msg)
11363 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11364 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11365 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11366#else
11367 mark_used(msg)
11368 mark_used(comm)
11369#endif
11370 CALL mp_timestop(handle)
11371 END SUBROUTINE mp_max_lv
11372
11373! **************************************************************************************************
11374!> \brief Finds the element-wise maximum of a vector with the result left on
11375!> all processes.
11376!> \param[in,out] msg Find maximum among these data (input) and
11377!> maximum (output)
11378!> \param comm ...
11379!> \note see mp_max_l
11380! **************************************************************************************************
11381 SUBROUTINE mp_max_root_lm(msg, root, comm)
11382 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11383 INTEGER :: root
11384 CLASS(mp_comm_type), INTENT(IN) :: comm
11385
11386 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_lm'
11387
11388 INTEGER :: handle
11389#if defined(__parallel)
11390 INTEGER :: ierr, msglen
11391 INTEGER(KIND=int_8) :: res(size(msg, 1), size(msg, 2))
11392#endif
11393
11394 CALL mp_timeset(routinen, handle)
11395
11396#if defined(__parallel)
11397 msglen = SIZE(msg)
11398 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_max, root, comm%handle, ierr)
11399 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11400 IF (root == comm%mepos) msg = res
11401 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11402#else
11403 mark_used(msg)
11404 mark_used(comm)
11405 mark_used(root)
11406#endif
11407 CALL mp_timestop(handle)
11408 END SUBROUTINE mp_max_root_lm
11409
11410! **************************************************************************************************
11411!> \brief Finds the minimum of a datum with the result left on all processes.
11412!> \param[in,out] msg Find minimum among these data (input) and
11413!> maximum (output)
11414!> \param[in] comm Message passing environment identifier
11415!> \par MPI mapping
11416!> mpi_allreduce
11417! **************************************************************************************************
11418 SUBROUTINE mp_min_l (msg, comm)
11419 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11420 CLASS(mp_comm_type), INTENT(IN) :: comm
11421
11422 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_l'
11423
11424 INTEGER :: handle
11425#if defined(__parallel)
11426 INTEGER :: ierr, msglen
11427#endif
11428
11429 CALL mp_timeset(routinen, handle)
11430
11431#if defined(__parallel)
11432 msglen = 1
11433 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11434 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11435 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11436#else
11437 mark_used(msg)
11438 mark_used(comm)
11439#endif
11440 CALL mp_timestop(handle)
11441 END SUBROUTINE mp_min_l
11442
11443! **************************************************************************************************
11444!> \brief Finds the element-wise minimum of vector with the result left on
11445!> all processes.
11446!> \param[in,out] msg Find minimum among these data (input) and
11447!> maximum (output)
11448!> \param comm ...
11449!> \par MPI mapping
11450!> mpi_allreduce
11451!> \note see mp_min_l
11452! **************************************************************************************************
11453 SUBROUTINE mp_min_lv(msg, comm)
11454 INTEGER(KIND=int_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
11455 CLASS(mp_comm_type), INTENT(IN) :: comm
11456
11457 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_lv'
11458
11459 INTEGER :: handle
11460#if defined(__parallel)
11461 INTEGER :: ierr, msglen
11462#endif
11463
11464 CALL mp_timeset(routinen, handle)
11465
11466#if defined(__parallel)
11467 msglen = SIZE(msg)
11468 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11469 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11470 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11471#else
11472 mark_used(msg)
11473 mark_used(comm)
11474#endif
11475 CALL mp_timestop(handle)
11476 END SUBROUTINE mp_min_lv
11477
11478! **************************************************************************************************
11479!> \brief Multiplies a set of numbers scattered across a number of processes,
11480!> then replicates the result.
11481!> \param[in,out] msg a number to multiply (input) and result (output)
11482!> \param[in] comm message passing environment identifier
11483!> \par MPI mapping
11484!> mpi_allreduce
11485! **************************************************************************************************
11486 SUBROUTINE mp_prod_l (msg, comm)
11487 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11488 CLASS(mp_comm_type), INTENT(IN) :: comm
11489
11490 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_l'
11491
11492 INTEGER :: handle
11493#if defined(__parallel)
11494 INTEGER :: ierr, msglen
11495#endif
11496
11497 CALL mp_timeset(routinen, handle)
11498
11499#if defined(__parallel)
11500 msglen = 1
11501 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_prod, comm%handle, ierr)
11502 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11503 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11504#else
11505 mark_used(msg)
11506 mark_used(comm)
11507#endif
11508 CALL mp_timestop(handle)
11509 END SUBROUTINE mp_prod_l
11510
11511! **************************************************************************************************
11512!> \brief Scatters data from one processes to all others
11513!> \param[in] msg_scatter Data to scatter (for root process)
11514!> \param[out] msg Received data
11515!> \param[in] root Process which scatters data
11516!> \param[in] comm Message passing environment identifier
11517!> \par MPI mapping
11518!> mpi_scatter
11519! **************************************************************************************************
11520 SUBROUTINE mp_scatter_lv(msg_scatter, msg, root, comm)
11521 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
11522 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
11523 INTEGER, INTENT(IN) :: root
11524 CLASS(mp_comm_type), INTENT(IN) :: comm
11525
11526 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_lv'
11527
11528 INTEGER :: handle
11529#if defined(__parallel)
11530 INTEGER :: ierr, msglen
11531#endif
11532
11533 CALL mp_timeset(routinen, handle)
11534
11535#if defined(__parallel)
11536 msglen = SIZE(msg)
11537 CALL mpi_scatter(msg_scatter, msglen, mpi_integer8, msg, &
11538 msglen, mpi_integer8, root, comm%handle, ierr)
11539 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
11540 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11541#else
11542 mark_used(root)
11543 mark_used(comm)
11544 msg = msg_scatter
11545#endif
11546 CALL mp_timestop(handle)
11547 END SUBROUTINE mp_scatter_lv
11548
11549! **************************************************************************************************
11550!> \brief Scatters data from one processes to all others
11551!> \param[in] msg_scatter Data to scatter (for root process)
11552!> \param[in] root Process which scatters data
11553!> \param[in] comm Message passing environment identifier
11554!> \par MPI mapping
11555!> mpi_scatter
11556! **************************************************************************************************
11557 SUBROUTINE mp_iscatter_l (msg_scatter, msg, root, comm, request)
11558 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:)
11559 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11560 INTEGER, INTENT(IN) :: root
11561 CLASS(mp_comm_type), INTENT(IN) :: comm
11562 TYPE(mp_request_type), INTENT(OUT) :: request
11563
11564 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_l'
11565
11566 INTEGER :: handle
11567#if defined(__parallel)
11568 INTEGER :: ierr, msglen
11569#endif
11570
11571 CALL mp_timeset(routinen, handle)
11572
11573#if defined(__parallel)
11574#if !defined(__GNUC__) || __GNUC__ >= 9
11575 cpassert(is_contiguous(msg_scatter))
11576#endif
11577 msglen = 1
11578 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer8, msg, &
11579 msglen, mpi_integer8, root, comm%handle, request%handle, ierr)
11580 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
11581 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11582#else
11583 mark_used(root)
11584 mark_used(comm)
11585 msg = msg_scatter(1)
11586 request = mp_request_null
11587#endif
11588 CALL mp_timestop(handle)
11589 END SUBROUTINE mp_iscatter_l
11590
11591! **************************************************************************************************
11592!> \brief Scatters data from one processes to all others
11593!> \param[in] msg_scatter Data to scatter (for root process)
11594!> \param[in] root Process which scatters data
11595!> \param[in] comm Message passing environment identifier
11596!> \par MPI mapping
11597!> mpi_scatter
11598! **************************************************************************************************
11599 SUBROUTINE mp_iscatter_lv2(msg_scatter, msg, root, comm, request)
11600 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:, :)
11601 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11602 INTEGER, INTENT(IN) :: root
11603 CLASS(mp_comm_type), INTENT(IN) :: comm
11604 TYPE(mp_request_type), INTENT(OUT) :: request
11605
11606 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_lv2'
11607
11608 INTEGER :: handle
11609#if defined(__parallel)
11610 INTEGER :: ierr, msglen
11611#endif
11612
11613 CALL mp_timeset(routinen, handle)
11614
11615#if defined(__parallel)
11616#if !defined(__GNUC__) || __GNUC__ >= 9
11617 cpassert(is_contiguous(msg_scatter))
11618#endif
11619 msglen = SIZE(msg)
11620 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer8, msg, &
11621 msglen, mpi_integer8, root, comm%handle, request%handle, ierr)
11622 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
11623 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11624#else
11625 mark_used(root)
11626 mark_used(comm)
11627 msg(:) = msg_scatter(:, 1)
11628 request = mp_request_null
11629#endif
11630 CALL mp_timestop(handle)
11631 END SUBROUTINE mp_iscatter_lv2
11632
11633! **************************************************************************************************
11634!> \brief Scatters data from one processes to all others
11635!> \param[in] msg_scatter Data to scatter (for root process)
11636!> \param[in] root Process which scatters data
11637!> \param[in] comm Message passing environment identifier
11638!> \par MPI mapping
11639!> mpi_scatter
11640! **************************************************************************************************
11641 SUBROUTINE mp_iscatterv_lv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
11642 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:)
11643 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
11644 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11645 INTEGER, INTENT(IN) :: recvcount, root
11646 CLASS(mp_comm_type), INTENT(IN) :: comm
11647 TYPE(mp_request_type), INTENT(OUT) :: request
11648
11649 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_lv'
11650
11651 INTEGER :: handle
11652#if defined(__parallel)
11653 INTEGER :: ierr
11654#endif
11655
11656 CALL mp_timeset(routinen, handle)
11657
11658#if defined(__parallel)
11659#if !defined(__GNUC__) || __GNUC__ >= 9
11660 cpassert(is_contiguous(msg_scatter))
11661 cpassert(is_contiguous(msg))
11662 cpassert(is_contiguous(sendcounts))
11663 cpassert(is_contiguous(displs))
11664#endif
11665 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_integer8, msg, &
11666 recvcount, mpi_integer8, root, comm%handle, request%handle, ierr)
11667 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
11668 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11669#else
11670 mark_used(sendcounts)
11671 mark_used(displs)
11672 mark_used(recvcount)
11673 mark_used(root)
11674 mark_used(comm)
11675 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
11676 request = mp_request_null
11677#endif
11678 CALL mp_timestop(handle)
11679 END SUBROUTINE mp_iscatterv_lv
11680
11681! **************************************************************************************************
11682!> \brief Gathers a datum from all processes to one
11683!> \param[in] msg Datum to send to root
11684!> \param[out] msg_gather Received data (on root)
11685!> \param[in] root Process which gathers the data
11686!> \param[in] comm Message passing environment identifier
11687!> \par MPI mapping
11688!> mpi_gather
11689! **************************************************************************************************
11690 SUBROUTINE mp_gather_l (msg, msg_gather, root, comm)
11691 INTEGER(KIND=int_8), INTENT(IN) :: msg
11692 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11693 INTEGER, INTENT(IN) :: root
11694 CLASS(mp_comm_type), INTENT(IN) :: comm
11695
11696 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_l'
11697
11698 INTEGER :: handle
11699#if defined(__parallel)
11700 INTEGER :: ierr, msglen
11701#endif
11702
11703 CALL mp_timeset(routinen, handle)
11704
11705#if defined(__parallel)
11706 msglen = 1
11707 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11708 msglen, mpi_integer8, root, comm%handle, ierr)
11709 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11710 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11711#else
11712 mark_used(root)
11713 mark_used(comm)
11714 msg_gather(1) = msg
11715#endif
11716 CALL mp_timestop(handle)
11717 END SUBROUTINE mp_gather_l
11718
11719! **************************************************************************************************
11720!> \brief Gathers a datum from all processes to one, uses the source process of comm
11721!> \param[in] msg Datum to send to root
11722!> \param[out] msg_gather Received data (on root)
11723!> \param[in] comm Message passing environment identifier
11724!> \par MPI mapping
11725!> mpi_gather
11726! **************************************************************************************************
11727 SUBROUTINE mp_gather_l_src(msg, msg_gather, comm)
11728 INTEGER(KIND=int_8), INTENT(IN) :: msg
11729 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11730 CLASS(mp_comm_type), INTENT(IN) :: comm
11731
11732 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_l_src'
11733
11734 INTEGER :: handle
11735#if defined(__parallel)
11736 INTEGER :: ierr, msglen
11737#endif
11738
11739 CALL mp_timeset(routinen, handle)
11740
11741#if defined(__parallel)
11742 msglen = 1
11743 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11744 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11745 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11746 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11747#else
11748 mark_used(comm)
11749 msg_gather(1) = msg
11750#endif
11751 CALL mp_timestop(handle)
11752 END SUBROUTINE mp_gather_l_src
11753
11754! **************************************************************************************************
11755!> \brief Gathers data from all processes to one
11756!> \param[in] msg Datum to send to root
11757!> \param msg_gather ...
11758!> \param root ...
11759!> \param comm ...
11760!> \par Data length
11761!> All data (msg) is equal-sized
11762!> \par MPI mapping
11763!> mpi_gather
11764!> \note see mp_gather_l
11765! **************************************************************************************************
11766 SUBROUTINE mp_gather_lv(msg, msg_gather, root, comm)
11767 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
11768 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11769 INTEGER, INTENT(IN) :: root
11770 CLASS(mp_comm_type), INTENT(IN) :: comm
11771
11772 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lv'
11773
11774 INTEGER :: handle
11775#if defined(__parallel)
11776 INTEGER :: ierr, msglen
11777#endif
11778
11779 CALL mp_timeset(routinen, handle)
11780
11781#if defined(__parallel)
11782 msglen = SIZE(msg)
11783 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11784 msglen, mpi_integer8, root, comm%handle, ierr)
11785 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11786 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11787#else
11788 mark_used(root)
11789 mark_used(comm)
11790 msg_gather = msg
11791#endif
11792 CALL mp_timestop(handle)
11793 END SUBROUTINE mp_gather_lv
11794
11795! **************************************************************************************************
11796!> \brief Gathers data from all processes to one. Gathers from comm%source
11797!> \param[in] msg Datum to send to root
11798!> \param msg_gather ...
11799!> \param comm ...
11800!> \par Data length
11801!> All data (msg) is equal-sized
11802!> \par MPI mapping
11803!> mpi_gather
11804!> \note see mp_gather_l
11805! **************************************************************************************************
11806 SUBROUTINE mp_gather_lv_src(msg, msg_gather, comm)
11807 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
11808 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11809 CLASS(mp_comm_type), INTENT(IN) :: comm
11810
11811 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lv_src'
11812
11813 INTEGER :: handle
11814#if defined(__parallel)
11815 INTEGER :: ierr, msglen
11816#endif
11817
11818 CALL mp_timeset(routinen, handle)
11819
11820#if defined(__parallel)
11821 msglen = SIZE(msg)
11822 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11823 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11824 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11825 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11826#else
11827 mark_used(comm)
11828 msg_gather = msg
11829#endif
11830 CALL mp_timestop(handle)
11831 END SUBROUTINE mp_gather_lv_src
11832
11833! **************************************************************************************************
11834!> \brief Gathers data from all processes to one
11835!> \param[in] msg Datum to send to root
11836!> \param msg_gather ...
11837!> \param root ...
11838!> \param comm ...
11839!> \par Data length
11840!> All data (msg) is equal-sized
11841!> \par MPI mapping
11842!> mpi_gather
11843!> \note see mp_gather_l
11844! **************************************************************************************************
11845 SUBROUTINE mp_gather_lm(msg, msg_gather, root, comm)
11846 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11847 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
11848 INTEGER, INTENT(IN) :: root
11849 CLASS(mp_comm_type), INTENT(IN) :: comm
11850
11851 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lm'
11852
11853 INTEGER :: handle
11854#if defined(__parallel)
11855 INTEGER :: ierr, msglen
11856#endif
11857
11858 CALL mp_timeset(routinen, handle)
11859
11860#if defined(__parallel)
11861 msglen = SIZE(msg)
11862 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11863 msglen, mpi_integer8, root, comm%handle, ierr)
11864 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11865 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11866#else
11867 mark_used(root)
11868 mark_used(comm)
11869 msg_gather = msg
11870#endif
11871 CALL mp_timestop(handle)
11872 END SUBROUTINE mp_gather_lm
11873
11874! **************************************************************************************************
11875!> \brief Gathers data from all processes to one. Gathers from comm%source
11876!> \param[in] msg Datum to send to root
11877!> \param msg_gather ...
11878!> \param comm ...
11879!> \par Data length
11880!> All data (msg) is equal-sized
11881!> \par MPI mapping
11882!> mpi_gather
11883!> \note see mp_gather_l
11884! **************************************************************************************************
11885 SUBROUTINE mp_gather_lm_src(msg, msg_gather, comm)
11886 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11887 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
11888 CLASS(mp_comm_type), INTENT(IN) :: comm
11889
11890 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lm_src'
11891
11892 INTEGER :: handle
11893#if defined(__parallel)
11894 INTEGER :: ierr, msglen
11895#endif
11896
11897 CALL mp_timeset(routinen, handle)
11898
11899#if defined(__parallel)
11900 msglen = SIZE(msg)
11901 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11902 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11903 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11904 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11905#else
11906 mark_used(comm)
11907 msg_gather = msg
11908#endif
11909 CALL mp_timestop(handle)
11910 END SUBROUTINE mp_gather_lm_src
11911
11912! **************************************************************************************************
11913!> \brief Gathers data from all processes to one.
11914!> \param[in] sendbuf Data to send to root
11915!> \param[out] recvbuf Received data (on root)
11916!> \param[in] recvcounts Sizes of data received from processes
11917!> \param[in] displs Offsets of data received from processes
11918!> \param[in] root Process which gathers the data
11919!> \param[in] comm Message passing environment identifier
11920!> \par Data length
11921!> Data can have different lengths
11922!> \par Offsets
11923!> Offsets start at 0
11924!> \par MPI mapping
11925!> mpi_gather
11926! **************************************************************************************************
11927 SUBROUTINE mp_gatherv_lv(sendbuf, recvbuf, recvcounts, displs, root, comm)
11928
11929 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
11930 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
11931 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
11932 INTEGER, INTENT(IN) :: root
11933 CLASS(mp_comm_type), INTENT(IN) :: comm
11934
11935 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lv'
11936
11937 INTEGER :: handle
11938#if defined(__parallel)
11939 INTEGER :: ierr, sendcount
11940#endif
11941
11942 CALL mp_timeset(routinen, handle)
11943
11944#if defined(__parallel)
11945 sendcount = SIZE(sendbuf)
11946 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
11947 recvbuf, recvcounts, displs, mpi_integer8, &
11948 root, comm%handle, ierr)
11949 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
11950 CALL add_perf(perf_id=4, &
11951 count=1, &
11952 msg_size=sendcount*int_8_size)
11953#else
11954 mark_used(recvcounts)
11955 mark_used(root)
11956 mark_used(comm)
11957 recvbuf(1 + displs(1):) = sendbuf
11958#endif
11959 CALL mp_timestop(handle)
11960 END SUBROUTINE mp_gatherv_lv
11961
11962! **************************************************************************************************
11963!> \brief Gathers data from all processes to one. Gathers from comm%source
11964!> \param[in] sendbuf Data to send to root
11965!> \param[out] recvbuf Received data (on root)
11966!> \param[in] recvcounts Sizes of data received from processes
11967!> \param[in] displs Offsets of data received from processes
11968!> \param[in] comm Message passing environment identifier
11969!> \par Data length
11970!> Data can have different lengths
11971!> \par Offsets
11972!> Offsets start at 0
11973!> \par MPI mapping
11974!> mpi_gather
11975! **************************************************************************************************
11976 SUBROUTINE mp_gatherv_lv_src(sendbuf, recvbuf, recvcounts, displs, comm)
11977
11978 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
11979 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
11980 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
11981 CLASS(mp_comm_type), INTENT(IN) :: comm
11982
11983 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lv_src'
11984
11985 INTEGER :: handle
11986#if defined(__parallel)
11987 INTEGER :: ierr, sendcount
11988#endif
11989
11990 CALL mp_timeset(routinen, handle)
11991
11992#if defined(__parallel)
11993 sendcount = SIZE(sendbuf)
11994 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
11995 recvbuf, recvcounts, displs, mpi_integer8, &
11996 comm%source, comm%handle, ierr)
11997 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
11998 CALL add_perf(perf_id=4, &
11999 count=1, &
12000 msg_size=sendcount*int_8_size)
12001#else
12002 mark_used(recvcounts)
12003 mark_used(comm)
12004 recvbuf(1 + displs(1):) = sendbuf
12005#endif
12006 CALL mp_timestop(handle)
12007 END SUBROUTINE mp_gatherv_lv_src
12008
12009! **************************************************************************************************
12010!> \brief Gathers data from all processes to one.
12011!> \param[in] sendbuf Data to send to root
12012!> \param[out] recvbuf Received data (on root)
12013!> \param[in] recvcounts Sizes of data received from processes
12014!> \param[in] displs Offsets of data received from processes
12015!> \param[in] root Process which gathers the data
12016!> \param[in] comm Message passing environment identifier
12017!> \par Data length
12018!> Data can have different lengths
12019!> \par Offsets
12020!> Offsets start at 0
12021!> \par MPI mapping
12022!> mpi_gather
12023! **************************************************************************************************
12024 SUBROUTINE mp_gatherv_lm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
12025
12026 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
12027 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
12028 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12029 INTEGER, INTENT(IN) :: root
12030 CLASS(mp_comm_type), INTENT(IN) :: comm
12031
12032 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lm2'
12033
12034 INTEGER :: handle
12035#if defined(__parallel)
12036 INTEGER :: ierr, sendcount
12037#endif
12038
12039 CALL mp_timeset(routinen, handle)
12040
12041#if defined(__parallel)
12042 sendcount = SIZE(sendbuf)
12043 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12044 recvbuf, recvcounts, displs, mpi_integer8, &
12045 root, comm%handle, ierr)
12046 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12047 CALL add_perf(perf_id=4, &
12048 count=1, &
12049 msg_size=sendcount*int_8_size)
12050#else
12051 mark_used(recvcounts)
12052 mark_used(root)
12053 mark_used(comm)
12054 recvbuf(:, 1 + displs(1):) = sendbuf
12055#endif
12056 CALL mp_timestop(handle)
12057 END SUBROUTINE mp_gatherv_lm2
12058
12059! **************************************************************************************************
12060!> \brief Gathers data from all processes to one.
12061!> \param[in] sendbuf Data to send to root
12062!> \param[out] recvbuf Received data (on root)
12063!> \param[in] recvcounts Sizes of data received from processes
12064!> \param[in] displs Offsets of data received from processes
12065!> \param[in] comm Message passing environment identifier
12066!> \par Data length
12067!> Data can have different lengths
12068!> \par Offsets
12069!> Offsets start at 0
12070!> \par MPI mapping
12071!> mpi_gather
12072! **************************************************************************************************
12073 SUBROUTINE mp_gatherv_lm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
12074
12075 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
12076 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
12077 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12078 CLASS(mp_comm_type), INTENT(IN) :: comm
12079
12080 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lm2_src'
12081
12082 INTEGER :: handle
12083#if defined(__parallel)
12084 INTEGER :: ierr, sendcount
12085#endif
12086
12087 CALL mp_timeset(routinen, handle)
12088
12089#if defined(__parallel)
12090 sendcount = SIZE(sendbuf)
12091 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12092 recvbuf, recvcounts, displs, mpi_integer8, &
12093 comm%source, comm%handle, ierr)
12094 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12095 CALL add_perf(perf_id=4, &
12096 count=1, &
12097 msg_size=sendcount*int_8_size)
12098#else
12099 mark_used(recvcounts)
12100 mark_used(comm)
12101 recvbuf(:, 1 + displs(1):) = sendbuf
12102#endif
12103 CALL mp_timestop(handle)
12104 END SUBROUTINE mp_gatherv_lm2_src
12105
12106! **************************************************************************************************
12107!> \brief Gathers data from all processes to one.
12108!> \param[in] sendbuf Data to send to root
12109!> \param[out] recvbuf Received data (on root)
12110!> \param[in] recvcounts Sizes of data received from processes
12111!> \param[in] displs Offsets of data received from processes
12112!> \param[in] root Process which gathers the data
12113!> \param[in] comm Message passing environment identifier
12114!> \par Data length
12115!> Data can have different lengths
12116!> \par Offsets
12117!> Offsets start at 0
12118!> \par MPI mapping
12119!> mpi_gather
12120! **************************************************************************************************
12121 SUBROUTINE mp_igatherv_lv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
12122 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: sendbuf
12123 INTEGER(KIND=int_8), DIMENSION(:), INTENT(OUT) :: recvbuf
12124 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12125 INTEGER, INTENT(IN) :: sendcount, root
12126 CLASS(mp_comm_type), INTENT(IN) :: comm
12127 TYPE(mp_request_type), INTENT(OUT) :: request
12128
12129 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_lv'
12130
12131 INTEGER :: handle
12132#if defined(__parallel)
12133 INTEGER :: ierr
12134#endif
12135
12136 CALL mp_timeset(routinen, handle)
12137
12138#if defined(__parallel)
12139#if !defined(__GNUC__) || __GNUC__ >= 9
12140 cpassert(is_contiguous(sendbuf))
12141 cpassert(is_contiguous(recvbuf))
12142 cpassert(is_contiguous(recvcounts))
12143 cpassert(is_contiguous(displs))
12144#endif
12145 CALL mpi_igatherv(sendbuf, sendcount, mpi_integer8, &
12146 recvbuf, recvcounts, displs, mpi_integer8, &
12147 root, comm%handle, request%handle, ierr)
12148 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12149 CALL add_perf(perf_id=24, &
12150 count=1, &
12151 msg_size=sendcount*int_8_size)
12152#else
12153 mark_used(sendcount)
12154 mark_used(recvcounts)
12155 mark_used(root)
12156 mark_used(comm)
12157 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
12158 request = mp_request_null
12159#endif
12160 CALL mp_timestop(handle)
12161 END SUBROUTINE mp_igatherv_lv
12162
12163! **************************************************************************************************
12164!> \brief Gathers a datum from all processes and all processes receive the
12165!> same data
12166!> \param[in] msgout Datum to send
12167!> \param[out] msgin Received data
12168!> \param[in] comm Message passing environment identifier
12169!> \par Data size
12170!> All processes send equal-sized data
12171!> \par MPI mapping
12172!> mpi_allgather
12173! **************************************************************************************************
12174 SUBROUTINE mp_allgather_l (msgout, msgin, comm)
12175 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12176 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
12177 CLASS(mp_comm_type), INTENT(IN) :: comm
12178
12179 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l'
12180
12181 INTEGER :: handle
12182#if defined(__parallel)
12183 INTEGER :: ierr, rcount, scount
12184#endif
12185
12186 CALL mp_timeset(routinen, handle)
12187
12188#if defined(__parallel)
12189 scount = 1
12190 rcount = 1
12191 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12192 msgin, rcount, mpi_integer8, &
12193 comm%handle, ierr)
12194 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12195#else
12196 mark_used(comm)
12197 msgin = msgout
12198#endif
12199 CALL mp_timestop(handle)
12200 END SUBROUTINE mp_allgather_l
12201
12202! **************************************************************************************************
12203!> \brief Gathers a datum from all processes and all processes receive the
12204!> same data
12205!> \param[in] msgout Datum to send
12206!> \param[out] msgin Received data
12207!> \param[in] comm Message passing environment identifier
12208!> \par Data size
12209!> All processes send equal-sized data
12210!> \par MPI mapping
12211!> mpi_allgather
12212! **************************************************************************************************
12213 SUBROUTINE mp_allgather_l2(msgout, msgin, comm)
12214 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12215 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12216 CLASS(mp_comm_type), INTENT(IN) :: comm
12217
12218 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l2'
12219
12220 INTEGER :: handle
12221#if defined(__parallel)
12222 INTEGER :: ierr, rcount, scount
12223#endif
12224
12225 CALL mp_timeset(routinen, handle)
12226
12227#if defined(__parallel)
12228 scount = 1
12229 rcount = 1
12230 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12231 msgin, rcount, mpi_integer8, &
12232 comm%handle, ierr)
12233 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12234#else
12235 mark_used(comm)
12236 msgin = msgout
12237#endif
12238 CALL mp_timestop(handle)
12239 END SUBROUTINE mp_allgather_l2
12240
12241! **************************************************************************************************
12242!> \brief Gathers a datum from all processes and all processes receive the
12243!> same data
12244!> \param[in] msgout Datum to send
12245!> \param[out] msgin Received data
12246!> \param[in] comm Message passing environment identifier
12247!> \par Data size
12248!> All processes send equal-sized data
12249!> \par MPI mapping
12250!> mpi_allgather
12251! **************************************************************************************************
12252 SUBROUTINE mp_iallgather_l (msgout, msgin, comm, request)
12253 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12254 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12255 CLASS(mp_comm_type), INTENT(IN) :: comm
12256 TYPE(mp_request_type), INTENT(OUT) :: request
12257
12258 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l'
12259
12260 INTEGER :: handle
12261#if defined(__parallel)
12262 INTEGER :: ierr, rcount, scount
12263#endif
12264
12265 CALL mp_timeset(routinen, handle)
12266
12267#if defined(__parallel)
12268#if !defined(__GNUC__) || __GNUC__ >= 9
12269 cpassert(is_contiguous(msgin))
12270#endif
12271 scount = 1
12272 rcount = 1
12273 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12274 msgin, rcount, mpi_integer8, &
12275 comm%handle, request%handle, ierr)
12276 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12277#else
12278 mark_used(comm)
12279 msgin = msgout
12280 request = mp_request_null
12281#endif
12282 CALL mp_timestop(handle)
12283 END SUBROUTINE mp_iallgather_l
12284
12285! **************************************************************************************************
12286!> \brief Gathers vector data from all processes and all processes receive the
12287!> same data
12288!> \param[in] msgout Rank-1 data to send
12289!> \param[out] msgin Received data
12290!> \param[in] comm Message passing environment identifier
12291!> \par Data size
12292!> All processes send equal-sized data
12293!> \par Ranks
12294!> The last rank counts the processes
12295!> \par MPI mapping
12296!> mpi_allgather
12297! **************************************************************************************************
12298 SUBROUTINE mp_allgather_l12(msgout, msgin, comm)
12299 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:)
12300 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12301 CLASS(mp_comm_type), INTENT(IN) :: comm
12302
12303 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l12'
12304
12305 INTEGER :: handle
12306#if defined(__parallel)
12307 INTEGER :: ierr, rcount, scount
12308#endif
12309
12310 CALL mp_timeset(routinen, handle)
12311
12312#if defined(__parallel)
12313 scount = SIZE(msgout(:))
12314 rcount = scount
12315 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12316 msgin, rcount, mpi_integer8, &
12317 comm%handle, ierr)
12318 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12319#else
12320 mark_used(comm)
12321 msgin(:, 1) = msgout(:)
12322#endif
12323 CALL mp_timestop(handle)
12324 END SUBROUTINE mp_allgather_l12
12325
12326! **************************************************************************************************
12327!> \brief Gathers matrix data from all processes and all processes receive the
12328!> same data
12329!> \param[in] msgout Rank-2 data to send
12330!> \param msgin ...
12331!> \param comm ...
12332!> \note see mp_allgather_l12
12333! **************************************************************************************************
12334 SUBROUTINE mp_allgather_l23(msgout, msgin, comm)
12335 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
12336 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
12337 CLASS(mp_comm_type), INTENT(IN) :: comm
12338
12339 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l23'
12340
12341 INTEGER :: handle
12342#if defined(__parallel)
12343 INTEGER :: ierr, rcount, scount
12344#endif
12345
12346 CALL mp_timeset(routinen, handle)
12347
12348#if defined(__parallel)
12349 scount = SIZE(msgout(:, :))
12350 rcount = scount
12351 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12352 msgin, rcount, mpi_integer8, &
12353 comm%handle, ierr)
12354 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12355#else
12356 mark_used(comm)
12357 msgin(:, :, 1) = msgout(:, :)
12358#endif
12359 CALL mp_timestop(handle)
12360 END SUBROUTINE mp_allgather_l23
12361
12362! **************************************************************************************************
12363!> \brief Gathers rank-3 data from all processes and all processes receive the
12364!> same data
12365!> \param[in] msgout Rank-3 data to send
12366!> \param msgin ...
12367!> \param comm ...
12368!> \note see mp_allgather_l12
12369! **************************************************************************************************
12370 SUBROUTINE mp_allgather_l34(msgout, msgin, comm)
12371 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
12372 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
12373 CLASS(mp_comm_type), INTENT(IN) :: comm
12374
12375 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l34'
12376
12377 INTEGER :: handle
12378#if defined(__parallel)
12379 INTEGER :: ierr, rcount, scount
12380#endif
12381
12382 CALL mp_timeset(routinen, handle)
12383
12384#if defined(__parallel)
12385 scount = SIZE(msgout(:, :, :))
12386 rcount = scount
12387 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12388 msgin, rcount, mpi_integer8, &
12389 comm%handle, ierr)
12390 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12391#else
12392 mark_used(comm)
12393 msgin(:, :, :, 1) = msgout(:, :, :)
12394#endif
12395 CALL mp_timestop(handle)
12396 END SUBROUTINE mp_allgather_l34
12397
12398! **************************************************************************************************
12399!> \brief Gathers rank-2 data from all processes and all processes receive the
12400!> same data
12401!> \param[in] msgout Rank-2 data to send
12402!> \param msgin ...
12403!> \param comm ...
12404!> \note see mp_allgather_l12
12405! **************************************************************************************************
12406 SUBROUTINE mp_allgather_l22(msgout, msgin, comm)
12407 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
12408 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12409 CLASS(mp_comm_type), INTENT(IN) :: comm
12410
12411 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l22'
12412
12413 INTEGER :: handle
12414#if defined(__parallel)
12415 INTEGER :: ierr, rcount, scount
12416#endif
12417
12418 CALL mp_timeset(routinen, handle)
12419
12420#if defined(__parallel)
12421 scount = SIZE(msgout(:, :))
12422 rcount = scount
12423 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12424 msgin, rcount, mpi_integer8, &
12425 comm%handle, ierr)
12426 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12427#else
12428 mark_used(comm)
12429 msgin(:, :) = msgout(:, :)
12430#endif
12431 CALL mp_timestop(handle)
12432 END SUBROUTINE mp_allgather_l22
12433
12434! **************************************************************************************************
12435!> \brief Gathers rank-1 data from all processes and all processes receive the
12436!> same data
12437!> \param[in] msgout Rank-1 data to send
12438!> \param msgin ...
12439!> \param comm ...
12440!> \param request ...
12441!> \note see mp_allgather_l11
12442! **************************************************************************************************
12443 SUBROUTINE mp_iallgather_l11(msgout, msgin, comm, request)
12444 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12445 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12446 CLASS(mp_comm_type), INTENT(IN) :: comm
12447 TYPE(mp_request_type), INTENT(OUT) :: request
12448
12449 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l11'
12450
12451 INTEGER :: handle
12452#if defined(__parallel)
12453 INTEGER :: ierr, rcount, scount
12454#endif
12455
12456 CALL mp_timeset(routinen, handle)
12457
12458#if defined(__parallel)
12459#if !defined(__GNUC__) || __GNUC__ >= 9
12460 cpassert(is_contiguous(msgout))
12461 cpassert(is_contiguous(msgin))
12462#endif
12463 scount = SIZE(msgout(:))
12464 rcount = scount
12465 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12466 msgin, rcount, mpi_integer8, &
12467 comm%handle, request%handle, ierr)
12468 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12469#else
12470 mark_used(comm)
12471 msgin = msgout
12472 request = mp_request_null
12473#endif
12474 CALL mp_timestop(handle)
12475 END SUBROUTINE mp_iallgather_l11
12476
12477! **************************************************************************************************
12478!> \brief Gathers rank-2 data from all processes and all processes receive the
12479!> same data
12480!> \param[in] msgout Rank-2 data to send
12481!> \param msgin ...
12482!> \param comm ...
12483!> \param request ...
12484!> \note see mp_allgather_l12
12485! **************************************************************************************************
12486 SUBROUTINE mp_iallgather_l13(msgout, msgin, comm, request)
12487 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12488 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :)
12489 CLASS(mp_comm_type), INTENT(IN) :: comm
12490 TYPE(mp_request_type), INTENT(OUT) :: request
12491
12492 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l13'
12493
12494 INTEGER :: handle
12495#if defined(__parallel)
12496 INTEGER :: ierr, rcount, scount
12497#endif
12498
12499 CALL mp_timeset(routinen, handle)
12500
12501#if defined(__parallel)
12502#if !defined(__GNUC__) || __GNUC__ >= 9
12503 cpassert(is_contiguous(msgout))
12504 cpassert(is_contiguous(msgin))
12505#endif
12506
12507 scount = SIZE(msgout(:))
12508 rcount = scount
12509 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12510 msgin, rcount, mpi_integer8, &
12511 comm%handle, request%handle, ierr)
12512 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12513#else
12514 mark_used(comm)
12515 msgin(:, 1, 1) = msgout(:)
12516 request = mp_request_null
12517#endif
12518 CALL mp_timestop(handle)
12519 END SUBROUTINE mp_iallgather_l13
12520
12521! **************************************************************************************************
12522!> \brief Gathers rank-2 data from all processes and all processes receive the
12523!> same data
12524!> \param[in] msgout Rank-2 data to send
12525!> \param msgin ...
12526!> \param comm ...
12527!> \param request ...
12528!> \note see mp_allgather_l12
12529! **************************************************************************************************
12530 SUBROUTINE mp_iallgather_l22(msgout, msgin, comm, request)
12531 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :)
12532 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :)
12533 CLASS(mp_comm_type), INTENT(IN) :: comm
12534 TYPE(mp_request_type), INTENT(OUT) :: request
12535
12536 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l22'
12537
12538 INTEGER :: handle
12539#if defined(__parallel)
12540 INTEGER :: ierr, rcount, scount
12541#endif
12542
12543 CALL mp_timeset(routinen, handle)
12544
12545#if defined(__parallel)
12546#if !defined(__GNUC__) || __GNUC__ >= 9
12547 cpassert(is_contiguous(msgout))
12548 cpassert(is_contiguous(msgin))
12549#endif
12550
12551 scount = SIZE(msgout(:, :))
12552 rcount = scount
12553 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12554 msgin, rcount, mpi_integer8, &
12555 comm%handle, request%handle, ierr)
12556 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12557#else
12558 mark_used(comm)
12559 msgin(:, :) = msgout(:, :)
12560 request = mp_request_null
12561#endif
12562 CALL mp_timestop(handle)
12563 END SUBROUTINE mp_iallgather_l22
12564
12565! **************************************************************************************************
12566!> \brief Gathers rank-2 data from all processes and all processes receive the
12567!> same data
12568!> \param[in] msgout Rank-2 data to send
12569!> \param msgin ...
12570!> \param comm ...
12571!> \param request ...
12572!> \note see mp_allgather_l12
12573! **************************************************************************************************
12574 SUBROUTINE mp_iallgather_l24(msgout, msgin, comm, request)
12575 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :)
12576 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :, :)
12577 CLASS(mp_comm_type), INTENT(IN) :: comm
12578 TYPE(mp_request_type), INTENT(OUT) :: request
12579
12580 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l24'
12581
12582 INTEGER :: handle
12583#if defined(__parallel)
12584 INTEGER :: ierr, rcount, scount
12585#endif
12586
12587 CALL mp_timeset(routinen, handle)
12588
12589#if defined(__parallel)
12590#if !defined(__GNUC__) || __GNUC__ >= 9
12591 cpassert(is_contiguous(msgout))
12592 cpassert(is_contiguous(msgin))
12593#endif
12594
12595 scount = SIZE(msgout(:, :))
12596 rcount = scount
12597 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12598 msgin, rcount, mpi_integer8, &
12599 comm%handle, request%handle, ierr)
12600 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12601#else
12602 mark_used(comm)
12603 msgin(:, :, 1, 1) = msgout(:, :)
12604 request = mp_request_null
12605#endif
12606 CALL mp_timestop(handle)
12607 END SUBROUTINE mp_iallgather_l24
12608
12609! **************************************************************************************************
12610!> \brief Gathers rank-3 data from all processes and all processes receive the
12611!> same data
12612!> \param[in] msgout Rank-3 data to send
12613!> \param msgin ...
12614!> \param comm ...
12615!> \param request ...
12616!> \note see mp_allgather_l12
12617! **************************************************************************************************
12618 SUBROUTINE mp_iallgather_l33(msgout, msgin, comm, request)
12619 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :, :)
12620 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :)
12621 CLASS(mp_comm_type), INTENT(IN) :: comm
12622 TYPE(mp_request_type), INTENT(OUT) :: request
12623
12624 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l33'
12625
12626 INTEGER :: handle
12627#if defined(__parallel)
12628 INTEGER :: ierr, rcount, scount
12629#endif
12630
12631 CALL mp_timeset(routinen, handle)
12632
12633#if defined(__parallel)
12634#if !defined(__GNUC__) || __GNUC__ >= 9
12635 cpassert(is_contiguous(msgout))
12636 cpassert(is_contiguous(msgin))
12637#endif
12638
12639 scount = SIZE(msgout(:, :, :))
12640 rcount = scount
12641 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12642 msgin, rcount, mpi_integer8, &
12643 comm%handle, request%handle, ierr)
12644 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12645#else
12646 mark_used(comm)
12647 msgin(:, :, :) = msgout(:, :, :)
12648 request = mp_request_null
12649#endif
12650 CALL mp_timestop(handle)
12651 END SUBROUTINE mp_iallgather_l33
12652
12653! **************************************************************************************************
12654!> \brief Gathers vector data from all processes and all processes receive the
12655!> same data
12656!> \param[in] msgout Rank-1 data to send
12657!> \param[out] msgin Received data
12658!> \param[in] rcount Size of sent data for every process
12659!> \param[in] rdispl Offset of sent data for every process
12660!> \param[in] comm Message passing environment identifier
12661!> \par Data size
12662!> Processes can send different-sized data
12663!> \par Ranks
12664!> The last rank counts the processes
12665!> \par Offsets
12666!> Offsets are from 0
12667!> \par MPI mapping
12668!> mpi_allgather
12669! **************************************************************************************************
12670 SUBROUTINE mp_allgatherv_lv(msgout, msgin, rcount, rdispl, comm)
12671 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
12672 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12673 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12674 CLASS(mp_comm_type), INTENT(IN) :: comm
12675
12676 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_lv'
12677
12678 INTEGER :: handle
12679#if defined(__parallel)
12680 INTEGER :: ierr, scount
12681#endif
12682
12683 CALL mp_timeset(routinen, handle)
12684
12685#if defined(__parallel)
12686 scount = SIZE(msgout)
12687 CALL mpi_allgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12688 rdispl, mpi_integer8, comm%handle, ierr)
12689 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
12690#else
12691 mark_used(rcount)
12692 mark_used(rdispl)
12693 mark_used(comm)
12694 msgin = msgout
12695#endif
12696 CALL mp_timestop(handle)
12697 END SUBROUTINE mp_allgatherv_lv
12698
12699! **************************************************************************************************
12700!> \brief Gathers vector data from all processes and all processes receive the
12701!> same data
12702!> \param[in] msgout Rank-1 data to send
12703!> \param[out] msgin Received data
12704!> \param[in] rcount Size of sent data for every process
12705!> \param[in] rdispl Offset of sent data for every process
12706!> \param[in] comm Message passing environment identifier
12707!> \par Data size
12708!> Processes can send different-sized data
12709!> \par Ranks
12710!> The last rank counts the processes
12711!> \par Offsets
12712!> Offsets are from 0
12713!> \par MPI mapping
12714!> mpi_allgather
12715! **************************************************************************************************
12716 SUBROUTINE mp_allgatherv_lm2(msgout, msgin, rcount, rdispl, comm)
12717 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
12718 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
12719 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12720 CLASS(mp_comm_type), INTENT(IN) :: comm
12721
12722 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_lv'
12723
12724 INTEGER :: handle
12725#if defined(__parallel)
12726 INTEGER :: ierr, scount
12727#endif
12728
12729 CALL mp_timeset(routinen, handle)
12730
12731#if defined(__parallel)
12732 scount = SIZE(msgout)
12733 CALL mpi_allgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12734 rdispl, mpi_integer8, comm%handle, ierr)
12735 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
12736#else
12737 mark_used(rcount)
12738 mark_used(rdispl)
12739 mark_used(comm)
12740 msgin = msgout
12741#endif
12742 CALL mp_timestop(handle)
12743 END SUBROUTINE mp_allgatherv_lm2
12744
12745! **************************************************************************************************
12746!> \brief Gathers vector data from all processes and all processes receive the
12747!> same data
12748!> \param[in] msgout Rank-1 data to send
12749!> \param[out] msgin Received data
12750!> \param[in] rcount Size of sent data for every process
12751!> \param[in] rdispl Offset of sent data for every process
12752!> \param[in] comm Message passing environment identifier
12753!> \par Data size
12754!> Processes can send different-sized data
12755!> \par Ranks
12756!> The last rank counts the processes
12757!> \par Offsets
12758!> Offsets are from 0
12759!> \par MPI mapping
12760!> mpi_allgather
12761! **************************************************************************************************
12762 SUBROUTINE mp_iallgatherv_lv(msgout, msgin, rcount, rdispl, comm, request)
12763 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12764 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12765 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12766 CLASS(mp_comm_type), INTENT(IN) :: comm
12767 TYPE(mp_request_type), INTENT(OUT) :: request
12768
12769 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_lv'
12770
12771 INTEGER :: handle
12772#if defined(__parallel)
12773 INTEGER :: ierr, scount, rsize
12774#endif
12775
12776 CALL mp_timeset(routinen, handle)
12777
12778#if defined(__parallel)
12779#if !defined(__GNUC__) || __GNUC__ >= 9
12780 cpassert(is_contiguous(msgout))
12781 cpassert(is_contiguous(msgin))
12782 cpassert(is_contiguous(rcount))
12783 cpassert(is_contiguous(rdispl))
12784#endif
12785
12786 scount = SIZE(msgout)
12787 rsize = SIZE(rcount)
12788 CALL mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, &
12789 rdispl, comm, request, ierr)
12790 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
12791#else
12792 mark_used(rcount)
12793 mark_used(rdispl)
12794 mark_used(comm)
12795 msgin = msgout
12796 request = mp_request_null
12797#endif
12798 CALL mp_timestop(handle)
12799 END SUBROUTINE mp_iallgatherv_lv
12800
12801! **************************************************************************************************
12802!> \brief Gathers vector data from all processes and all processes receive the
12803!> same data
12804!> \param[in] msgout Rank-1 data to send
12805!> \param[out] msgin Received data
12806!> \param[in] rcount Size of sent data for every process
12807!> \param[in] rdispl Offset of sent data for every process
12808!> \param[in] comm Message passing environment identifier
12809!> \par Data size
12810!> Processes can send different-sized data
12811!> \par Ranks
12812!> The last rank counts the processes
12813!> \par Offsets
12814!> Offsets are from 0
12815!> \par MPI mapping
12816!> mpi_allgather
12817! **************************************************************************************************
12818 SUBROUTINE mp_iallgatherv_lv2(msgout, msgin, rcount, rdispl, comm, request)
12819 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12820 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12821 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
12822 CLASS(mp_comm_type), INTENT(IN) :: comm
12823 TYPE(mp_request_type), INTENT(OUT) :: request
12824
12825 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_lv2'
12826
12827 INTEGER :: handle
12828#if defined(__parallel)
12829 INTEGER :: ierr, scount, rsize
12830#endif
12831
12832 CALL mp_timeset(routinen, handle)
12833
12834#if defined(__parallel)
12835#if !defined(__GNUC__) || __GNUC__ >= 9
12836 cpassert(is_contiguous(msgout))
12837 cpassert(is_contiguous(msgin))
12838 cpassert(is_contiguous(rcount))
12839 cpassert(is_contiguous(rdispl))
12840#endif
12841
12842 scount = SIZE(msgout)
12843 rsize = SIZE(rcount)
12844 CALL mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, &
12845 rdispl, comm, request, ierr)
12846 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
12847#else
12848 mark_used(rcount)
12849 mark_used(rdispl)
12850 mark_used(comm)
12851 msgin = msgout
12852 request = mp_request_null
12853#endif
12854 CALL mp_timestop(handle)
12855 END SUBROUTINE mp_iallgatherv_lv2
12856
12857! **************************************************************************************************
12858!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
12859!> the issue is with the rank of rcount and rdispl
12860!> \param count ...
12861!> \param array_of_requests ...
12862!> \param array_of_statuses ...
12863!> \param ierr ...
12864!> \author Alfio Lazzaro
12865! **************************************************************************************************
12866#if defined(__parallel)
12867 SUBROUTINE mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
12868 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
12869 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12870 INTEGER, INTENT(IN) :: rsize
12871 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
12872 CLASS(mp_comm_type), INTENT(IN) :: comm
12873 TYPE(mp_request_type), INTENT(OUT) :: request
12874 INTEGER, INTENT(INOUT) :: ierr
12875
12876 CALL mpi_iallgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12877 rdispl, mpi_integer8, comm%handle, request%handle, ierr)
12878
12879 END SUBROUTINE mp_iallgatherv_lv_internal
12880#endif
12881
12882! **************************************************************************************************
12883!> \brief Sums a vector and partitions the result among processes
12884!> \param[in] msgout Data to sum
12885!> \param[out] msgin Received portion of summed data
12886!> \param[in] rcount Partition sizes of the summed data for
12887!> every process
12888!> \param[in] comm Message passing environment identifier
12889! **************************************************************************************************
12890 SUBROUTINE mp_sum_scatter_lv(msgout, msgin, rcount, comm)
12891 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
12892 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12893 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
12894 CLASS(mp_comm_type), INTENT(IN) :: comm
12895
12896 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_lv'
12897
12898 INTEGER :: handle
12899#if defined(__parallel)
12900 INTEGER :: ierr
12901#endif
12902
12903 CALL mp_timeset(routinen, handle)
12904
12905#if defined(__parallel)
12906 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_integer8, mpi_sum, &
12907 comm%handle, ierr)
12908 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
12909
12910 CALL add_perf(perf_id=3, count=1, &
12911 msg_size=rcount(1)*2*int_8_size)
12912#else
12913 mark_used(rcount)
12914 mark_used(comm)
12915 msgin = msgout(:, 1)
12916#endif
12917 CALL mp_timestop(handle)
12918 END SUBROUTINE mp_sum_scatter_lv
12919
12920! **************************************************************************************************
12921!> \brief Sends and receives vector data
12922!> \param[in] msgin Data to send
12923!> \param[in] dest Process to send data to
12924!> \param[out] msgout Received data
12925!> \param[in] source Process from which to receive
12926!> \param[in] comm Message passing environment identifier
12927!> \param[in] tag Send and recv tag (default: 0)
12928! **************************************************************************************************
12929 SUBROUTINE mp_sendrecv_l (msgin, dest, msgout, source, comm, tag)
12930 INTEGER(KIND=int_8), INTENT(IN) :: msgin
12931 INTEGER, INTENT(IN) :: dest
12932 INTEGER(KIND=int_8), INTENT(OUT) :: msgout
12933 INTEGER, INTENT(IN) :: source
12934 CLASS(mp_comm_type), INTENT(IN) :: comm
12935 INTEGER, INTENT(IN), OPTIONAL :: tag
12936
12937 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_l'
12938
12939 INTEGER :: handle
12940#if defined(__parallel)
12941 INTEGER :: ierr, msglen_in, msglen_out, &
12942 recv_tag, send_tag
12943#endif
12944
12945 CALL mp_timeset(routinen, handle)
12946
12947#if defined(__parallel)
12948 msglen_in = 1
12949 msglen_out = 1
12950 send_tag = 0 ! cannot think of something better here, this might be dangerous
12951 recv_tag = 0 ! cannot think of something better here, this might be dangerous
12952 IF (PRESENT(tag)) THEN
12953 send_tag = tag
12954 recv_tag = tag
12955 END IF
12956 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
12957 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
12958 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
12959 CALL add_perf(perf_id=7, count=1, &
12960 msg_size=(msglen_in + msglen_out)*int_8_size/2)
12961#else
12962 mark_used(dest)
12963 mark_used(source)
12964 mark_used(comm)
12965 mark_used(tag)
12966 msgout = msgin
12967#endif
12968 CALL mp_timestop(handle)
12969 END SUBROUTINE mp_sendrecv_l
12970
12971! **************************************************************************************************
12972!> \brief Sends and receives vector data
12973!> \param[in] msgin Data to send
12974!> \param[in] dest Process to send data to
12975!> \param[out] msgout Received data
12976!> \param[in] source Process from which to receive
12977!> \param[in] comm Message passing environment identifier
12978!> \param[in] tag Send and recv tag (default: 0)
12979! **************************************************************************************************
12980 SUBROUTINE mp_sendrecv_lv(msgin, dest, msgout, source, comm, tag)
12981 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
12982 INTEGER, INTENT(IN) :: dest
12983 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
12984 INTEGER, INTENT(IN) :: source
12985 CLASS(mp_comm_type), INTENT(IN) :: comm
12986 INTEGER, INTENT(IN), OPTIONAL :: tag
12987
12988 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lv'
12989
12990 INTEGER :: handle
12991#if defined(__parallel)
12992 INTEGER :: ierr, msglen_in, msglen_out, &
12993 recv_tag, send_tag
12994#endif
12995
12996 CALL mp_timeset(routinen, handle)
12997
12998#if defined(__parallel)
12999 msglen_in = SIZE(msgin)
13000 msglen_out = SIZE(msgout)
13001 send_tag = 0 ! cannot think of something better here, this might be dangerous
13002 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13003 IF (PRESENT(tag)) THEN
13004 send_tag = tag
13005 recv_tag = tag
13006 END IF
13007 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13008 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13009 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13010 CALL add_perf(perf_id=7, count=1, &
13011 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13012#else
13013 mark_used(dest)
13014 mark_used(source)
13015 mark_used(comm)
13016 mark_used(tag)
13017 msgout = msgin
13018#endif
13019 CALL mp_timestop(handle)
13020 END SUBROUTINE mp_sendrecv_lv
13021
13022! **************************************************************************************************
13023!> \brief Sends and receives matrix data
13024!> \param msgin ...
13025!> \param dest ...
13026!> \param msgout ...
13027!> \param source ...
13028!> \param comm ...
13029!> \param tag ...
13030!> \note see mp_sendrecv_lv
13031! **************************************************************************************************
13032 SUBROUTINE mp_sendrecv_lm2(msgin, dest, msgout, source, comm, tag)
13033 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
13034 INTEGER, INTENT(IN) :: dest
13035 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
13036 INTEGER, INTENT(IN) :: source
13037 CLASS(mp_comm_type), INTENT(IN) :: comm
13038 INTEGER, INTENT(IN), OPTIONAL :: tag
13039
13040 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm2'
13041
13042 INTEGER :: handle
13043#if defined(__parallel)
13044 INTEGER :: ierr, msglen_in, msglen_out, &
13045 recv_tag, send_tag
13046#endif
13047
13048 CALL mp_timeset(routinen, handle)
13049
13050#if defined(__parallel)
13051 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
13052 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
13053 send_tag = 0 ! cannot think of something better here, this might be dangerous
13054 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13055 IF (PRESENT(tag)) THEN
13056 send_tag = tag
13057 recv_tag = tag
13058 END IF
13059 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13060 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13061 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13062 CALL add_perf(perf_id=7, count=1, &
13063 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13064#else
13065 mark_used(dest)
13066 mark_used(source)
13067 mark_used(comm)
13068 mark_used(tag)
13069 msgout = msgin
13070#endif
13071 CALL mp_timestop(handle)
13072 END SUBROUTINE mp_sendrecv_lm2
13073
13074! **************************************************************************************************
13075!> \brief Sends and receives rank-3 data
13076!> \param msgin ...
13077!> \param dest ...
13078!> \param msgout ...
13079!> \param source ...
13080!> \param comm ...
13081!> \note see mp_sendrecv_lv
13082! **************************************************************************************************
13083 SUBROUTINE mp_sendrecv_lm3(msgin, dest, msgout, source, comm, tag)
13084 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
13085 INTEGER, INTENT(IN) :: dest
13086 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
13087 INTEGER, INTENT(IN) :: source
13088 CLASS(mp_comm_type), INTENT(IN) :: comm
13089 INTEGER, INTENT(IN), OPTIONAL :: tag
13090
13091 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm3'
13092
13093 INTEGER :: handle
13094#if defined(__parallel)
13095 INTEGER :: ierr, msglen_in, msglen_out, &
13096 recv_tag, send_tag
13097#endif
13098
13099 CALL mp_timeset(routinen, handle)
13100
13101#if defined(__parallel)
13102 msglen_in = SIZE(msgin)
13103 msglen_out = SIZE(msgout)
13104 send_tag = 0 ! cannot think of something better here, this might be dangerous
13105 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13106 IF (PRESENT(tag)) THEN
13107 send_tag = tag
13108 recv_tag = tag
13109 END IF
13110 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13111 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13112 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13113 CALL add_perf(perf_id=7, count=1, &
13114 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13115#else
13116 mark_used(dest)
13117 mark_used(source)
13118 mark_used(comm)
13119 mark_used(tag)
13120 msgout = msgin
13121#endif
13122 CALL mp_timestop(handle)
13123 END SUBROUTINE mp_sendrecv_lm3
13124
13125! **************************************************************************************************
13126!> \brief Sends and receives rank-4 data
13127!> \param msgin ...
13128!> \param dest ...
13129!> \param msgout ...
13130!> \param source ...
13131!> \param comm ...
13132!> \note see mp_sendrecv_lv
13133! **************************************************************************************************
13134 SUBROUTINE mp_sendrecv_lm4(msgin, dest, msgout, source, comm, tag)
13135 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
13136 INTEGER, INTENT(IN) :: dest
13137 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
13138 INTEGER, INTENT(IN) :: source
13139 CLASS(mp_comm_type), INTENT(IN) :: comm
13140 INTEGER, INTENT(IN), OPTIONAL :: tag
13141
13142 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm4'
13143
13144 INTEGER :: handle
13145#if defined(__parallel)
13146 INTEGER :: ierr, msglen_in, msglen_out, &
13147 recv_tag, send_tag
13148#endif
13149
13150 CALL mp_timeset(routinen, handle)
13151
13152#if defined(__parallel)
13153 msglen_in = SIZE(msgin)
13154 msglen_out = SIZE(msgout)
13155 send_tag = 0 ! cannot think of something better here, this might be dangerous
13156 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13157 IF (PRESENT(tag)) THEN
13158 send_tag = tag
13159 recv_tag = tag
13160 END IF
13161 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13162 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13163 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13164 CALL add_perf(perf_id=7, count=1, &
13165 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13166#else
13167 mark_used(dest)
13168 mark_used(source)
13169 mark_used(comm)
13170 mark_used(tag)
13171 msgout = msgin
13172#endif
13173 CALL mp_timestop(handle)
13174 END SUBROUTINE mp_sendrecv_lm4
13175
13176! **************************************************************************************************
13177!> \brief Non-blocking send and receive of a scalar
13178!> \param[in] msgin Scalar data to send
13179!> \param[in] dest Which process to send to
13180!> \param[out] msgout Receive data into this pointer
13181!> \param[in] source Process to receive from
13182!> \param[in] comm Message passing environment identifier
13183!> \param[out] send_request Request handle for the send
13184!> \param[out] recv_request Request handle for the receive
13185!> \param[in] tag (optional) tag to differentiate requests
13186!> \par Implementation
13187!> Calls mpi_isend and mpi_irecv.
13188!> \par History
13189!> 02.2005 created [Alfio Lazzaro]
13190! **************************************************************************************************
13191 SUBROUTINE mp_isendrecv_l (msgin, dest, msgout, source, comm, send_request, &
13192 recv_request, tag)
13193 INTEGER(KIND=int_8), INTENT(IN) :: msgin
13194 INTEGER, INTENT(IN) :: dest
13195 INTEGER(KIND=int_8), INTENT(INOUT) :: msgout
13196 INTEGER, INTENT(IN) :: source
13197 CLASS(mp_comm_type), INTENT(IN) :: comm
13198 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
13199 INTEGER, INTENT(in), OPTIONAL :: tag
13200
13201 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_l'
13202
13203 INTEGER :: handle
13204#if defined(__parallel)
13205 INTEGER :: ierr, my_tag
13206#endif
13207
13208 CALL mp_timeset(routinen, handle)
13209
13210#if defined(__parallel)
13211 my_tag = 0
13212 IF (PRESENT(tag)) my_tag = tag
13213
13214 CALL mpi_irecv(msgout, 1, mpi_integer8, source, my_tag, &
13215 comm%handle, recv_request%handle, ierr)
13216 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13217
13218 CALL mpi_isend(msgin, 1, mpi_integer8, dest, my_tag, &
13219 comm%handle, send_request%handle, ierr)
13220 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13221
13222 CALL add_perf(perf_id=8, count=1, msg_size=2*int_8_size)
13223#else
13224 mark_used(dest)
13225 mark_used(source)
13226 mark_used(comm)
13227 mark_used(tag)
13228 send_request = mp_request_null
13229 recv_request = mp_request_null
13230 msgout = msgin
13231#endif
13232 CALL mp_timestop(handle)
13233 END SUBROUTINE mp_isendrecv_l
13234
13235! **************************************************************************************************
13236!> \brief Non-blocking send and receive of a vector
13237!> \param[in] msgin Vector data to send
13238!> \param[in] dest Which process to send to
13239!> \param[out] msgout Receive data into this pointer
13240!> \param[in] source Process to receive from
13241!> \param[in] comm Message passing environment identifier
13242!> \param[out] send_request Request handle for the send
13243!> \param[out] recv_request Request handle for the receive
13244!> \param[in] tag (optional) tag to differentiate requests
13245!> \par Implementation
13246!> Calls mpi_isend and mpi_irecv.
13247!> \par History
13248!> 11.2004 created [Joost VandeVondele]
13249!> \note
13250!> arrays can be pointers or assumed shape, but they must be contiguous!
13251! **************************************************************************************************
13252 SUBROUTINE mp_isendrecv_lv(msgin, dest, msgout, source, comm, send_request, &
13253 recv_request, tag)
13254 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: msgin
13255 INTEGER, INTENT(IN) :: dest
13256 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT) :: msgout
13257 INTEGER, INTENT(IN) :: source
13258 CLASS(mp_comm_type), INTENT(IN) :: comm
13259 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
13260 INTEGER, INTENT(in), OPTIONAL :: tag
13261
13262 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_lv'
13263
13264 INTEGER :: handle
13265#if defined(__parallel)
13266 INTEGER :: ierr, msglen, my_tag
13267 INTEGER(KIND=int_8) :: foo
13268#endif
13269
13270 CALL mp_timeset(routinen, handle)
13271
13272#if defined(__parallel)
13273#if !defined(__GNUC__) || __GNUC__ >= 9
13274 cpassert(is_contiguous(msgout))
13275 cpassert(is_contiguous(msgin))
13276#endif
13277
13278 my_tag = 0
13279 IF (PRESENT(tag)) my_tag = tag
13280
13281 msglen = SIZE(msgout, 1)
13282 IF (msglen > 0) THEN
13283 CALL mpi_irecv(msgout(1), msglen, mpi_integer8, source, my_tag, &
13284 comm%handle, recv_request%handle, ierr)
13285 ELSE
13286 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13287 comm%handle, recv_request%handle, ierr)
13288 END IF
13289 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13290
13291 msglen = SIZE(msgin, 1)
13292 IF (msglen > 0) THEN
13293 CALL mpi_isend(msgin(1), msglen, mpi_integer8, dest, my_tag, &
13294 comm%handle, send_request%handle, ierr)
13295 ELSE
13296 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13297 comm%handle, send_request%handle, ierr)
13298 END IF
13299 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13300
13301 msglen = (msglen + SIZE(msgout, 1) + 1)/2
13302 CALL add_perf(perf_id=8, count=1, msg_size=msglen*int_8_size)
13303#else
13304 mark_used(dest)
13305 mark_used(source)
13306 mark_used(comm)
13307 mark_used(tag)
13308 send_request = mp_request_null
13309 recv_request = mp_request_null
13310 msgout = msgin
13311#endif
13312 CALL mp_timestop(handle)
13313 END SUBROUTINE mp_isendrecv_lv
13314
13315! **************************************************************************************************
13316!> \brief Non-blocking send of vector data
13317!> \param msgin ...
13318!> \param dest ...
13319!> \param comm ...
13320!> \param request ...
13321!> \param tag ...
13322!> \par History
13323!> 08.2003 created [f&j]
13324!> \note see mp_isendrecv_lv
13325!> \note
13326!> arrays can be pointers or assumed shape, but they must be contiguous!
13327! **************************************************************************************************
13328 SUBROUTINE mp_isend_lv(msgin, dest, comm, request, tag)
13329 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: msgin
13330 INTEGER, INTENT(IN) :: dest
13331 CLASS(mp_comm_type), INTENT(IN) :: comm
13332 TYPE(mp_request_type), INTENT(out) :: request
13333 INTEGER, INTENT(in), OPTIONAL :: tag
13334
13335 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lv'
13336
13337 INTEGER :: handle, ierr
13338#if defined(__parallel)
13339 INTEGER :: msglen, my_tag
13340 INTEGER(KIND=int_8) :: foo(1)
13341#endif
13342
13343 CALL mp_timeset(routinen, handle)
13344
13345#if defined(__parallel)
13346#if !defined(__GNUC__) || __GNUC__ >= 9
13347 cpassert(is_contiguous(msgin))
13348#endif
13349 my_tag = 0
13350 IF (PRESENT(tag)) my_tag = tag
13351
13352 msglen = SIZE(msgin)
13353 IF (msglen > 0) THEN
13354 CALL mpi_isend(msgin(1), msglen, mpi_integer8, dest, my_tag, &
13355 comm%handle, request%handle, ierr)
13356 ELSE
13357 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13358 comm%handle, request%handle, ierr)
13359 END IF
13360 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13361
13362 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13363#else
13364 mark_used(msgin)
13365 mark_used(dest)
13366 mark_used(comm)
13367 mark_used(request)
13368 mark_used(tag)
13369 ierr = 1
13370 request = mp_request_null
13371 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13372#endif
13373 CALL mp_timestop(handle)
13374 END SUBROUTINE mp_isend_lv
13375
13376! **************************************************************************************************
13377!> \brief Non-blocking send of matrix data
13378!> \param msgin ...
13379!> \param dest ...
13380!> \param comm ...
13381!> \param request ...
13382!> \param tag ...
13383!> \par History
13384!> 2009-11-25 [UB] Made type-generic for templates
13385!> \author fawzi
13386!> \note see mp_isendrecv_lv
13387!> \note see mp_isend_lv
13388!> \note
13389!> arrays can be pointers or assumed shape, but they must be contiguous!
13390! **************************************************************************************************
13391 SUBROUTINE mp_isend_lm2(msgin, dest, comm, request, tag)
13392 INTEGER(KIND=int_8), DIMENSION(:, :), INTENT(IN) :: msgin
13393 INTEGER, INTENT(IN) :: dest
13394 CLASS(mp_comm_type), INTENT(IN) :: comm
13395 TYPE(mp_request_type), INTENT(out) :: request
13396 INTEGER, INTENT(in), OPTIONAL :: tag
13397
13398 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm2'
13399
13400 INTEGER :: handle, ierr
13401#if defined(__parallel)
13402 INTEGER :: msglen, my_tag
13403 INTEGER(KIND=int_8) :: foo(1)
13404#endif
13405
13406 CALL mp_timeset(routinen, handle)
13407
13408#if defined(__parallel)
13409#if !defined(__GNUC__) || __GNUC__ >= 9
13410 cpassert(is_contiguous(msgin))
13411#endif
13412
13413 my_tag = 0
13414 IF (PRESENT(tag)) my_tag = tag
13415
13416 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
13417 IF (msglen > 0) THEN
13418 CALL mpi_isend(msgin(1, 1), msglen, mpi_integer8, dest, my_tag, &
13419 comm%handle, request%handle, ierr)
13420 ELSE
13421 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13422 comm%handle, request%handle, ierr)
13423 END IF
13424 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13425
13426 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13427#else
13428 mark_used(msgin)
13429 mark_used(dest)
13430 mark_used(comm)
13431 mark_used(request)
13432 mark_used(tag)
13433 ierr = 1
13434 request = mp_request_null
13435 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13436#endif
13437 CALL mp_timestop(handle)
13438 END SUBROUTINE mp_isend_lm2
13439
13440! **************************************************************************************************
13441!> \brief Non-blocking send of rank-3 data
13442!> \param msgin ...
13443!> \param dest ...
13444!> \param comm ...
13445!> \param request ...
13446!> \param tag ...
13447!> \par History
13448!> 9.2008 added _rm3 subroutine [Iain Bethune]
13449!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
13450!> 2009-11-25 [UB] Made type-generic for templates
13451!> \author fawzi
13452!> \note see mp_isendrecv_lv
13453!> \note see mp_isend_lv
13454!> \note
13455!> arrays can be pointers or assumed shape, but they must be contiguous!
13456! **************************************************************************************************
13457 SUBROUTINE mp_isend_lm3(msgin, dest, comm, request, tag)
13458 INTEGER(KIND=int_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
13459 INTEGER, INTENT(IN) :: dest
13460 CLASS(mp_comm_type), INTENT(IN) :: comm
13461 TYPE(mp_request_type), INTENT(out) :: request
13462 INTEGER, INTENT(in), OPTIONAL :: tag
13463
13464 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm3'
13465
13466 INTEGER :: handle, ierr
13467#if defined(__parallel)
13468 INTEGER :: msglen, my_tag
13469 INTEGER(KIND=int_8) :: foo(1)
13470#endif
13471
13472 CALL mp_timeset(routinen, handle)
13473
13474#if defined(__parallel)
13475#if !defined(__GNUC__) || __GNUC__ >= 9
13476 cpassert(is_contiguous(msgin))
13477#endif
13478
13479 my_tag = 0
13480 IF (PRESENT(tag)) my_tag = tag
13481
13482 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
13483 IF (msglen > 0) THEN
13484 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_integer8, dest, my_tag, &
13485 comm%handle, request%handle, ierr)
13486 ELSE
13487 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13488 comm%handle, request%handle, ierr)
13489 END IF
13490 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13491
13492 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13493#else
13494 mark_used(msgin)
13495 mark_used(dest)
13496 mark_used(comm)
13497 mark_used(request)
13498 mark_used(tag)
13499 ierr = 1
13500 request = mp_request_null
13501 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13502#endif
13503 CALL mp_timestop(handle)
13504 END SUBROUTINE mp_isend_lm3
13505
13506! **************************************************************************************************
13507!> \brief Non-blocking send of rank-4 data
13508!> \param msgin the input message
13509!> \param dest the destination processor
13510!> \param comm the communicator object
13511!> \param request the communication request id
13512!> \param tag the message tag
13513!> \par History
13514!> 2.2016 added _lm4 subroutine [Nico Holmberg]
13515!> \author fawzi
13516!> \note see mp_isend_lv
13517!> \note
13518!> arrays can be pointers or assumed shape, but they must be contiguous!
13519! **************************************************************************************************
13520 SUBROUTINE mp_isend_lm4(msgin, dest, comm, request, tag)
13521 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
13522 INTEGER, INTENT(IN) :: dest
13523 CLASS(mp_comm_type), INTENT(IN) :: comm
13524 TYPE(mp_request_type), INTENT(out) :: request
13525 INTEGER, INTENT(in), OPTIONAL :: tag
13526
13527 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm4'
13528
13529 INTEGER :: handle, ierr
13530#if defined(__parallel)
13531 INTEGER :: msglen, my_tag
13532 INTEGER(KIND=int_8) :: foo(1)
13533#endif
13534
13535 CALL mp_timeset(routinen, handle)
13536
13537#if defined(__parallel)
13538#if !defined(__GNUC__) || __GNUC__ >= 9
13539 cpassert(is_contiguous(msgin))
13540#endif
13541
13542 my_tag = 0
13543 IF (PRESENT(tag)) my_tag = tag
13544
13545 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
13546 IF (msglen > 0) THEN
13547 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_integer8, dest, my_tag, &
13548 comm%handle, request%handle, ierr)
13549 ELSE
13550 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13551 comm%handle, request%handle, ierr)
13552 END IF
13553 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13554
13555 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13556#else
13557 mark_used(msgin)
13558 mark_used(dest)
13559 mark_used(comm)
13560 mark_used(request)
13561 mark_used(tag)
13562 ierr = 1
13563 request = mp_request_null
13564 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13565#endif
13566 CALL mp_timestop(handle)
13567 END SUBROUTINE mp_isend_lm4
13568
13569! **************************************************************************************************
13570!> \brief Non-blocking receive of vector data
13571!> \param msgout ...
13572!> \param source ...
13573!> \param comm ...
13574!> \param request ...
13575!> \param tag ...
13576!> \par History
13577!> 08.2003 created [f&j]
13578!> 2009-11-25 [UB] Made type-generic for templates
13579!> \note see mp_isendrecv_lv
13580!> \note
13581!> arrays can be pointers or assumed shape, but they must be contiguous!
13582! **************************************************************************************************
13583 SUBROUTINE mp_irecv_lv(msgout, source, comm, request, tag)
13584 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT) :: msgout
13585 INTEGER, INTENT(IN) :: source
13586 CLASS(mp_comm_type), INTENT(IN) :: comm
13587 TYPE(mp_request_type), INTENT(out) :: request
13588 INTEGER, INTENT(in), OPTIONAL :: tag
13589
13590 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lv'
13591
13592 INTEGER :: handle
13593#if defined(__parallel)
13594 INTEGER :: ierr, msglen, my_tag
13595 INTEGER(KIND=int_8) :: foo(1)
13596#endif
13597
13598 CALL mp_timeset(routinen, handle)
13599
13600#if defined(__parallel)
13601#if !defined(__GNUC__) || __GNUC__ >= 9
13602 cpassert(is_contiguous(msgout))
13603#endif
13604
13605 my_tag = 0
13606 IF (PRESENT(tag)) my_tag = tag
13607
13608 msglen = SIZE(msgout)
13609 IF (msglen > 0) THEN
13610 CALL mpi_irecv(msgout(1), msglen, mpi_integer8, source, my_tag, &
13611 comm%handle, request%handle, ierr)
13612 ELSE
13613 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13614 comm%handle, request%handle, ierr)
13615 END IF
13616 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13617
13618 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13619#else
13620 cpabort("mp_irecv called in non parallel case")
13621 mark_used(msgout)
13622 mark_used(source)
13623 mark_used(comm)
13624 mark_used(tag)
13625 request = mp_request_null
13626#endif
13627 CALL mp_timestop(handle)
13628 END SUBROUTINE mp_irecv_lv
13629
13630! **************************************************************************************************
13631!> \brief Non-blocking receive of matrix data
13632!> \param msgout ...
13633!> \param source ...
13634!> \param comm ...
13635!> \param request ...
13636!> \param tag ...
13637!> \par History
13638!> 2009-11-25 [UB] Made type-generic for templates
13639!> \author fawzi
13640!> \note see mp_isendrecv_lv
13641!> \note see mp_irecv_lv
13642!> \note
13643!> arrays can be pointers or assumed shape, but they must be contiguous!
13644! **************************************************************************************************
13645 SUBROUTINE mp_irecv_lm2(msgout, source, comm, request, tag)
13646 INTEGER(KIND=int_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
13647 INTEGER, INTENT(IN) :: source
13648 CLASS(mp_comm_type), INTENT(IN) :: comm
13649 TYPE(mp_request_type), INTENT(out) :: request
13650 INTEGER, INTENT(in), OPTIONAL :: tag
13651
13652 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm2'
13653
13654 INTEGER :: handle
13655#if defined(__parallel)
13656 INTEGER :: ierr, msglen, my_tag
13657 INTEGER(KIND=int_8) :: foo(1)
13658#endif
13659
13660 CALL mp_timeset(routinen, handle)
13661
13662#if defined(__parallel)
13663#if !defined(__GNUC__) || __GNUC__ >= 9
13664 cpassert(is_contiguous(msgout))
13665#endif
13666
13667 my_tag = 0
13668 IF (PRESENT(tag)) my_tag = tag
13669
13670 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
13671 IF (msglen > 0) THEN
13672 CALL mpi_irecv(msgout(1, 1), msglen, mpi_integer8, source, my_tag, &
13673 comm%handle, request%handle, ierr)
13674 ELSE
13675 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13676 comm%handle, request%handle, ierr)
13677 END IF
13678 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13679
13680 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13681#else
13682 mark_used(msgout)
13683 mark_used(source)
13684 mark_used(comm)
13685 mark_used(tag)
13686 request = mp_request_null
13687 cpabort("mp_irecv called in non parallel case")
13688#endif
13689 CALL mp_timestop(handle)
13690 END SUBROUTINE mp_irecv_lm2
13691
13692! **************************************************************************************************
13693!> \brief Non-blocking send of rank-3 data
13694!> \param msgout ...
13695!> \param source ...
13696!> \param comm ...
13697!> \param request ...
13698!> \param tag ...
13699!> \par History
13700!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
13701!> 2009-11-25 [UB] Made type-generic for templates
13702!> \author fawzi
13703!> \note see mp_isendrecv_lv
13704!> \note see mp_irecv_lv
13705!> \note
13706!> arrays can be pointers or assumed shape, but they must be contiguous!
13707! **************************************************************************************************
13708 SUBROUTINE mp_irecv_lm3(msgout, source, comm, request, tag)
13709 INTEGER(KIND=int_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
13710 INTEGER, INTENT(IN) :: source
13711 CLASS(mp_comm_type), INTENT(IN) :: comm
13712 TYPE(mp_request_type), INTENT(out) :: request
13713 INTEGER, INTENT(in), OPTIONAL :: tag
13714
13715 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm3'
13716
13717 INTEGER :: handle
13718#if defined(__parallel)
13719 INTEGER :: ierr, msglen, my_tag
13720 INTEGER(KIND=int_8) :: foo(1)
13721#endif
13722
13723 CALL mp_timeset(routinen, handle)
13724
13725#if defined(__parallel)
13726#if !defined(__GNUC__) || __GNUC__ >= 9
13727 cpassert(is_contiguous(msgout))
13728#endif
13729
13730 my_tag = 0
13731 IF (PRESENT(tag)) my_tag = tag
13732
13733 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
13734 IF (msglen > 0) THEN
13735 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_integer8, source, my_tag, &
13736 comm%handle, request%handle, ierr)
13737 ELSE
13738 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13739 comm%handle, request%handle, ierr)
13740 END IF
13741 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
13742
13743 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13744#else
13745 mark_used(msgout)
13746 mark_used(source)
13747 mark_used(comm)
13748 mark_used(tag)
13749 request = mp_request_null
13750 cpabort("mp_irecv called in non parallel case")
13751#endif
13752 CALL mp_timestop(handle)
13753 END SUBROUTINE mp_irecv_lm3
13754
13755! **************************************************************************************************
13756!> \brief Non-blocking receive of rank-4 data
13757!> \param msgout the output message
13758!> \param source the source processor
13759!> \param comm the communicator object
13760!> \param request the communication request id
13761!> \param tag the message tag
13762!> \par History
13763!> 2.2016 added _lm4 subroutine [Nico Holmberg]
13764!> \author fawzi
13765!> \note see mp_irecv_lv
13766!> \note
13767!> arrays can be pointers or assumed shape, but they must be contiguous!
13768! **************************************************************************************************
13769 SUBROUTINE mp_irecv_lm4(msgout, source, comm, request, tag)
13770 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
13771 INTEGER, INTENT(IN) :: source
13772 CLASS(mp_comm_type), INTENT(IN) :: comm
13773 TYPE(mp_request_type), INTENT(out) :: request
13774 INTEGER, INTENT(in), OPTIONAL :: tag
13775
13776 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm4'
13777
13778 INTEGER :: handle
13779#if defined(__parallel)
13780 INTEGER :: ierr, msglen, my_tag
13781 INTEGER(KIND=int_8) :: foo(1)
13782#endif
13783
13784 CALL mp_timeset(routinen, handle)
13785
13786#if defined(__parallel)
13787#if !defined(__GNUC__) || __GNUC__ >= 9
13788 cpassert(is_contiguous(msgout))
13789#endif
13790
13791 my_tag = 0
13792 IF (PRESENT(tag)) my_tag = tag
13793
13794 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
13795 IF (msglen > 0) THEN
13796 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_integer8, source, my_tag, &
13797 comm%handle, request%handle, ierr)
13798 ELSE
13799 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13800 comm%handle, request%handle, ierr)
13801 END IF
13802 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
13803
13804 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13805#else
13806 mark_used(msgout)
13807 mark_used(source)
13808 mark_used(comm)
13809 mark_used(tag)
13810 request = mp_request_null
13811 cpabort("mp_irecv called in non parallel case")
13812#endif
13813 CALL mp_timestop(handle)
13814 END SUBROUTINE mp_irecv_lm4
13815
13816! **************************************************************************************************
13817!> \brief Window initialization function for vector data
13818!> \param base ...
13819!> \param comm ...
13820!> \param win ...
13821!> \par History
13822!> 02.2015 created [Alfio Lazzaro]
13823!> \note
13824!> arrays can be pointers or assumed shape, but they must be contiguous!
13825! **************************************************************************************************
13826 SUBROUTINE mp_win_create_lv(base, comm, win)
13827 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
13828 TYPE(mp_comm_type), INTENT(IN) :: comm
13829 CLASS(mp_win_type), INTENT(INOUT) :: win
13830
13831 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_lv'
13832
13833 INTEGER :: handle
13834#if defined(__parallel)
13835 INTEGER :: ierr
13836 INTEGER(kind=mpi_address_kind) :: len
13837 INTEGER(KIND=int_8) :: foo(1)
13838#endif
13839
13840 CALL mp_timeset(routinen, handle)
13841
13842#if defined(__parallel)
13843
13844 len = SIZE(base)*int_8_size
13845 IF (len > 0) THEN
13846 CALL mpi_win_create(base(1), len, int_8_size, mpi_info_null, comm%handle, win%handle, ierr)
13847 ELSE
13848 CALL mpi_win_create(foo, len, int_8_size, mpi_info_null, comm%handle, win%handle, ierr)
13849 END IF
13850 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
13851
13852 CALL add_perf(perf_id=20, count=1)
13853#else
13854 mark_used(base)
13855 mark_used(comm)
13856 win%handle = mp_win_null_handle
13857#endif
13858 CALL mp_timestop(handle)
13859 END SUBROUTINE mp_win_create_lv
13860
13861! **************************************************************************************************
13862!> \brief Single-sided get function for vector data
13863!> \param base ...
13864!> \param comm ...
13865!> \param win ...
13866!> \par History
13867!> 02.2015 created [Alfio Lazzaro]
13868!> \note
13869!> arrays can be pointers or assumed shape, but they must be contiguous!
13870! **************************************************************************************************
13871 SUBROUTINE mp_rget_lv(base, source, win, win_data, myproc, disp, request, &
13872 origin_datatype, target_datatype)
13873 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
13874 INTEGER, INTENT(IN) :: source
13875 CLASS(mp_win_type), INTENT(IN) :: win
13876 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: win_data
13877 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
13878 TYPE(mp_request_type), INTENT(OUT) :: request
13879 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
13880
13881 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_lv'
13882
13883 INTEGER :: handle
13884#if defined(__parallel)
13885 INTEGER :: ierr, len, &
13886 origin_len, target_len
13887 LOGICAL :: do_local_copy
13888 INTEGER(kind=mpi_address_kind) :: disp_aint
13889 mpi_data_type :: handle_origin_datatype, handle_target_datatype
13890#endif
13891
13892 CALL mp_timeset(routinen, handle)
13893
13894#if defined(__parallel)
13895 len = SIZE(base)
13896 disp_aint = 0
13897 IF (PRESENT(disp)) THEN
13898 disp_aint = int(disp, kind=mpi_address_kind)
13899 END IF
13900 handle_origin_datatype = mpi_integer8
13901 origin_len = len
13902 IF (PRESENT(origin_datatype)) THEN
13903 handle_origin_datatype = origin_datatype%type_handle
13904 origin_len = 1
13905 END IF
13906 handle_target_datatype = mpi_integer8
13907 target_len = len
13908 IF (PRESENT(target_datatype)) THEN
13909 handle_target_datatype = target_datatype%type_handle
13910 target_len = 1
13911 END IF
13912 IF (len > 0) THEN
13913 do_local_copy = .false.
13914 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
13915 IF (myproc .EQ. source) do_local_copy = .true.
13916 END IF
13917 IF (do_local_copy) THEN
13918 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
13919 base(:) = win_data(disp_aint + 1:disp_aint + len)
13920 !$OMP END PARALLEL WORKSHARE
13921 request = mp_request_null
13922 ierr = 0
13923 ELSE
13924 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
13925 target_len, handle_target_datatype, win%handle, request%handle, ierr)
13926 END IF
13927 ELSE
13928 request = mp_request_null
13929 ierr = 0
13930 END IF
13931 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
13932
13933 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*int_8_size)
13934#else
13935 mark_used(source)
13936 mark_used(win)
13937 mark_used(myproc)
13938 mark_used(origin_datatype)
13939 mark_used(target_datatype)
13940
13941 request = mp_request_null
13942 !
13943 IF (PRESENT(disp)) THEN
13944 base(:) = win_data(disp + 1:disp + SIZE(base))
13945 ELSE
13946 base(:) = win_data(:SIZE(base))
13947 END IF
13948
13949#endif
13950 CALL mp_timestop(handle)
13951 END SUBROUTINE mp_rget_lv
13952
13953! **************************************************************************************************
13954!> \brief ...
13955!> \param count ...
13956!> \param lengths ...
13957!> \param displs ...
13958!> \return ...
13959! ***************************************************************************
13960 FUNCTION mp_type_indexed_make_l (count, lengths, displs) &
13961 result(type_descriptor)
13962 INTEGER, INTENT(IN) :: count
13963 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
13964 TYPE(mp_type_descriptor_type) :: type_descriptor
13965
13966 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_l'
13967
13968 INTEGER :: handle
13969#if defined(__parallel)
13970 INTEGER :: ierr
13971#endif
13972
13973 CALL mp_timeset(routinen, handle)
13974
13975#if defined(__parallel)
13976 CALL mpi_type_indexed(count, lengths, displs, mpi_integer8, &
13977 type_descriptor%type_handle, ierr)
13978 IF (ierr /= 0) &
13979 cpabort("MPI_Type_Indexed @ "//routinen)
13980 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
13981 IF (ierr /= 0) &
13982 cpabort("MPI_Type_commit @ "//routinen)
13983#else
13984 type_descriptor%type_handle = 19
13985#endif
13986 type_descriptor%length = count
13987 NULLIFY (type_descriptor%subtype)
13988 type_descriptor%vector_descriptor(1:2) = 1
13989 type_descriptor%has_indexing = .true.
13990 type_descriptor%index_descriptor%index => lengths
13991 type_descriptor%index_descriptor%chunks => displs
13992
13993 CALL mp_timestop(handle)
13994
13995 END FUNCTION mp_type_indexed_make_l
13996
13997! **************************************************************************************************
13998!> \brief Allocates special parallel memory
13999!> \param[in] DATA pointer to integer array to allocate
14000!> \param[in] len number of integers to allocate
14001!> \param[out] stat (optional) allocation status result
14002!> \author UB
14003! **************************************************************************************************
14004 SUBROUTINE mp_allocate_l (DATA, len, stat)
14005 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
14006 INTEGER, INTENT(IN) :: len
14007 INTEGER, INTENT(OUT), OPTIONAL :: stat
14008
14009 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_l'
14010
14011 INTEGER :: handle, ierr
14012
14013 CALL mp_timeset(routinen, handle)
14014
14015#if defined(__parallel)
14016 NULLIFY (data)
14017 CALL mp_alloc_mem(DATA, len, stat=ierr)
14018 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
14019 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
14020 CALL add_perf(perf_id=15, count=1)
14021#else
14022 ALLOCATE (DATA(len), stat=ierr)
14023 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
14024 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
14025#endif
14026 IF (PRESENT(stat)) stat = ierr
14027 CALL mp_timestop(handle)
14028 END SUBROUTINE mp_allocate_l
14029
14030! **************************************************************************************************
14031!> \brief Deallocates special parallel memory
14032!> \param[in] DATA pointer to special memory to deallocate
14033!> \param stat ...
14034!> \author UB
14035! **************************************************************************************************
14036 SUBROUTINE mp_deallocate_l (DATA, stat)
14037 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
14038 INTEGER, INTENT(OUT), OPTIONAL :: stat
14039
14040 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_l'
14041
14042 INTEGER :: handle
14043#if defined(__parallel)
14044 INTEGER :: ierr
14045#endif
14046
14047 CALL mp_timeset(routinen, handle)
14048
14049#if defined(__parallel)
14050 CALL mp_free_mem(DATA, ierr)
14051 IF (PRESENT(stat)) THEN
14052 stat = ierr
14053 ELSE
14054 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
14055 END IF
14056 NULLIFY (data)
14057 CALL add_perf(perf_id=15, count=1)
14058#else
14059 DEALLOCATE (data)
14060 IF (PRESENT(stat)) stat = 0
14061#endif
14062 CALL mp_timestop(handle)
14063 END SUBROUTINE mp_deallocate_l
14064
14065! **************************************************************************************************
14066!> \brief (parallel) Blocking individual file write using explicit offsets
14067!> (serial) Unformatted stream write
14068!> \param[in] fh file handle (file storage unit)
14069!> \param[in] offset file offset (position)
14070!> \param[in] msg data to be written to the file
14071!> \param msglen ...
14072!> \par MPI-I/O mapping mpi_file_write_at
14073!> \par STREAM-I/O mapping WRITE
14074!> \param[in](optional) msglen number of the elements of data
14075! **************************************************************************************************
14076 SUBROUTINE mp_file_write_at_lv(fh, offset, msg, msglen)
14077 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
14078 CLASS(mp_file_type), INTENT(IN) :: fh
14079 INTEGER, INTENT(IN), OPTIONAL :: msglen
14080 INTEGER(kind=file_offset), INTENT(IN) :: offset
14081
14082 INTEGER :: msg_len
14083#if defined(__parallel)
14084 INTEGER :: ierr
14085#endif
14086
14087 msg_len = SIZE(msg)
14088 IF (PRESENT(msglen)) msg_len = msglen
14089#if defined(__parallel)
14090 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14091 IF (ierr .NE. 0) &
14092 cpabort("mpi_file_write_at_lv @ mp_file_write_at_lv")
14093#else
14094 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14095#endif
14096 END SUBROUTINE mp_file_write_at_lv
14097
14098! **************************************************************************************************
14099!> \brief ...
14100!> \param fh ...
14101!> \param offset ...
14102!> \param msg ...
14103! **************************************************************************************************
14104 SUBROUTINE mp_file_write_at_l (fh, offset, msg)
14105 INTEGER(KIND=int_8), INTENT(IN) :: msg
14106 CLASS(mp_file_type), INTENT(IN) :: fh
14107 INTEGER(kind=file_offset), INTENT(IN) :: offset
14108
14109#if defined(__parallel)
14110 INTEGER :: ierr
14111
14112 ierr = 0
14113 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14114 IF (ierr .NE. 0) &
14115 cpabort("mpi_file_write_at_l @ mp_file_write_at_l")
14116#else
14117 WRITE (unit=fh%handle, pos=offset + 1) msg
14118#endif
14119 END SUBROUTINE mp_file_write_at_l
14120
14121! **************************************************************************************************
14122!> \brief (parallel) Blocking collective file write using explicit offsets
14123!> (serial) Unformatted stream write
14124!> \param fh ...
14125!> \param offset ...
14126!> \param msg ...
14127!> \param msglen ...
14128!> \par MPI-I/O mapping mpi_file_write_at_all
14129!> \par STREAM-I/O mapping WRITE
14130! **************************************************************************************************
14131 SUBROUTINE mp_file_write_at_all_lv(fh, offset, msg, msglen)
14132 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
14133 CLASS(mp_file_type), INTENT(IN) :: fh
14134 INTEGER, INTENT(IN), OPTIONAL :: msglen
14135 INTEGER(kind=file_offset), INTENT(IN) :: offset
14136
14137 INTEGER :: msg_len
14138#if defined(__parallel)
14139 INTEGER :: ierr
14140#endif
14141
14142 msg_len = SIZE(msg)
14143 IF (PRESENT(msglen)) msg_len = msglen
14144#if defined(__parallel)
14145 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14146 IF (ierr .NE. 0) &
14147 cpabort("mpi_file_write_at_all_lv @ mp_file_write_at_all_lv")
14148#else
14149 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14150#endif
14151 END SUBROUTINE mp_file_write_at_all_lv
14152
14153! **************************************************************************************************
14154!> \brief ...
14155!> \param fh ...
14156!> \param offset ...
14157!> \param msg ...
14158! **************************************************************************************************
14159 SUBROUTINE mp_file_write_at_all_l (fh, offset, msg)
14160 INTEGER(KIND=int_8), INTENT(IN) :: msg
14161 CLASS(mp_file_type), INTENT(IN) :: fh
14162 INTEGER(kind=file_offset), INTENT(IN) :: offset
14163
14164#if defined(__parallel)
14165 INTEGER :: ierr
14166
14167 ierr = 0
14168 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14169 IF (ierr .NE. 0) &
14170 cpabort("mpi_file_write_at_all_l @ mp_file_write_at_all_l")
14171#else
14172 WRITE (unit=fh%handle, pos=offset + 1) msg
14173#endif
14174 END SUBROUTINE mp_file_write_at_all_l
14175
14176! **************************************************************************************************
14177!> \brief (parallel) Blocking individual file read using explicit offsets
14178!> (serial) Unformatted stream read
14179!> \param[in] fh file handle (file storage unit)
14180!> \param[in] offset file offset (position)
14181!> \param[out] msg data to be read from the file
14182!> \param msglen ...
14183!> \par MPI-I/O mapping mpi_file_read_at
14184!> \par STREAM-I/O mapping READ
14185!> \param[in](optional) msglen number of elements of data
14186! **************************************************************************************************
14187 SUBROUTINE mp_file_read_at_lv(fh, offset, msg, msglen)
14188 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msg(:)
14189 CLASS(mp_file_type), INTENT(IN) :: fh
14190 INTEGER, INTENT(IN), OPTIONAL :: msglen
14191 INTEGER(kind=file_offset), INTENT(IN) :: offset
14192
14193 INTEGER :: msg_len
14194#if defined(__parallel)
14195 INTEGER :: ierr
14196#endif
14197
14198 msg_len = SIZE(msg)
14199 IF (PRESENT(msglen)) msg_len = msglen
14200#if defined(__parallel)
14201 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14202 IF (ierr .NE. 0) &
14203 cpabort("mpi_file_read_at_lv @ mp_file_read_at_lv")
14204#else
14205 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14206#endif
14207 END SUBROUTINE mp_file_read_at_lv
14208
14209! **************************************************************************************************
14210!> \brief ...
14211!> \param fh ...
14212!> \param offset ...
14213!> \param msg ...
14214! **************************************************************************************************
14215 SUBROUTINE mp_file_read_at_l (fh, offset, msg)
14216 INTEGER(KIND=int_8), INTENT(OUT) :: msg
14217 CLASS(mp_file_type), INTENT(IN) :: fh
14218 INTEGER(kind=file_offset), INTENT(IN) :: offset
14219
14220#if defined(__parallel)
14221 INTEGER :: ierr
14222
14223 ierr = 0
14224 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14225 IF (ierr .NE. 0) &
14226 cpabort("mpi_file_read_at_l @ mp_file_read_at_l")
14227#else
14228 READ (unit=fh%handle, pos=offset + 1) msg
14229#endif
14230 END SUBROUTINE mp_file_read_at_l
14231
14232! **************************************************************************************************
14233!> \brief (parallel) Blocking collective file read using explicit offsets
14234!> (serial) Unformatted stream read
14235!> \param fh ...
14236!> \param offset ...
14237!> \param msg ...
14238!> \param msglen ...
14239!> \par MPI-I/O mapping mpi_file_read_at_all
14240!> \par STREAM-I/O mapping READ
14241! **************************************************************************************************
14242 SUBROUTINE mp_file_read_at_all_lv(fh, offset, msg, msglen)
14243 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msg(:)
14244 CLASS(mp_file_type), INTENT(IN) :: fh
14245 INTEGER, INTENT(IN), OPTIONAL :: msglen
14246 INTEGER(kind=file_offset), INTENT(IN) :: offset
14247
14248 INTEGER :: msg_len
14249#if defined(__parallel)
14250 INTEGER :: ierr
14251#endif
14252
14253 msg_len = SIZE(msg)
14254 IF (PRESENT(msglen)) msg_len = msglen
14255#if defined(__parallel)
14256 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14257 IF (ierr .NE. 0) &
14258 cpabort("mpi_file_read_at_all_lv @ mp_file_read_at_all_lv")
14259#else
14260 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14261#endif
14262 END SUBROUTINE mp_file_read_at_all_lv
14263
14264! **************************************************************************************************
14265!> \brief ...
14266!> \param fh ...
14267!> \param offset ...
14268!> \param msg ...
14269! **************************************************************************************************
14270 SUBROUTINE mp_file_read_at_all_l (fh, offset, msg)
14271 INTEGER(KIND=int_8), INTENT(OUT) :: msg
14272 CLASS(mp_file_type), INTENT(IN) :: fh
14273 INTEGER(kind=file_offset), INTENT(IN) :: offset
14274
14275#if defined(__parallel)
14276 INTEGER :: ierr
14277
14278 ierr = 0
14279 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14280 IF (ierr .NE. 0) &
14281 cpabort("mpi_file_read_at_all_l @ mp_file_read_at_all_l")
14282#else
14283 READ (unit=fh%handle, pos=offset + 1) msg
14284#endif
14285 END SUBROUTINE mp_file_read_at_all_l
14286
14287! **************************************************************************************************
14288!> \brief ...
14289!> \param ptr ...
14290!> \param vector_descriptor ...
14291!> \param index_descriptor ...
14292!> \return ...
14293! **************************************************************************************************
14294 FUNCTION mp_type_make_l (ptr, &
14295 vector_descriptor, index_descriptor) &
14296 result(type_descriptor)
14297 INTEGER(KIND=int_8), DIMENSION(:), TARGET, asynchronous :: ptr
14298 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
14299 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
14300 TYPE(mp_type_descriptor_type) :: type_descriptor
14301
14302 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_l'
14303
14304#if defined(__parallel)
14305 INTEGER :: ierr
14306#endif
14307
14308 NULLIFY (type_descriptor%subtype)
14309 type_descriptor%length = SIZE(ptr)
14310#if defined(__parallel)
14311 type_descriptor%type_handle = mpi_integer8
14312 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
14313 IF (ierr /= 0) &
14314 cpabort("MPI_Get_address @ "//routinen)
14315#else
14316 type_descriptor%type_handle = 19
14317#endif
14318 type_descriptor%vector_descriptor(1:2) = 1
14319 type_descriptor%has_indexing = .false.
14320 type_descriptor%data_l => ptr
14321 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
14322 cpabort(routinen//": Vectors and indices NYI")
14323 END IF
14324 END FUNCTION mp_type_make_l
14325
14326! **************************************************************************************************
14327!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
14328!> as the Fortran version returns an integer, which we take to be a C_PTR
14329!> \param DATA data array to allocate
14330!> \param[in] len length (in data elements) of data array allocation
14331!> \param[out] stat (optional) allocation status result
14332! **************************************************************************************************
14333 SUBROUTINE mp_alloc_mem_l (DATA, len, stat)
14334 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: data
14335 INTEGER, INTENT(IN) :: len
14336 INTEGER, INTENT(OUT), OPTIONAL :: stat
14337
14338#if defined(__parallel)
14339 INTEGER :: size, ierr, length, &
14340 mp_res
14341 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
14342 TYPE(c_ptr) :: mp_baseptr
14343 mpi_info_type :: mp_info
14344
14345 length = max(len, 1)
14346 CALL mpi_type_size(mpi_integer8, size, ierr)
14347 mp_size = int(length, kind=mpi_address_kind)*size
14348 IF (mp_size .GT. mp_max_memory_size) THEN
14349 cpabort("MPI cannot allocate more than 2 GiByte")
14350 END IF
14351 mp_info = mpi_info_null
14352 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
14353 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
14354 IF (PRESENT(stat)) stat = mp_res
14355#else
14356 INTEGER :: length, mystat
14357 length = max(len, 1)
14358 IF (PRESENT(stat)) THEN
14359 ALLOCATE (DATA(length), stat=mystat)
14360 stat = mystat ! show to convention checker that stat is used
14361 ELSE
14362 ALLOCATE (DATA(length))
14363 END IF
14364#endif
14365 END SUBROUTINE mp_alloc_mem_l
14366
14367! **************************************************************************************************
14368!> \brief Deallocates am array, ... this is hackish
14369!> as the Fortran version takes an integer, which we hope to get by reference
14370!> \param DATA data array to allocate
14371!> \param[out] stat (optional) allocation status result
14372! **************************************************************************************************
14373 SUBROUTINE mp_free_mem_l (DATA, stat)
14374 INTEGER(KIND=int_8), DIMENSION(:), &
14375 POINTER, asynchronous :: data
14376 INTEGER, INTENT(OUT), OPTIONAL :: stat
14377
14378#if defined(__parallel)
14379 INTEGER :: mp_res
14380 CALL mpi_free_mem(DATA, mp_res)
14381 IF (PRESENT(stat)) stat = mp_res
14382#else
14383 DEALLOCATE (data)
14384 IF (PRESENT(stat)) stat = 0
14385#endif
14386 END SUBROUTINE mp_free_mem_l
14387! **************************************************************************************************
14388!> \brief Shift around the data in msg
14389!> \param[in,out] msg Rank-2 data to shift
14390!> \param[in] comm message passing environment identifier
14391!> \param[in] displ_in displacements (?)
14392!> \par Example
14393!> msg will be moved from rank to rank+displ_in (in a circular way)
14394!> \par Limitations
14395!> * displ_in will be 1 by default (others not tested)
14396!> * the message array needs to be the same size on all processes
14397! **************************************************************************************************
14398 SUBROUTINE mp_shift_dm(msg, comm, displ_in)
14399
14400 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
14401 CLASS(mp_comm_type), INTENT(IN) :: comm
14402 INTEGER, INTENT(IN), OPTIONAL :: displ_in
14403
14404 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_dm'
14405
14406 INTEGER :: handle, ierror
14407#if defined(__parallel)
14408 INTEGER :: displ, left, &
14409 msglen, myrank, nprocs, &
14410 right, tag
14411#endif
14412
14413 ierror = 0
14414 CALL mp_timeset(routinen, handle)
14415
14416#if defined(__parallel)
14417 CALL mpi_comm_rank(comm%handle, myrank, ierror)
14418 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
14419 CALL mpi_comm_size(comm%handle, nprocs, ierror)
14420 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
14421 IF (PRESENT(displ_in)) THEN
14422 displ = displ_in
14423 ELSE
14424 displ = 1
14425 END IF
14426 right = modulo(myrank + displ, nprocs)
14427 left = modulo(myrank - displ, nprocs)
14428 tag = 17
14429 msglen = SIZE(msg)
14430 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_precision, right, tag, left, tag, &
14431 comm%handle, mpi_status_ignore, ierror)
14432 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
14433 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_8_size)
14434#else
14435 mark_used(msg)
14436 mark_used(comm)
14437 mark_used(displ_in)
14438#endif
14439 CALL mp_timestop(handle)
14440
14441 END SUBROUTINE mp_shift_dm
14442
14443! **************************************************************************************************
14444!> \brief Shift around the data in msg
14445!> \param[in,out] msg Data to shift
14446!> \param[in] comm message passing environment identifier
14447!> \param[in] displ_in displacements (?)
14448!> \par Example
14449!> msg will be moved from rank to rank+displ_in (in a circular way)
14450!> \par Limitations
14451!> * displ_in will be 1 by default (others not tested)
14452!> * the message array needs to be the same size on all processes
14453! **************************************************************************************************
14454 SUBROUTINE mp_shift_d (msg, comm, displ_in)
14455
14456 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
14457 CLASS(mp_comm_type), INTENT(IN) :: comm
14458 INTEGER, INTENT(IN), OPTIONAL :: displ_in
14459
14460 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_d'
14461
14462 INTEGER :: handle, ierror
14463#if defined(__parallel)
14464 INTEGER :: displ, left, &
14465 msglen, myrank, nprocs, &
14466 right, tag
14467#endif
14468
14469 ierror = 0
14470 CALL mp_timeset(routinen, handle)
14471
14472#if defined(__parallel)
14473 CALL mpi_comm_rank(comm%handle, myrank, ierror)
14474 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
14475 CALL mpi_comm_size(comm%handle, nprocs, ierror)
14476 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
14477 IF (PRESENT(displ_in)) THEN
14478 displ = displ_in
14479 ELSE
14480 displ = 1
14481 END IF
14482 right = modulo(myrank + displ, nprocs)
14483 left = modulo(myrank - displ, nprocs)
14484 tag = 19
14485 msglen = SIZE(msg)
14486 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_precision, right, tag, left, &
14487 tag, comm%handle, mpi_status_ignore, ierror)
14488 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
14489 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_8_size)
14490#else
14491 mark_used(msg)
14492 mark_used(comm)
14493 mark_used(displ_in)
14494#endif
14495 CALL mp_timestop(handle)
14496
14497 END SUBROUTINE mp_shift_d
14498
14499! **************************************************************************************************
14500!> \brief All-to-all data exchange, rank-1 data of different sizes
14501!> \param[in] sb Data to send
14502!> \param[in] scount Data counts for data sent to other processes
14503!> \param[in] sdispl Respective data offsets for data sent to process
14504!> \param[in,out] rb Buffer into which to receive data
14505!> \param[in] rcount Data counts for data received from other
14506!> processes
14507!> \param[in] rdispl Respective data offsets for data received from
14508!> other processes
14509!> \param[in] comm Message passing environment identifier
14510!> \par MPI mapping
14511!> mpi_alltoallv
14512!> \par Array sizes
14513!> The scount, rcount, and the sdispl and rdispl arrays have a
14514!> size equal to the number of processes.
14515!> \par Offsets
14516!> Values in sdispl and rdispl start with 0.
14517! **************************************************************************************************
14518 SUBROUTINE mp_alltoall_d11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
14519
14520 REAL(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
14521 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
14522 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
14523 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
14524 CLASS(mp_comm_type), INTENT(IN) :: comm
14525
14526 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d11v'
14527
14528 INTEGER :: handle
14529#if defined(__parallel)
14530 INTEGER :: ierr, msglen
14531#else
14532 INTEGER :: i
14533#endif
14534
14535 CALL mp_timeset(routinen, handle)
14536
14537#if defined(__parallel)
14538 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_precision, &
14539 rb, rcount, rdispl, mpi_double_precision, comm%handle, ierr)
14540 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
14541 msglen = sum(scount) + sum(rcount)
14542 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14543#else
14544 mark_used(comm)
14545 mark_used(scount)
14546 mark_used(sdispl)
14547 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
14548 DO i = 1, rcount(1)
14549 rb(rdispl(1) + i) = sb(sdispl(1) + i)
14550 END DO
14551#endif
14552 CALL mp_timestop(handle)
14553
14554 END SUBROUTINE mp_alltoall_d11v
14555
14556! **************************************************************************************************
14557!> \brief All-to-all data exchange, rank-2 data of different sizes
14558!> \param sb ...
14559!> \param scount ...
14560!> \param sdispl ...
14561!> \param rb ...
14562!> \param rcount ...
14563!> \param rdispl ...
14564!> \param comm ...
14565!> \par MPI mapping
14566!> mpi_alltoallv
14567!> \note see mp_alltoall_d11v
14568! **************************************************************************************************
14569 SUBROUTINE mp_alltoall_d22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
14570
14571 REAL(kind=real_8), DIMENSION(:, :), &
14572 INTENT(IN), CONTIGUOUS :: sb
14573 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
14574 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, &
14575 INTENT(INOUT) :: rb
14576 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
14577 CLASS(mp_comm_type), INTENT(IN) :: comm
14578
14579 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d22v'
14580
14581 INTEGER :: handle
14582#if defined(__parallel)
14583 INTEGER :: ierr, msglen
14584#endif
14585
14586 CALL mp_timeset(routinen, handle)
14587
14588#if defined(__parallel)
14589 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_precision, &
14590 rb, rcount, rdispl, mpi_double_precision, comm%handle, ierr)
14591 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
14592 msglen = sum(scount) + sum(rcount)
14593 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*real_8_size)
14594#else
14595 mark_used(comm)
14596 mark_used(scount)
14597 mark_used(sdispl)
14598 mark_used(rcount)
14599 mark_used(rdispl)
14600 rb = sb
14601#endif
14602 CALL mp_timestop(handle)
14603
14604 END SUBROUTINE mp_alltoall_d22v
14605
14606! **************************************************************************************************
14607!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
14608!> \param[in] sb array with data to send
14609!> \param[out] rb array into which data is received
14610!> \param[in] count number of elements to send/receive (product of the
14611!> extents of the first two dimensions)
14612!> \param[in] comm Message passing environment identifier
14613!> \par Index meaning
14614!> \par The first two indices specify the data while the last index counts
14615!> the processes
14616!> \par Sizes of ranks
14617!> All processes have the same data size.
14618!> \par MPI mapping
14619!> mpi_alltoall
14620! **************************************************************************************************
14621 SUBROUTINE mp_alltoall_d (sb, rb, count, comm)
14622
14623 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
14624 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
14625 INTEGER, INTENT(IN) :: count
14626 CLASS(mp_comm_type), INTENT(IN) :: comm
14627
14628 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d'
14629
14630 INTEGER :: handle
14631#if defined(__parallel)
14632 INTEGER :: ierr, msglen, np
14633#endif
14634
14635 CALL mp_timeset(routinen, handle)
14636
14637#if defined(__parallel)
14638 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14639 rb, count, mpi_double_precision, comm%handle, ierr)
14640 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14641 CALL mpi_comm_size(comm%handle, np, ierr)
14642 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14643 msglen = 2*count*np
14644 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14645#else
14646 mark_used(count)
14647 mark_used(comm)
14648 rb = sb
14649#endif
14650 CALL mp_timestop(handle)
14651
14652 END SUBROUTINE mp_alltoall_d
14653
14654! **************************************************************************************************
14655!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
14656!> \param sb ...
14657!> \param rb ...
14658!> \param count ...
14659!> \param commp ...
14660!> \note see mp_alltoall_d
14661! **************************************************************************************************
14662 SUBROUTINE mp_alltoall_d22(sb, rb, count, comm)
14663
14664 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
14665 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
14666 INTEGER, INTENT(IN) :: count
14667 CLASS(mp_comm_type), INTENT(IN) :: comm
14668
14669 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d22'
14670
14671 INTEGER :: handle
14672#if defined(__parallel)
14673 INTEGER :: ierr, msglen, np
14674#endif
14675
14676 CALL mp_timeset(routinen, handle)
14677
14678#if defined(__parallel)
14679 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14680 rb, count, mpi_double_precision, comm%handle, ierr)
14681 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14682 CALL mpi_comm_size(comm%handle, np, ierr)
14683 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14684 msglen = 2*SIZE(sb)*np
14685 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14686#else
14687 mark_used(count)
14688 mark_used(comm)
14689 rb = sb
14690#endif
14691 CALL mp_timestop(handle)
14692
14693 END SUBROUTINE mp_alltoall_d22
14694
14695! **************************************************************************************************
14696!> \brief All-to-all data exchange, rank-3 data with equal sizes
14697!> \param sb ...
14698!> \param rb ...
14699!> \param count ...
14700!> \param comm ...
14701!> \note see mp_alltoall_d
14702! **************************************************************************************************
14703 SUBROUTINE mp_alltoall_d33(sb, rb, count, comm)
14704
14705 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
14706 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
14707 INTEGER, INTENT(IN) :: count
14708 CLASS(mp_comm_type), INTENT(IN) :: comm
14709
14710 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d33'
14711
14712 INTEGER :: handle
14713#if defined(__parallel)
14714 INTEGER :: ierr, msglen, np
14715#endif
14716
14717 CALL mp_timeset(routinen, handle)
14718
14719#if defined(__parallel)
14720 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14721 rb, count, mpi_double_precision, comm%handle, ierr)
14722 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14723 CALL mpi_comm_size(comm%handle, np, ierr)
14724 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14725 msglen = 2*count*np
14726 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14727#else
14728 mark_used(count)
14729 mark_used(comm)
14730 rb = sb
14731#endif
14732 CALL mp_timestop(handle)
14733
14734 END SUBROUTINE mp_alltoall_d33
14735
14736! **************************************************************************************************
14737!> \brief All-to-all data exchange, rank 4 data, equal sizes
14738!> \param sb ...
14739!> \param rb ...
14740!> \param count ...
14741!> \param comm ...
14742!> \note see mp_alltoall_d
14743! **************************************************************************************************
14744 SUBROUTINE mp_alltoall_d44(sb, rb, count, comm)
14745
14746 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14747 INTENT(IN) :: sb
14748 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14749 INTENT(OUT) :: rb
14750 INTEGER, INTENT(IN) :: count
14751 CLASS(mp_comm_type), INTENT(IN) :: comm
14752
14753 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d44'
14754
14755 INTEGER :: handle
14756#if defined(__parallel)
14757 INTEGER :: ierr, msglen, np
14758#endif
14759
14760 CALL mp_timeset(routinen, handle)
14761
14762#if defined(__parallel)
14763 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14764 rb, count, mpi_double_precision, comm%handle, ierr)
14765 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14766 CALL mpi_comm_size(comm%handle, np, ierr)
14767 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14768 msglen = 2*count*np
14769 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14770#else
14771 mark_used(count)
14772 mark_used(comm)
14773 rb = sb
14774#endif
14775 CALL mp_timestop(handle)
14776
14777 END SUBROUTINE mp_alltoall_d44
14778
14779! **************************************************************************************************
14780!> \brief All-to-all data exchange, rank 5 data, equal sizes
14781!> \param sb ...
14782!> \param rb ...
14783!> \param count ...
14784!> \param comm ...
14785!> \note see mp_alltoall_d
14786! **************************************************************************************************
14787 SUBROUTINE mp_alltoall_d55(sb, rb, count, comm)
14788
14789 REAL(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
14790 INTENT(IN) :: sb
14791 REAL(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
14792 INTENT(OUT) :: rb
14793 INTEGER, INTENT(IN) :: count
14794 CLASS(mp_comm_type), INTENT(IN) :: comm
14795
14796 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d55'
14797
14798 INTEGER :: handle
14799#if defined(__parallel)
14800 INTEGER :: ierr, msglen, np
14801#endif
14802
14803 CALL mp_timeset(routinen, handle)
14804
14805#if defined(__parallel)
14806 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14807 rb, count, mpi_double_precision, comm%handle, ierr)
14808 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14809 CALL mpi_comm_size(comm%handle, np, ierr)
14810 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14811 msglen = 2*count*np
14812 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14813#else
14814 mark_used(count)
14815 mark_used(comm)
14816 rb = sb
14817#endif
14818 CALL mp_timestop(handle)
14819
14820 END SUBROUTINE mp_alltoall_d55
14821
14822! **************************************************************************************************
14823!> \brief All-to-all data exchange, rank-4 data to rank-5 data
14824!> \param sb ...
14825!> \param rb ...
14826!> \param count ...
14827!> \param comm ...
14828!> \note see mp_alltoall_d
14829!> \note User must ensure size consistency.
14830! **************************************************************************************************
14831 SUBROUTINE mp_alltoall_d45(sb, rb, count, comm)
14832
14833 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14834 INTENT(IN) :: sb
14835 REAL(kind=real_8), &
14836 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
14837 INTEGER, INTENT(IN) :: count
14838 CLASS(mp_comm_type), INTENT(IN) :: comm
14839
14840 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d45'
14841
14842 INTEGER :: handle
14843#if defined(__parallel)
14844 INTEGER :: ierr, msglen, np
14845#endif
14846
14847 CALL mp_timeset(routinen, handle)
14848
14849#if defined(__parallel)
14850 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14851 rb, count, mpi_double_precision, comm%handle, ierr)
14852 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14853 CALL mpi_comm_size(comm%handle, np, ierr)
14854 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14855 msglen = 2*count*np
14856 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14857#else
14858 mark_used(count)
14859 mark_used(comm)
14860 rb = reshape(sb, shape(rb))
14861#endif
14862 CALL mp_timestop(handle)
14863
14864 END SUBROUTINE mp_alltoall_d45
14865
14866! **************************************************************************************************
14867!> \brief All-to-all data exchange, rank-3 data to rank-4 data
14868!> \param sb ...
14869!> \param rb ...
14870!> \param count ...
14871!> \param comm ...
14872!> \note see mp_alltoall_d
14873!> \note User must ensure size consistency.
14874! **************************************************************************************************
14875 SUBROUTINE mp_alltoall_d34(sb, rb, count, comm)
14876
14877 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, &
14878 INTENT(IN) :: sb
14879 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14880 INTENT(OUT) :: rb
14881 INTEGER, INTENT(IN) :: count
14882 CLASS(mp_comm_type), INTENT(IN) :: comm
14883
14884 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d34'
14885
14886 INTEGER :: handle
14887#if defined(__parallel)
14888 INTEGER :: ierr, msglen, np
14889#endif
14890
14891 CALL mp_timeset(routinen, handle)
14892
14893#if defined(__parallel)
14894 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14895 rb, count, mpi_double_precision, comm%handle, ierr)
14896 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14897 CALL mpi_comm_size(comm%handle, np, ierr)
14898 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14899 msglen = 2*count*np
14900 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14901#else
14902 mark_used(count)
14903 mark_used(comm)
14904 rb = reshape(sb, shape(rb))
14905#endif
14906 CALL mp_timestop(handle)
14907
14908 END SUBROUTINE mp_alltoall_d34
14909
14910! **************************************************************************************************
14911!> \brief All-to-all data exchange, rank-5 data to rank-4 data
14912!> \param sb ...
14913!> \param rb ...
14914!> \param count ...
14915!> \param comm ...
14916!> \note see mp_alltoall_d
14917!> \note User must ensure size consistency.
14918! **************************************************************************************************
14919 SUBROUTINE mp_alltoall_d54(sb, rb, count, comm)
14920
14921 REAL(kind=real_8), &
14922 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
14923 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14924 INTENT(OUT) :: rb
14925 INTEGER, INTENT(IN) :: count
14926 CLASS(mp_comm_type), INTENT(IN) :: comm
14927
14928 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d54'
14929
14930 INTEGER :: handle
14931#if defined(__parallel)
14932 INTEGER :: ierr, msglen, np
14933#endif
14934
14935 CALL mp_timeset(routinen, handle)
14936
14937#if defined(__parallel)
14938 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14939 rb, count, mpi_double_precision, comm%handle, ierr)
14940 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14941 CALL mpi_comm_size(comm%handle, np, ierr)
14942 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14943 msglen = 2*count*np
14944 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14945#else
14946 mark_used(count)
14947 mark_used(comm)
14948 rb = reshape(sb, shape(rb))
14949#endif
14950 CALL mp_timestop(handle)
14951
14952 END SUBROUTINE mp_alltoall_d54
14953
14954! **************************************************************************************************
14955!> \brief Send one datum to another process
14956!> \param[in] msg Scalar to send
14957!> \param[in] dest Destination process
14958!> \param[in] tag Transfer identifier
14959!> \param[in] comm Message passing environment identifier
14960!> \par MPI mapping
14961!> mpi_send
14962! **************************************************************************************************
14963 SUBROUTINE mp_send_d (msg, dest, tag, comm)
14964 REAL(kind=real_8), INTENT(IN) :: msg
14965 INTEGER, INTENT(IN) :: dest, tag
14966 CLASS(mp_comm_type), INTENT(IN) :: comm
14967
14968 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_d'
14969
14970 INTEGER :: handle
14971#if defined(__parallel)
14972 INTEGER :: ierr, msglen
14973#endif
14974
14975 CALL mp_timeset(routinen, handle)
14976
14977#if defined(__parallel)
14978 msglen = 1
14979 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
14980 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
14981 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
14982#else
14983 mark_used(msg)
14984 mark_used(dest)
14985 mark_used(tag)
14986 mark_used(comm)
14987 ! only defined in parallel
14988 cpabort("not in parallel mode")
14989#endif
14990 CALL mp_timestop(handle)
14991 END SUBROUTINE mp_send_d
14992
14993! **************************************************************************************************
14994!> \brief Send rank-1 data to another process
14995!> \param[in] msg Rank-1 data to send
14996!> \param dest ...
14997!> \param tag ...
14998!> \param comm ...
14999!> \note see mp_send_d
15000! **************************************************************************************************
15001 SUBROUTINE mp_send_dv(msg, dest, tag, comm)
15002 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
15003 INTEGER, INTENT(IN) :: dest, tag
15004 CLASS(mp_comm_type), INTENT(IN) :: comm
15005
15006 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_dv'
15007
15008 INTEGER :: handle
15009#if defined(__parallel)
15010 INTEGER :: ierr, msglen
15011#endif
15012
15013 CALL mp_timeset(routinen, handle)
15014
15015#if defined(__parallel)
15016 msglen = SIZE(msg)
15017 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15018 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15019 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15020#else
15021 mark_used(msg)
15022 mark_used(dest)
15023 mark_used(tag)
15024 mark_used(comm)
15025 ! only defined in parallel
15026 cpabort("not in parallel mode")
15027#endif
15028 CALL mp_timestop(handle)
15029 END SUBROUTINE mp_send_dv
15030
15031! **************************************************************************************************
15032!> \brief Send rank-2 data to another process
15033!> \param[in] msg Rank-2 data to send
15034!> \param dest ...
15035!> \param tag ...
15036!> \param comm ...
15037!> \note see mp_send_d
15038! **************************************************************************************************
15039 SUBROUTINE mp_send_dm2(msg, dest, tag, comm)
15040 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
15041 INTEGER, INTENT(IN) :: dest, tag
15042 CLASS(mp_comm_type), INTENT(IN) :: comm
15043
15044 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_dm2'
15045
15046 INTEGER :: handle
15047#if defined(__parallel)
15048 INTEGER :: ierr, msglen
15049#endif
15050
15051 CALL mp_timeset(routinen, handle)
15052
15053#if defined(__parallel)
15054 msglen = SIZE(msg)
15055 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15056 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15057 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15058#else
15059 mark_used(msg)
15060 mark_used(dest)
15061 mark_used(tag)
15062 mark_used(comm)
15063 ! only defined in parallel
15064 cpabort("not in parallel mode")
15065#endif
15066 CALL mp_timestop(handle)
15067 END SUBROUTINE mp_send_dm2
15068
15069! **************************************************************************************************
15070!> \brief Send rank-3 data to another process
15071!> \param[in] msg Rank-3 data to send
15072!> \param dest ...
15073!> \param tag ...
15074!> \param comm ...
15075!> \note see mp_send_d
15076! **************************************************************************************************
15077 SUBROUTINE mp_send_dm3(msg, dest, tag, comm)
15078 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
15079 INTEGER, INTENT(IN) :: dest, tag
15080 CLASS(mp_comm_type), INTENT(IN) :: comm
15081
15082 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
15083
15084 INTEGER :: handle
15085#if defined(__parallel)
15086 INTEGER :: ierr, msglen
15087#endif
15088
15089 CALL mp_timeset(routinen, handle)
15090
15091#if defined(__parallel)
15092 msglen = SIZE(msg)
15093 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15094 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15095 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15096#else
15097 mark_used(msg)
15098 mark_used(dest)
15099 mark_used(tag)
15100 mark_used(comm)
15101 ! only defined in parallel
15102 cpabort("not in parallel mode")
15103#endif
15104 CALL mp_timestop(handle)
15105 END SUBROUTINE mp_send_dm3
15106
15107! **************************************************************************************************
15108!> \brief Receive one datum from another process
15109!> \param[in,out] msg Place received data into this variable
15110!> \param[in,out] source Process to receive from
15111!> \param[in,out] tag Transfer identifier
15112!> \param[in] comm Message passing environment identifier
15113!> \par MPI mapping
15114!> mpi_send
15115! **************************************************************************************************
15116 SUBROUTINE mp_recv_d (msg, source, tag, comm)
15117 REAL(kind=real_8), INTENT(INOUT) :: msg
15118 INTEGER, INTENT(INOUT) :: source, tag
15119 CLASS(mp_comm_type), INTENT(IN) :: comm
15120
15121 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_d'
15122
15123 INTEGER :: handle
15124#if defined(__parallel)
15125 INTEGER :: ierr, msglen
15126 mpi_status_type :: status
15127#endif
15128
15129 CALL mp_timeset(routinen, handle)
15130
15131#if defined(__parallel)
15132 msglen = 1
15133 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15134 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15135 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15136 ELSE
15137 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15138 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15139 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15140 source = status mpi_status_extract(mpi_source)
15141 tag = status mpi_status_extract(mpi_tag)
15142 END IF
15143#else
15144 mark_used(msg)
15145 mark_used(source)
15146 mark_used(tag)
15147 mark_used(comm)
15148 ! only defined in parallel
15149 cpabort("not in parallel mode")
15150#endif
15151 CALL mp_timestop(handle)
15152 END SUBROUTINE mp_recv_d
15153
15154! **************************************************************************************************
15155!> \brief Receive rank-1 data from another process
15156!> \param[in,out] msg Place received data into this rank-1 array
15157!> \param source ...
15158!> \param tag ...
15159!> \param comm ...
15160!> \note see mp_recv_d
15161! **************************************************************************************************
15162 SUBROUTINE mp_recv_dv(msg, source, tag, comm)
15163 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15164 INTEGER, INTENT(INOUT) :: source, tag
15165 CLASS(mp_comm_type), INTENT(IN) :: comm
15166
15167 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dv'
15168
15169 INTEGER :: handle
15170#if defined(__parallel)
15171 INTEGER :: ierr, msglen
15172 mpi_status_type :: status
15173#endif
15174
15175 CALL mp_timeset(routinen, handle)
15176
15177#if defined(__parallel)
15178 msglen = SIZE(msg)
15179 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15180 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15181 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15182 ELSE
15183 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15184 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15185 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15186 source = status mpi_status_extract(mpi_source)
15187 tag = status mpi_status_extract(mpi_tag)
15188 END IF
15189#else
15190 mark_used(msg)
15191 mark_used(source)
15192 mark_used(tag)
15193 mark_used(comm)
15194 ! only defined in parallel
15195 cpabort("not in parallel mode")
15196#endif
15197 CALL mp_timestop(handle)
15198 END SUBROUTINE mp_recv_dv
15199
15200! **************************************************************************************************
15201!> \brief Receive rank-2 data from another process
15202!> \param[in,out] msg Place received data into this rank-2 array
15203!> \param source ...
15204!> \param tag ...
15205!> \param comm ...
15206!> \note see mp_recv_d
15207! **************************************************************************************************
15208 SUBROUTINE mp_recv_dm2(msg, source, tag, comm)
15209 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15210 INTEGER, INTENT(INOUT) :: source, tag
15211 CLASS(mp_comm_type), INTENT(IN) :: comm
15212
15213 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dm2'
15214
15215 INTEGER :: handle
15216#if defined(__parallel)
15217 INTEGER :: ierr, msglen
15218 mpi_status_type :: status
15219#endif
15220
15221 CALL mp_timeset(routinen, handle)
15222
15223#if defined(__parallel)
15224 msglen = SIZE(msg)
15225 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15226 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15227 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15228 ELSE
15229 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15230 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15231 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15232 source = status mpi_status_extract(mpi_source)
15233 tag = status mpi_status_extract(mpi_tag)
15234 END IF
15235#else
15236 mark_used(msg)
15237 mark_used(source)
15238 mark_used(tag)
15239 mark_used(comm)
15240 ! only defined in parallel
15241 cpabort("not in parallel mode")
15242#endif
15243 CALL mp_timestop(handle)
15244 END SUBROUTINE mp_recv_dm2
15245
15246! **************************************************************************************************
15247!> \brief Receive rank-3 data from another process
15248!> \param[in,out] msg Place received data into this rank-3 array
15249!> \param source ...
15250!> \param tag ...
15251!> \param comm ...
15252!> \note see mp_recv_d
15253! **************************************************************************************************
15254 SUBROUTINE mp_recv_dm3(msg, source, tag, comm)
15255 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
15256 INTEGER, INTENT(INOUT) :: source, tag
15257 CLASS(mp_comm_type), INTENT(IN) :: comm
15258
15259 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dm3'
15260
15261 INTEGER :: handle
15262#if defined(__parallel)
15263 INTEGER :: ierr, msglen
15264 mpi_status_type :: status
15265#endif
15266
15267 CALL mp_timeset(routinen, handle)
15268
15269#if defined(__parallel)
15270 msglen = SIZE(msg)
15271 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15272 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15273 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15274 ELSE
15275 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15276 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15277 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15278 source = status mpi_status_extract(mpi_source)
15279 tag = status mpi_status_extract(mpi_tag)
15280 END IF
15281#else
15282 mark_used(msg)
15283 mark_used(source)
15284 mark_used(tag)
15285 mark_used(comm)
15286 ! only defined in parallel
15287 cpabort("not in parallel mode")
15288#endif
15289 CALL mp_timestop(handle)
15290 END SUBROUTINE mp_recv_dm3
15291
15292! **************************************************************************************************
15293!> \brief Broadcasts a datum to all processes.
15294!> \param[in] msg Datum to broadcast
15295!> \param[in] source Processes which broadcasts
15296!> \param[in] comm Message passing environment identifier
15297!> \par MPI mapping
15298!> mpi_bcast
15299! **************************************************************************************************
15300 SUBROUTINE mp_bcast_d (msg, source, comm)
15301 REAL(kind=real_8), INTENT(INOUT) :: msg
15302 INTEGER, INTENT(IN) :: source
15303 CLASS(mp_comm_type), INTENT(IN) :: comm
15304
15305 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d'
15306
15307 INTEGER :: handle
15308#if defined(__parallel)
15309 INTEGER :: ierr, msglen
15310#endif
15311
15312 CALL mp_timeset(routinen, handle)
15313
15314#if defined(__parallel)
15315 msglen = 1
15316 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15317 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15318 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15319#else
15320 mark_used(msg)
15321 mark_used(source)
15322 mark_used(comm)
15323#endif
15324 CALL mp_timestop(handle)
15325 END SUBROUTINE mp_bcast_d
15326
15327! **************************************************************************************************
15328!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
15329!> \param[in] msg Datum to broadcast
15330!> \param[in] comm Message passing environment identifier
15331!> \par MPI mapping
15332!> mpi_bcast
15333! **************************************************************************************************
15334 SUBROUTINE mp_bcast_d_src(msg, comm)
15335 REAL(kind=real_8), INTENT(INOUT) :: msg
15336 CLASS(mp_comm_type), INTENT(IN) :: comm
15337
15338 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d_src'
15339
15340 INTEGER :: handle
15341#if defined(__parallel)
15342 INTEGER :: ierr, msglen
15343#endif
15344
15345 CALL mp_timeset(routinen, handle)
15346
15347#if defined(__parallel)
15348 msglen = 1
15349 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15350 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15351 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15352#else
15353 mark_used(msg)
15354 mark_used(comm)
15355#endif
15356 CALL mp_timestop(handle)
15357 END SUBROUTINE mp_bcast_d_src
15358
15359! **************************************************************************************************
15360!> \brief Broadcasts a datum to all processes.
15361!> \param[in] msg Datum to broadcast
15362!> \param[in] source Processes which broadcasts
15363!> \param[in] comm Message passing environment identifier
15364!> \par MPI mapping
15365!> mpi_bcast
15366! **************************************************************************************************
15367 SUBROUTINE mp_ibcast_d (msg, source, comm, request)
15368 REAL(kind=real_8), INTENT(INOUT) :: msg
15369 INTEGER, INTENT(IN) :: source
15370 CLASS(mp_comm_type), INTENT(IN) :: comm
15371 TYPE(mp_request_type), INTENT(OUT) :: request
15372
15373 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_d'
15374
15375 INTEGER :: handle
15376#if defined(__parallel)
15377 INTEGER :: ierr, msglen
15378#endif
15379
15380 CALL mp_timeset(routinen, handle)
15381
15382#if defined(__parallel)
15383 msglen = 1
15384 CALL mpi_ibcast(msg, msglen, mpi_double_precision, source, comm%handle, request%handle, ierr)
15385 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
15386 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_8_size)
15387#else
15388 mark_used(msg)
15389 mark_used(source)
15390 mark_used(comm)
15391 request = mp_request_null
15392#endif
15393 CALL mp_timestop(handle)
15394 END SUBROUTINE mp_ibcast_d
15395
15396! **************************************************************************************************
15397!> \brief Broadcasts rank-1 data to all processes
15398!> \param[in] msg Data to broadcast
15399!> \param source ...
15400!> \param comm ...
15401!> \note see mp_bcast_d1
15402! **************************************************************************************************
15403 SUBROUTINE mp_bcast_dv(msg, source, comm)
15404 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15405 INTEGER, INTENT(IN) :: source
15406 CLASS(mp_comm_type), INTENT(IN) :: comm
15407
15408 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dv'
15409
15410 INTEGER :: handle
15411#if defined(__parallel)
15412 INTEGER :: ierr, msglen
15413#endif
15414
15415 CALL mp_timeset(routinen, handle)
15416
15417#if defined(__parallel)
15418 msglen = SIZE(msg)
15419 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15420 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15421 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15422#else
15423 mark_used(msg)
15424 mark_used(source)
15425 mark_used(comm)
15426#endif
15427 CALL mp_timestop(handle)
15428 END SUBROUTINE mp_bcast_dv
15429
15430! **************************************************************************************************
15431!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
15432!> \param[in] msg Data to broadcast
15433!> \param comm ...
15434!> \note see mp_bcast_d1
15435! **************************************************************************************************
15436 SUBROUTINE mp_bcast_dv_src(msg, comm)
15437 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15438 CLASS(mp_comm_type), INTENT(IN) :: comm
15439
15440 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dv_src'
15441
15442 INTEGER :: handle
15443#if defined(__parallel)
15444 INTEGER :: ierr, msglen
15445#endif
15446
15447 CALL mp_timeset(routinen, handle)
15448
15449#if defined(__parallel)
15450 msglen = SIZE(msg)
15451 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15452 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15453 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15454#else
15455 mark_used(msg)
15456 mark_used(comm)
15457#endif
15458 CALL mp_timestop(handle)
15459 END SUBROUTINE mp_bcast_dv_src
15460
15461! **************************************************************************************************
15462!> \brief Broadcasts rank-1 data to all processes
15463!> \param[in] msg Data to broadcast
15464!> \param source ...
15465!> \param comm ...
15466!> \note see mp_bcast_d1
15467! **************************************************************************************************
15468 SUBROUTINE mp_ibcast_dv(msg, source, comm, request)
15469 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
15470 INTEGER, INTENT(IN) :: source
15471 CLASS(mp_comm_type), INTENT(IN) :: comm
15472 TYPE(mp_request_type) :: request
15473
15474 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_dv'
15475
15476 INTEGER :: handle
15477#if defined(__parallel)
15478 INTEGER :: ierr, msglen
15479#endif
15480
15481 CALL mp_timeset(routinen, handle)
15482
15483#if defined(__parallel)
15484#if !defined(__GNUC__) || __GNUC__ >= 9
15485 cpassert(is_contiguous(msg))
15486#endif
15487 msglen = SIZE(msg)
15488 CALL mpi_ibcast(msg, msglen, mpi_double_precision, source, comm%handle, request%handle, ierr)
15489 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
15490 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_8_size)
15491#else
15492 mark_used(msg)
15493 mark_used(source)
15494 mark_used(comm)
15495 request = mp_request_null
15496#endif
15497 CALL mp_timestop(handle)
15498 END SUBROUTINE mp_ibcast_dv
15499
15500! **************************************************************************************************
15501!> \brief Broadcasts rank-2 data to all processes
15502!> \param[in] msg Data to broadcast
15503!> \param source ...
15504!> \param comm ...
15505!> \note see mp_bcast_d1
15506! **************************************************************************************************
15507 SUBROUTINE mp_bcast_dm(msg, source, comm)
15508 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15509 INTEGER, INTENT(IN) :: source
15510 CLASS(mp_comm_type), INTENT(IN) :: comm
15511
15512 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dm'
15513
15514 INTEGER :: handle
15515#if defined(__parallel)
15516 INTEGER :: ierr, msglen
15517#endif
15518
15519 CALL mp_timeset(routinen, handle)
15520
15521#if defined(__parallel)
15522 msglen = SIZE(msg)
15523 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15524 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15525 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15526#else
15527 mark_used(msg)
15528 mark_used(source)
15529 mark_used(comm)
15530#endif
15531 CALL mp_timestop(handle)
15532 END SUBROUTINE mp_bcast_dm
15533
15534! **************************************************************************************************
15535!> \brief Broadcasts rank-2 data to all processes
15536!> \param[in] msg Data to broadcast
15537!> \param source ...
15538!> \param comm ...
15539!> \note see mp_bcast_d1
15540! **************************************************************************************************
15541 SUBROUTINE mp_bcast_dm_src(msg, comm)
15542 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15543 CLASS(mp_comm_type), INTENT(IN) :: comm
15544
15545 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dm_src'
15546
15547 INTEGER :: handle
15548#if defined(__parallel)
15549 INTEGER :: ierr, msglen
15550#endif
15551
15552 CALL mp_timeset(routinen, handle)
15553
15554#if defined(__parallel)
15555 msglen = SIZE(msg)
15556 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15557 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15558 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15559#else
15560 mark_used(msg)
15561 mark_used(comm)
15562#endif
15563 CALL mp_timestop(handle)
15564 END SUBROUTINE mp_bcast_dm_src
15565
15566! **************************************************************************************************
15567!> \brief Broadcasts rank-3 data to all processes
15568!> \param[in] msg Data to broadcast
15569!> \param source ...
15570!> \param comm ...
15571!> \note see mp_bcast_d1
15572! **************************************************************************************************
15573 SUBROUTINE mp_bcast_d3(msg, source, comm)
15574 REAL(kind=real_8), CONTIGUOUS :: msg(:, :, :)
15575 INTEGER, INTENT(IN) :: source
15576 CLASS(mp_comm_type), INTENT(IN) :: comm
15577
15578 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d3'
15579
15580 INTEGER :: handle
15581#if defined(__parallel)
15582 INTEGER :: ierr, msglen
15583#endif
15584
15585 CALL mp_timeset(routinen, handle)
15586
15587#if defined(__parallel)
15588 msglen = SIZE(msg)
15589 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15590 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15591 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15592#else
15593 mark_used(msg)
15594 mark_used(source)
15595 mark_used(comm)
15596#endif
15597 CALL mp_timestop(handle)
15598 END SUBROUTINE mp_bcast_d3
15599
15600! **************************************************************************************************
15601!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
15602!> \param[in] msg Data to broadcast
15603!> \param source ...
15604!> \param comm ...
15605!> \note see mp_bcast_d1
15606! **************************************************************************************************
15607 SUBROUTINE mp_bcast_d3_src(msg, comm)
15608 REAL(kind=real_8), CONTIGUOUS :: msg(:, :, :)
15609 CLASS(mp_comm_type), INTENT(IN) :: comm
15610
15611 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d3_src'
15612
15613 INTEGER :: handle
15614#if defined(__parallel)
15615 INTEGER :: ierr, msglen
15616#endif
15617
15618 CALL mp_timeset(routinen, handle)
15619
15620#if defined(__parallel)
15621 msglen = SIZE(msg)
15622 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15623 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15624 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15625#else
15626 mark_used(msg)
15627 mark_used(comm)
15628#endif
15629 CALL mp_timestop(handle)
15630 END SUBROUTINE mp_bcast_d3_src
15631
15632! **************************************************************************************************
15633!> \brief Sums a datum from all processes with result left on all processes.
15634!> \param[in,out] msg Datum to sum (input) and result (output)
15635!> \param[in] comm Message passing environment identifier
15636!> \par MPI mapping
15637!> mpi_allreduce
15638! **************************************************************************************************
15639 SUBROUTINE mp_sum_d (msg, comm)
15640 REAL(kind=real_8), INTENT(INOUT) :: msg
15641 CLASS(mp_comm_type), INTENT(IN) :: comm
15642
15643 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_d'
15644
15645 INTEGER :: handle
15646#if defined(__parallel)
15647 INTEGER :: ierr, msglen
15648#endif
15649
15650 CALL mp_timeset(routinen, handle)
15651
15652#if defined(__parallel)
15653 msglen = 1
15654 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15655 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15656 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15657#else
15658 mark_used(msg)
15659 mark_used(comm)
15660#endif
15661 CALL mp_timestop(handle)
15662 END SUBROUTINE mp_sum_d
15663
15664! **************************************************************************************************
15665!> \brief Element-wise sum of a rank-1 array on all processes.
15666!> \param[in,out] msg Vector to sum and result
15667!> \param comm ...
15668!> \note see mp_sum_d
15669! **************************************************************************************************
15670 SUBROUTINE mp_sum_dv(msg, comm)
15671 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15672 CLASS(mp_comm_type), INTENT(IN) :: comm
15673
15674 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dv'
15675
15676 INTEGER :: handle
15677#if defined(__parallel)
15678 INTEGER :: ierr, msglen
15679#endif
15680
15681 CALL mp_timeset(routinen, handle)
15682
15683#if defined(__parallel)
15684 msglen = SIZE(msg)
15685 IF (msglen > 0) THEN
15686 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15687 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15688 END IF
15689 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15690#else
15691 mark_used(msg)
15692 mark_used(comm)
15693#endif
15694 CALL mp_timestop(handle)
15695 END SUBROUTINE mp_sum_dv
15696
15697! **************************************************************************************************
15698!> \brief Element-wise sum of a rank-1 array on all processes.
15699!> \param[in,out] msg Vector to sum and result
15700!> \param comm ...
15701!> \note see mp_sum_d
15702! **************************************************************************************************
15703 SUBROUTINE mp_isum_dv(msg, comm, request)
15704 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
15705 CLASS(mp_comm_type), INTENT(IN) :: comm
15706 TYPE(mp_request_type), INTENT(OUT) :: request
15707
15708 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_dv'
15709
15710 INTEGER :: handle
15711#if defined(__parallel)
15712 INTEGER :: ierr, msglen
15713#endif
15714
15715 CALL mp_timeset(routinen, handle)
15716
15717#if defined(__parallel)
15718#if !defined(__GNUC__) || __GNUC__ >= 9
15719 cpassert(is_contiguous(msg))
15720#endif
15721 msglen = SIZE(msg)
15722 IF (msglen > 0) THEN
15723 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, request%handle, ierr)
15724 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
15725 ELSE
15726 request = mp_request_null
15727 END IF
15728 CALL add_perf(perf_id=23, count=1, msg_size=msglen*real_8_size)
15729#else
15730 mark_used(msg)
15731 mark_used(comm)
15732 request = mp_request_null
15733#endif
15734 CALL mp_timestop(handle)
15735 END SUBROUTINE mp_isum_dv
15736
15737! **************************************************************************************************
15738!> \brief Element-wise sum of a rank-2 array on all processes.
15739!> \param[in] msg Matrix to sum and result
15740!> \param comm ...
15741!> \note see mp_sum_d
15742! **************************************************************************************************
15743 SUBROUTINE mp_sum_dm(msg, comm)
15744 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15745 CLASS(mp_comm_type), INTENT(IN) :: comm
15746
15747 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm'
15748
15749 INTEGER :: handle
15750#if defined(__parallel)
15751 INTEGER, PARAMETER :: max_msg = 2**25
15752 INTEGER :: ierr, m1, msglen, step, msglensum
15753#endif
15754
15755 CALL mp_timeset(routinen, handle)
15756
15757#if defined(__parallel)
15758 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
15759 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
15760 msglensum = 0
15761 DO m1 = lbound(msg, 2), ubound(msg, 2), step
15762 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
15763 msglensum = msglensum + msglen
15764 IF (msglen > 0) THEN
15765 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15766 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15767 END IF
15768 END DO
15769 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_8_size)
15770#else
15771 mark_used(msg)
15772 mark_used(comm)
15773#endif
15774 CALL mp_timestop(handle)
15775 END SUBROUTINE mp_sum_dm
15776
15777! **************************************************************************************************
15778!> \brief Element-wise sum of a rank-3 array on all processes.
15779!> \param[in] msg Array to sum and result
15780!> \param comm ...
15781!> \note see mp_sum_d
15782! **************************************************************************************************
15783 SUBROUTINE mp_sum_dm3(msg, comm)
15784 REAL(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
15785 CLASS(mp_comm_type), INTENT(IN) :: comm
15786
15787 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm3'
15788
15789 INTEGER :: handle
15790#if defined(__parallel)
15791 INTEGER :: ierr, msglen
15792#endif
15793
15794 CALL mp_timeset(routinen, handle)
15795
15796#if defined(__parallel)
15797 msglen = SIZE(msg)
15798 IF (msglen > 0) THEN
15799 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15800 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15801 END IF
15802 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15803#else
15804 mark_used(msg)
15805 mark_used(comm)
15806#endif
15807 CALL mp_timestop(handle)
15808 END SUBROUTINE mp_sum_dm3
15809
15810! **************************************************************************************************
15811!> \brief Element-wise sum of a rank-4 array on all processes.
15812!> \param[in] msg Array to sum and result
15813!> \param comm ...
15814!> \note see mp_sum_d
15815! **************************************************************************************************
15816 SUBROUTINE mp_sum_dm4(msg, comm)
15817 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
15818 CLASS(mp_comm_type), INTENT(IN) :: comm
15819
15820 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm4'
15821
15822 INTEGER :: handle
15823#if defined(__parallel)
15824 INTEGER :: ierr, msglen
15825#endif
15826
15827 CALL mp_timeset(routinen, handle)
15828
15829#if defined(__parallel)
15830 msglen = SIZE(msg)
15831 IF (msglen > 0) THEN
15832 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15833 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15834 END IF
15835 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15836#else
15837 mark_used(msg)
15838 mark_used(comm)
15839#endif
15840 CALL mp_timestop(handle)
15841 END SUBROUTINE mp_sum_dm4
15842
15843! **************************************************************************************************
15844!> \brief Element-wise sum of data from all processes with result left only on
15845!> one.
15846!> \param[in,out] msg Vector to sum (input) and (only on process root)
15847!> result (output)
15848!> \param root ...
15849!> \param[in] comm Message passing environment identifier
15850!> \par MPI mapping
15851!> mpi_reduce
15852! **************************************************************************************************
15853 SUBROUTINE mp_sum_root_dv(msg, root, comm)
15854 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15855 INTEGER, INTENT(IN) :: root
15856 CLASS(mp_comm_type), INTENT(IN) :: comm
15857
15858 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_dv'
15859
15860 INTEGER :: handle
15861#if defined(__parallel)
15862 INTEGER :: ierr, m1, msglen, taskid
15863 REAL(kind=real_8), ALLOCATABLE :: res(:)
15864#endif
15865
15866 CALL mp_timeset(routinen, handle)
15867
15868#if defined(__parallel)
15869 msglen = SIZE(msg)
15870 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15871 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
15872 IF (msglen > 0) THEN
15873 m1 = SIZE(msg, 1)
15874 ALLOCATE (res(m1))
15875 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_sum, &
15876 root, comm%handle, ierr)
15877 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
15878 IF (taskid == root) THEN
15879 msg = res
15880 END IF
15881 DEALLOCATE (res)
15882 END IF
15883 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15884#else
15885 mark_used(msg)
15886 mark_used(root)
15887 mark_used(comm)
15888#endif
15889 CALL mp_timestop(handle)
15890 END SUBROUTINE mp_sum_root_dv
15891
15892! **************************************************************************************************
15893!> \brief Element-wise sum of data from all processes with result left only on
15894!> one.
15895!> \param[in,out] msg Matrix to sum (input) and (only on process root)
15896!> result (output)
15897!> \param root ...
15898!> \param comm ...
15899!> \note see mp_sum_root_dv
15900! **************************************************************************************************
15901 SUBROUTINE mp_sum_root_dm(msg, root, comm)
15902 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15903 INTEGER, INTENT(IN) :: root
15904 CLASS(mp_comm_type), INTENT(IN) :: comm
15905
15906 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
15907
15908 INTEGER :: handle
15909#if defined(__parallel)
15910 INTEGER :: ierr, m1, m2, msglen, taskid
15911 REAL(kind=real_8), ALLOCATABLE :: res(:, :)
15912#endif
15913
15914 CALL mp_timeset(routinen, handle)
15915
15916#if defined(__parallel)
15917 msglen = SIZE(msg)
15918 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15919 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
15920 IF (msglen > 0) THEN
15921 m1 = SIZE(msg, 1)
15922 m2 = SIZE(msg, 2)
15923 ALLOCATE (res(m1, m2))
15924 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_sum, root, comm%handle, ierr)
15925 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
15926 IF (taskid == root) THEN
15927 msg = res
15928 END IF
15929 DEALLOCATE (res)
15930 END IF
15931 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15932#else
15933 mark_used(root)
15934 mark_used(msg)
15935 mark_used(comm)
15936#endif
15937 CALL mp_timestop(handle)
15938 END SUBROUTINE mp_sum_root_dm
15939
15940! **************************************************************************************************
15941!> \brief Partial sum of data from all processes with result on each process.
15942!> \param[in] msg Matrix to sum (input)
15943!> \param[out] res Matrix containing result (output)
15944!> \param[in] comm Message passing environment identifier
15945! **************************************************************************************************
15946 SUBROUTINE mp_sum_partial_dm(msg, res, comm)
15947 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
15948 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
15949 CLASS(mp_comm_type), INTENT(IN) :: comm
15950
15951 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_dm'
15952
15953 INTEGER :: handle
15954#if defined(__parallel)
15955 INTEGER :: ierr, msglen, taskid
15956#endif
15957
15958 CALL mp_timeset(routinen, handle)
15959
15960#if defined(__parallel)
15961 msglen = SIZE(msg)
15962 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15963 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
15964 IF (msglen > 0) THEN
15965 CALL mpi_scan(msg, res, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15966 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
15967 END IF
15968 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15969 ! perf_id is same as for other summation routines
15970#else
15971 res = msg
15972 mark_used(comm)
15973#endif
15974 CALL mp_timestop(handle)
15975 END SUBROUTINE mp_sum_partial_dm
15976
15977! **************************************************************************************************
15978!> \brief Finds the maximum of a datum with the result left on all processes.
15979!> \param[in,out] msg Find maximum among these data (input) and
15980!> maximum (output)
15981!> \param[in] comm Message passing environment identifier
15982!> \par MPI mapping
15983!> mpi_allreduce
15984! **************************************************************************************************
15985 SUBROUTINE mp_max_d (msg, comm)
15986 REAL(kind=real_8), INTENT(INOUT) :: msg
15987 CLASS(mp_comm_type), INTENT(IN) :: comm
15988
15989 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_d'
15990
15991 INTEGER :: handle
15992#if defined(__parallel)
15993 INTEGER :: ierr, msglen
15994#endif
15995
15996 CALL mp_timeset(routinen, handle)
15997
15998#if defined(__parallel)
15999 msglen = 1
16000 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
16001 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16002 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16003#else
16004 mark_used(msg)
16005 mark_used(comm)
16006#endif
16007 CALL mp_timestop(handle)
16008 END SUBROUTINE mp_max_d
16009
16010! **************************************************************************************************
16011!> \brief Finds the maximum of a datum with the result left on all processes.
16012!> \param[in,out] msg Find maximum among these data (input) and
16013!> maximum (output)
16014!> \param[in] comm Message passing environment identifier
16015!> \par MPI mapping
16016!> mpi_allreduce
16017! **************************************************************************************************
16018 SUBROUTINE mp_max_root_d (msg, root, comm)
16019 REAL(kind=real_8), INTENT(INOUT) :: msg
16020 INTEGER, INTENT(IN) :: root
16021 CLASS(mp_comm_type), INTENT(IN) :: comm
16022
16023 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_d'
16024
16025 INTEGER :: handle
16026#if defined(__parallel)
16027 INTEGER :: ierr, msglen
16028 REAL(kind=real_8) :: res
16029#endif
16030
16031 CALL mp_timeset(routinen, handle)
16032
16033#if defined(__parallel)
16034 msglen = 1
16035 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_max, root, comm%handle, ierr)
16036 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
16037 IF (root == comm%mepos) msg = res
16038 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16039#else
16040 mark_used(msg)
16041 mark_used(comm)
16042 mark_used(root)
16043#endif
16044 CALL mp_timestop(handle)
16045 END SUBROUTINE mp_max_root_d
16046
16047! **************************************************************************************************
16048!> \brief Finds the element-wise maximum of a vector with the result left on
16049!> all processes.
16050!> \param[in,out] msg Find maximum among these data (input) and
16051!> maximum (output)
16052!> \param comm ...
16053!> \note see mp_max_d
16054! **************************************************************************************************
16055 SUBROUTINE mp_max_dv(msg, comm)
16056 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
16057 CLASS(mp_comm_type), INTENT(IN) :: comm
16058
16059 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_dv'
16060
16061 INTEGER :: handle
16062#if defined(__parallel)
16063 INTEGER :: ierr, msglen
16064#endif
16065
16066 CALL mp_timeset(routinen, handle)
16067
16068#if defined(__parallel)
16069 msglen = SIZE(msg)
16070 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
16071 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16072 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16073#else
16074 mark_used(msg)
16075 mark_used(comm)
16076#endif
16077 CALL mp_timestop(handle)
16078 END SUBROUTINE mp_max_dv
16079
16080! **************************************************************************************************
16081!> \brief Finds the element-wise maximum of a vector with the result left on
16082!> all processes.
16083!> \param[in,out] msg Find maximum among these data (input) and
16084!> maximum (output)
16085!> \param comm ...
16086!> \note see mp_max_d
16087! **************************************************************************************************
16088 SUBROUTINE mp_max_root_dm(msg, root, comm)
16089 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
16090 INTEGER :: root
16091 CLASS(mp_comm_type), INTENT(IN) :: comm
16092
16093 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_dm'
16094
16095 INTEGER :: handle
16096#if defined(__parallel)
16097 INTEGER :: ierr, msglen
16098 REAL(kind=real_8) :: res(SIZE(msg, 1), SIZE(msg, 2))
16099#endif
16100
16101 CALL mp_timeset(routinen, handle)
16102
16103#if defined(__parallel)
16104 msglen = SIZE(msg)
16105 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_max, root, comm%handle, ierr)
16106 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16107 IF (root == comm%mepos) msg = res
16108 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16109#else
16110 mark_used(msg)
16111 mark_used(comm)
16112 mark_used(root)
16113#endif
16114 CALL mp_timestop(handle)
16115 END SUBROUTINE mp_max_root_dm
16116
16117! **************************************************************************************************
16118!> \brief Finds the minimum of a datum with the result left on all processes.
16119!> \param[in,out] msg Find minimum among these data (input) and
16120!> maximum (output)
16121!> \param[in] comm Message passing environment identifier
16122!> \par MPI mapping
16123!> mpi_allreduce
16124! **************************************************************************************************
16125 SUBROUTINE mp_min_d (msg, comm)
16126 REAL(kind=real_8), INTENT(INOUT) :: msg
16127 CLASS(mp_comm_type), INTENT(IN) :: comm
16128
16129 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_d'
16130
16131 INTEGER :: handle
16132#if defined(__parallel)
16133 INTEGER :: ierr, msglen
16134#endif
16135
16136 CALL mp_timeset(routinen, handle)
16137
16138#if defined(__parallel)
16139 msglen = 1
16140 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
16141 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16142 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16143#else
16144 mark_used(msg)
16145 mark_used(comm)
16146#endif
16147 CALL mp_timestop(handle)
16148 END SUBROUTINE mp_min_d
16149
16150! **************************************************************************************************
16151!> \brief Finds the element-wise minimum of vector with the result left on
16152!> all processes.
16153!> \param[in,out] msg Find minimum among these data (input) and
16154!> maximum (output)
16155!> \param comm ...
16156!> \par MPI mapping
16157!> mpi_allreduce
16158!> \note see mp_min_d
16159! **************************************************************************************************
16160 SUBROUTINE mp_min_dv(msg, comm)
16161 REAL(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
16162 CLASS(mp_comm_type), INTENT(IN) :: comm
16163
16164 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_dv'
16165
16166 INTEGER :: handle
16167#if defined(__parallel)
16168 INTEGER :: ierr, msglen
16169#endif
16170
16171 CALL mp_timeset(routinen, handle)
16172
16173#if defined(__parallel)
16174 msglen = SIZE(msg)
16175 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
16176 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16177 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16178#else
16179 mark_used(msg)
16180 mark_used(comm)
16181#endif
16182 CALL mp_timestop(handle)
16183 END SUBROUTINE mp_min_dv
16184
16185! **************************************************************************************************
16186!> \brief Multiplies a set of numbers scattered across a number of processes,
16187!> then replicates the result.
16188!> \param[in,out] msg a number to multiply (input) and result (output)
16189!> \param[in] comm message passing environment identifier
16190!> \par MPI mapping
16191!> mpi_allreduce
16192! **************************************************************************************************
16193 SUBROUTINE mp_prod_d (msg, comm)
16194 REAL(kind=real_8), INTENT(INOUT) :: msg
16195 CLASS(mp_comm_type), INTENT(IN) :: comm
16196
16197 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_d'
16198
16199 INTEGER :: handle
16200#if defined(__parallel)
16201 INTEGER :: ierr, msglen
16202#endif
16203
16204 CALL mp_timeset(routinen, handle)
16205
16206#if defined(__parallel)
16207 msglen = 1
16208 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_prod, comm%handle, ierr)
16209 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16210 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16211#else
16212 mark_used(msg)
16213 mark_used(comm)
16214#endif
16215 CALL mp_timestop(handle)
16216 END SUBROUTINE mp_prod_d
16217
16218! **************************************************************************************************
16219!> \brief Scatters data from one processes to all others
16220!> \param[in] msg_scatter Data to scatter (for root process)
16221!> \param[out] msg Received data
16222!> \param[in] root Process which scatters data
16223!> \param[in] comm Message passing environment identifier
16224!> \par MPI mapping
16225!> mpi_scatter
16226! **************************************************************************************************
16227 SUBROUTINE mp_scatter_dv(msg_scatter, msg, root, comm)
16228 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
16229 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
16230 INTEGER, INTENT(IN) :: root
16231 CLASS(mp_comm_type), INTENT(IN) :: comm
16232
16233 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_dv'
16234
16235 INTEGER :: handle
16236#if defined(__parallel)
16237 INTEGER :: ierr, msglen
16238#endif
16239
16240 CALL mp_timeset(routinen, handle)
16241
16242#if defined(__parallel)
16243 msglen = SIZE(msg)
16244 CALL mpi_scatter(msg_scatter, msglen, mpi_double_precision, msg, &
16245 msglen, mpi_double_precision, root, comm%handle, ierr)
16246 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
16247 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16248#else
16249 mark_used(root)
16250 mark_used(comm)
16251 msg = msg_scatter
16252#endif
16253 CALL mp_timestop(handle)
16254 END SUBROUTINE mp_scatter_dv
16255
16256! **************************************************************************************************
16257!> \brief Scatters data from one processes to all others
16258!> \param[in] msg_scatter Data to scatter (for root process)
16259!> \param[in] root Process which scatters data
16260!> \param[in] comm Message passing environment identifier
16261!> \par MPI mapping
16262!> mpi_scatter
16263! **************************************************************************************************
16264 SUBROUTINE mp_iscatter_d (msg_scatter, msg, root, comm, request)
16265 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:)
16266 REAL(kind=real_8), INTENT(INOUT) :: msg
16267 INTEGER, INTENT(IN) :: root
16268 CLASS(mp_comm_type), INTENT(IN) :: comm
16269 TYPE(mp_request_type), INTENT(OUT) :: request
16270
16271 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_d'
16272
16273 INTEGER :: handle
16274#if defined(__parallel)
16275 INTEGER :: ierr, msglen
16276#endif
16277
16278 CALL mp_timeset(routinen, handle)
16279
16280#if defined(__parallel)
16281#if !defined(__GNUC__) || __GNUC__ >= 9
16282 cpassert(is_contiguous(msg_scatter))
16283#endif
16284 msglen = 1
16285 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_precision, msg, &
16286 msglen, mpi_double_precision, root, comm%handle, request%handle, ierr)
16287 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
16288 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16289#else
16290 mark_used(root)
16291 mark_used(comm)
16292 msg = msg_scatter(1)
16293 request = mp_request_null
16294#endif
16295 CALL mp_timestop(handle)
16296 END SUBROUTINE mp_iscatter_d
16297
16298! **************************************************************************************************
16299!> \brief Scatters data from one processes to all others
16300!> \param[in] msg_scatter Data to scatter (for root process)
16301!> \param[in] root Process which scatters data
16302!> \param[in] comm Message passing environment identifier
16303!> \par MPI mapping
16304!> mpi_scatter
16305! **************************************************************************************************
16306 SUBROUTINE mp_iscatter_dv2(msg_scatter, msg, root, comm, request)
16307 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:, :)
16308 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
16309 INTEGER, INTENT(IN) :: root
16310 CLASS(mp_comm_type), INTENT(IN) :: comm
16311 TYPE(mp_request_type), INTENT(OUT) :: request
16312
16313 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_dv2'
16314
16315 INTEGER :: handle
16316#if defined(__parallel)
16317 INTEGER :: ierr, msglen
16318#endif
16319
16320 CALL mp_timeset(routinen, handle)
16321
16322#if defined(__parallel)
16323#if !defined(__GNUC__) || __GNUC__ >= 9
16324 cpassert(is_contiguous(msg_scatter))
16325#endif
16326 msglen = SIZE(msg)
16327 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_precision, msg, &
16328 msglen, mpi_double_precision, root, comm%handle, request%handle, ierr)
16329 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
16330 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16331#else
16332 mark_used(root)
16333 mark_used(comm)
16334 msg(:) = msg_scatter(:, 1)
16335 request = mp_request_null
16336#endif
16337 CALL mp_timestop(handle)
16338 END SUBROUTINE mp_iscatter_dv2
16339
16340! **************************************************************************************************
16341!> \brief Scatters data from one processes to all others
16342!> \param[in] msg_scatter Data to scatter (for root process)
16343!> \param[in] root Process which scatters data
16344!> \param[in] comm Message passing environment identifier
16345!> \par MPI mapping
16346!> mpi_scatter
16347! **************************************************************************************************
16348 SUBROUTINE mp_iscatterv_dv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
16349 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:)
16350 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
16351 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
16352 INTEGER, INTENT(IN) :: recvcount, root
16353 CLASS(mp_comm_type), INTENT(IN) :: comm
16354 TYPE(mp_request_type), INTENT(OUT) :: request
16355
16356 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_dv'
16357
16358 INTEGER :: handle
16359#if defined(__parallel)
16360 INTEGER :: ierr
16361#endif
16362
16363 CALL mp_timeset(routinen, handle)
16364
16365#if defined(__parallel)
16366#if !defined(__GNUC__) || __GNUC__ >= 9
16367 cpassert(is_contiguous(msg_scatter))
16368 cpassert(is_contiguous(msg))
16369 cpassert(is_contiguous(sendcounts))
16370 cpassert(is_contiguous(displs))
16371#endif
16372 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_double_precision, msg, &
16373 recvcount, mpi_double_precision, root, comm%handle, request%handle, ierr)
16374 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
16375 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16376#else
16377 mark_used(sendcounts)
16378 mark_used(displs)
16379 mark_used(recvcount)
16380 mark_used(root)
16381 mark_used(comm)
16382 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
16383 request = mp_request_null
16384#endif
16385 CALL mp_timestop(handle)
16386 END SUBROUTINE mp_iscatterv_dv
16387
16388! **************************************************************************************************
16389!> \brief Gathers a datum from all processes to one
16390!> \param[in] msg Datum to send to root
16391!> \param[out] msg_gather Received data (on root)
16392!> \param[in] root Process which gathers the data
16393!> \param[in] comm Message passing environment identifier
16394!> \par MPI mapping
16395!> mpi_gather
16396! **************************************************************************************************
16397 SUBROUTINE mp_gather_d (msg, msg_gather, root, comm)
16398 REAL(kind=real_8), INTENT(IN) :: msg
16399 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16400 INTEGER, INTENT(IN) :: root
16401 CLASS(mp_comm_type), INTENT(IN) :: comm
16402
16403 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_d'
16404
16405 INTEGER :: handle
16406#if defined(__parallel)
16407 INTEGER :: ierr, msglen
16408#endif
16409
16410 CALL mp_timeset(routinen, handle)
16411
16412#if defined(__parallel)
16413 msglen = 1
16414 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16415 msglen, mpi_double_precision, root, comm%handle, ierr)
16416 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16417 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16418#else
16419 mark_used(root)
16420 mark_used(comm)
16421 msg_gather(1) = msg
16422#endif
16423 CALL mp_timestop(handle)
16424 END SUBROUTINE mp_gather_d
16425
16426! **************************************************************************************************
16427!> \brief Gathers a datum from all processes to one, uses the source process of comm
16428!> \param[in] msg Datum to send to root
16429!> \param[out] msg_gather Received data (on root)
16430!> \param[in] comm Message passing environment identifier
16431!> \par MPI mapping
16432!> mpi_gather
16433! **************************************************************************************************
16434 SUBROUTINE mp_gather_d_src(msg, msg_gather, comm)
16435 REAL(kind=real_8), INTENT(IN) :: msg
16436 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16437 CLASS(mp_comm_type), INTENT(IN) :: comm
16438
16439 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_d_src'
16440
16441 INTEGER :: handle
16442#if defined(__parallel)
16443 INTEGER :: ierr, msglen
16444#endif
16445
16446 CALL mp_timeset(routinen, handle)
16447
16448#if defined(__parallel)
16449 msglen = 1
16450 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16451 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16452 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16453 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16454#else
16455 mark_used(comm)
16456 msg_gather(1) = msg
16457#endif
16458 CALL mp_timestop(handle)
16459 END SUBROUTINE mp_gather_d_src
16460
16461! **************************************************************************************************
16462!> \brief Gathers data from all processes to one
16463!> \param[in] msg Datum to send to root
16464!> \param msg_gather ...
16465!> \param root ...
16466!> \param comm ...
16467!> \par Data length
16468!> All data (msg) is equal-sized
16469!> \par MPI mapping
16470!> mpi_gather
16471!> \note see mp_gather_d
16472! **************************************************************************************************
16473 SUBROUTINE mp_gather_dv(msg, msg_gather, root, comm)
16474 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
16475 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16476 INTEGER, INTENT(IN) :: root
16477 CLASS(mp_comm_type), INTENT(IN) :: comm
16478
16479 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dv'
16480
16481 INTEGER :: handle
16482#if defined(__parallel)
16483 INTEGER :: ierr, msglen
16484#endif
16485
16486 CALL mp_timeset(routinen, handle)
16487
16488#if defined(__parallel)
16489 msglen = SIZE(msg)
16490 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16491 msglen, mpi_double_precision, root, comm%handle, ierr)
16492 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16493 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16494#else
16495 mark_used(root)
16496 mark_used(comm)
16497 msg_gather = msg
16498#endif
16499 CALL mp_timestop(handle)
16500 END SUBROUTINE mp_gather_dv
16501
16502! **************************************************************************************************
16503!> \brief Gathers data from all processes to one. Gathers from comm%source
16504!> \param[in] msg Datum to send to root
16505!> \param msg_gather ...
16506!> \param comm ...
16507!> \par Data length
16508!> All data (msg) is equal-sized
16509!> \par MPI mapping
16510!> mpi_gather
16511!> \note see mp_gather_d
16512! **************************************************************************************************
16513 SUBROUTINE mp_gather_dv_src(msg, msg_gather, comm)
16514 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
16515 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16516 CLASS(mp_comm_type), INTENT(IN) :: comm
16517
16518 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dv_src'
16519
16520 INTEGER :: handle
16521#if defined(__parallel)
16522 INTEGER :: ierr, msglen
16523#endif
16524
16525 CALL mp_timeset(routinen, handle)
16526
16527#if defined(__parallel)
16528 msglen = SIZE(msg)
16529 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16530 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16531 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16532 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16533#else
16534 mark_used(comm)
16535 msg_gather = msg
16536#endif
16537 CALL mp_timestop(handle)
16538 END SUBROUTINE mp_gather_dv_src
16539
16540! **************************************************************************************************
16541!> \brief Gathers data from all processes to one
16542!> \param[in] msg Datum to send to root
16543!> \param msg_gather ...
16544!> \param root ...
16545!> \param comm ...
16546!> \par Data length
16547!> All data (msg) is equal-sized
16548!> \par MPI mapping
16549!> mpi_gather
16550!> \note see mp_gather_d
16551! **************************************************************************************************
16552 SUBROUTINE mp_gather_dm(msg, msg_gather, root, comm)
16553 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16554 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
16555 INTEGER, INTENT(IN) :: root
16556 CLASS(mp_comm_type), INTENT(IN) :: comm
16557
16558 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dm'
16559
16560 INTEGER :: handle
16561#if defined(__parallel)
16562 INTEGER :: ierr, msglen
16563#endif
16564
16565 CALL mp_timeset(routinen, handle)
16566
16567#if defined(__parallel)
16568 msglen = SIZE(msg)
16569 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16570 msglen, mpi_double_precision, root, comm%handle, ierr)
16571 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16572 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16573#else
16574 mark_used(root)
16575 mark_used(comm)
16576 msg_gather = msg
16577#endif
16578 CALL mp_timestop(handle)
16579 END SUBROUTINE mp_gather_dm
16580
16581! **************************************************************************************************
16582!> \brief Gathers data from all processes to one. Gathers from comm%source
16583!> \param[in] msg Datum to send to root
16584!> \param msg_gather ...
16585!> \param comm ...
16586!> \par Data length
16587!> All data (msg) is equal-sized
16588!> \par MPI mapping
16589!> mpi_gather
16590!> \note see mp_gather_d
16591! **************************************************************************************************
16592 SUBROUTINE mp_gather_dm_src(msg, msg_gather, comm)
16593 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16594 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
16595 CLASS(mp_comm_type), INTENT(IN) :: comm
16596
16597 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dm_src'
16598
16599 INTEGER :: handle
16600#if defined(__parallel)
16601 INTEGER :: ierr, msglen
16602#endif
16603
16604 CALL mp_timeset(routinen, handle)
16605
16606#if defined(__parallel)
16607 msglen = SIZE(msg)
16608 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16609 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16610 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16611 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16612#else
16613 mark_used(comm)
16614 msg_gather = msg
16615#endif
16616 CALL mp_timestop(handle)
16617 END SUBROUTINE mp_gather_dm_src
16618
16619! **************************************************************************************************
16620!> \brief Gathers data from all processes to one.
16621!> \param[in] sendbuf Data to send to root
16622!> \param[out] recvbuf Received data (on root)
16623!> \param[in] recvcounts Sizes of data received from processes
16624!> \param[in] displs Offsets of data received from processes
16625!> \param[in] root Process which gathers the data
16626!> \param[in] comm Message passing environment identifier
16627!> \par Data length
16628!> Data can have different lengths
16629!> \par Offsets
16630!> Offsets start at 0
16631!> \par MPI mapping
16632!> mpi_gather
16633! **************************************************************************************************
16634 SUBROUTINE mp_gatherv_dv(sendbuf, recvbuf, recvcounts, displs, root, comm)
16635
16636 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
16637 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
16638 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16639 INTEGER, INTENT(IN) :: root
16640 CLASS(mp_comm_type), INTENT(IN) :: comm
16641
16642 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dv'
16643
16644 INTEGER :: handle
16645#if defined(__parallel)
16646 INTEGER :: ierr, sendcount
16647#endif
16648
16649 CALL mp_timeset(routinen, handle)
16650
16651#if defined(__parallel)
16652 sendcount = SIZE(sendbuf)
16653 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16654 recvbuf, recvcounts, displs, mpi_double_precision, &
16655 root, comm%handle, ierr)
16656 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16657 CALL add_perf(perf_id=4, &
16658 count=1, &
16659 msg_size=sendcount*real_8_size)
16660#else
16661 mark_used(recvcounts)
16662 mark_used(root)
16663 mark_used(comm)
16664 recvbuf(1 + displs(1):) = sendbuf
16665#endif
16666 CALL mp_timestop(handle)
16667 END SUBROUTINE mp_gatherv_dv
16668
16669! **************************************************************************************************
16670!> \brief Gathers data from all processes to one. Gathers from comm%source
16671!> \param[in] sendbuf Data to send to root
16672!> \param[out] recvbuf Received data (on root)
16673!> \param[in] recvcounts Sizes of data received from processes
16674!> \param[in] displs Offsets of data received from processes
16675!> \param[in] comm Message passing environment identifier
16676!> \par Data length
16677!> Data can have different lengths
16678!> \par Offsets
16679!> Offsets start at 0
16680!> \par MPI mapping
16681!> mpi_gather
16682! **************************************************************************************************
16683 SUBROUTINE mp_gatherv_dv_src(sendbuf, recvbuf, recvcounts, displs, comm)
16684
16685 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
16686 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
16687 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16688 CLASS(mp_comm_type), INTENT(IN) :: comm
16689
16690 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dv_src'
16691
16692 INTEGER :: handle
16693#if defined(__parallel)
16694 INTEGER :: ierr, sendcount
16695#endif
16696
16697 CALL mp_timeset(routinen, handle)
16698
16699#if defined(__parallel)
16700 sendcount = SIZE(sendbuf)
16701 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16702 recvbuf, recvcounts, displs, mpi_double_precision, &
16703 comm%source, comm%handle, ierr)
16704 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16705 CALL add_perf(perf_id=4, &
16706 count=1, &
16707 msg_size=sendcount*real_8_size)
16708#else
16709 mark_used(recvcounts)
16710 mark_used(comm)
16711 recvbuf(1 + displs(1):) = sendbuf
16712#endif
16713 CALL mp_timestop(handle)
16714 END SUBROUTINE mp_gatherv_dv_src
16715
16716! **************************************************************************************************
16717!> \brief Gathers data from all processes to one.
16718!> \param[in] sendbuf Data to send to root
16719!> \param[out] recvbuf Received data (on root)
16720!> \param[in] recvcounts Sizes of data received from processes
16721!> \param[in] displs Offsets of data received from processes
16722!> \param[in] root Process which gathers the data
16723!> \param[in] comm Message passing environment identifier
16724!> \par Data length
16725!> Data can have different lengths
16726!> \par Offsets
16727!> Offsets start at 0
16728!> \par MPI mapping
16729!> mpi_gather
16730! **************************************************************************************************
16731 SUBROUTINE mp_gatherv_dm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
16732
16733 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
16734 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
16735 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16736 INTEGER, INTENT(IN) :: root
16737 CLASS(mp_comm_type), INTENT(IN) :: comm
16738
16739 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dm2'
16740
16741 INTEGER :: handle
16742#if defined(__parallel)
16743 INTEGER :: ierr, sendcount
16744#endif
16745
16746 CALL mp_timeset(routinen, handle)
16747
16748#if defined(__parallel)
16749 sendcount = SIZE(sendbuf)
16750 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16751 recvbuf, recvcounts, displs, mpi_double_precision, &
16752 root, comm%handle, ierr)
16753 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16754 CALL add_perf(perf_id=4, &
16755 count=1, &
16756 msg_size=sendcount*real_8_size)
16757#else
16758 mark_used(recvcounts)
16759 mark_used(root)
16760 mark_used(comm)
16761 recvbuf(:, 1 + displs(1):) = sendbuf
16762#endif
16763 CALL mp_timestop(handle)
16764 END SUBROUTINE mp_gatherv_dm2
16765
16766! **************************************************************************************************
16767!> \brief Gathers data from all processes to one.
16768!> \param[in] sendbuf Data to send to root
16769!> \param[out] recvbuf Received data (on root)
16770!> \param[in] recvcounts Sizes of data received from processes
16771!> \param[in] displs Offsets of data received from processes
16772!> \param[in] comm Message passing environment identifier
16773!> \par Data length
16774!> Data can have different lengths
16775!> \par Offsets
16776!> Offsets start at 0
16777!> \par MPI mapping
16778!> mpi_gather
16779! **************************************************************************************************
16780 SUBROUTINE mp_gatherv_dm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
16781
16782 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
16783 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
16784 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16785 CLASS(mp_comm_type), INTENT(IN) :: comm
16786
16787 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dm2_src'
16788
16789 INTEGER :: handle
16790#if defined(__parallel)
16791 INTEGER :: ierr, sendcount
16792#endif
16793
16794 CALL mp_timeset(routinen, handle)
16795
16796#if defined(__parallel)
16797 sendcount = SIZE(sendbuf)
16798 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16799 recvbuf, recvcounts, displs, mpi_double_precision, &
16800 comm%source, comm%handle, ierr)
16801 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16802 CALL add_perf(perf_id=4, &
16803 count=1, &
16804 msg_size=sendcount*real_8_size)
16805#else
16806 mark_used(recvcounts)
16807 mark_used(comm)
16808 recvbuf(:, 1 + displs(1):) = sendbuf
16809#endif
16810 CALL mp_timestop(handle)
16811 END SUBROUTINE mp_gatherv_dm2_src
16812
16813! **************************************************************************************************
16814!> \brief Gathers data from all processes to one.
16815!> \param[in] sendbuf Data to send to root
16816!> \param[out] recvbuf Received data (on root)
16817!> \param[in] recvcounts Sizes of data received from processes
16818!> \param[in] displs Offsets of data received from processes
16819!> \param[in] root Process which gathers the data
16820!> \param[in] comm Message passing environment identifier
16821!> \par Data length
16822!> Data can have different lengths
16823!> \par Offsets
16824!> Offsets start at 0
16825!> \par MPI mapping
16826!> mpi_gather
16827! **************************************************************************************************
16828 SUBROUTINE mp_igatherv_dv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
16829 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: sendbuf
16830 REAL(kind=real_8), DIMENSION(:), INTENT(OUT) :: recvbuf
16831 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16832 INTEGER, INTENT(IN) :: sendcount, root
16833 CLASS(mp_comm_type), INTENT(IN) :: comm
16834 TYPE(mp_request_type), INTENT(OUT) :: request
16835
16836 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_dv'
16837
16838 INTEGER :: handle
16839#if defined(__parallel)
16840 INTEGER :: ierr
16841#endif
16842
16843 CALL mp_timeset(routinen, handle)
16844
16845#if defined(__parallel)
16846#if !defined(__GNUC__) || __GNUC__ >= 9
16847 cpassert(is_contiguous(sendbuf))
16848 cpassert(is_contiguous(recvbuf))
16849 cpassert(is_contiguous(recvcounts))
16850 cpassert(is_contiguous(displs))
16851#endif
16852 CALL mpi_igatherv(sendbuf, sendcount, mpi_double_precision, &
16853 recvbuf, recvcounts, displs, mpi_double_precision, &
16854 root, comm%handle, request%handle, ierr)
16855 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16856 CALL add_perf(perf_id=24, &
16857 count=1, &
16858 msg_size=sendcount*real_8_size)
16859#else
16860 mark_used(sendcount)
16861 mark_used(recvcounts)
16862 mark_used(root)
16863 mark_used(comm)
16864 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
16865 request = mp_request_null
16866#endif
16867 CALL mp_timestop(handle)
16868 END SUBROUTINE mp_igatherv_dv
16869
16870! **************************************************************************************************
16871!> \brief Gathers a datum from all processes and all processes receive the
16872!> same data
16873!> \param[in] msgout Datum to send
16874!> \param[out] msgin Received data
16875!> \param[in] comm Message passing environment identifier
16876!> \par Data size
16877!> All processes send equal-sized data
16878!> \par MPI mapping
16879!> mpi_allgather
16880! **************************************************************************************************
16881 SUBROUTINE mp_allgather_d (msgout, msgin, comm)
16882 REAL(kind=real_8), INTENT(IN) :: 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_d'
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 = 1
16897 rcount = 1
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 = msgout
16905#endif
16906 CALL mp_timestop(handle)
16907 END SUBROUTINE mp_allgather_d
16908
16909! **************************************************************************************************
16910!> \brief Gathers a datum from all processes and all processes receive the
16911!> same data
16912!> \param[in] msgout Datum to send
16913!> \param[out] msgin Received data
16914!> \param[in] comm Message passing environment identifier
16915!> \par Data size
16916!> All processes send equal-sized data
16917!> \par MPI mapping
16918!> mpi_allgather
16919! **************************************************************************************************
16920 SUBROUTINE mp_allgather_d2(msgout, msgin, comm)
16921 REAL(kind=real_8), INTENT(IN) :: msgout
16922 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
16923 CLASS(mp_comm_type), INTENT(IN) :: comm
16924
16925 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d2'
16926
16927 INTEGER :: handle
16928#if defined(__parallel)
16929 INTEGER :: ierr, rcount, scount
16930#endif
16931
16932 CALL mp_timeset(routinen, handle)
16933
16934#if defined(__parallel)
16935 scount = 1
16936 rcount = 1
16937 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16938 msgin, rcount, mpi_double_precision, &
16939 comm%handle, ierr)
16940 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16941#else
16942 mark_used(comm)
16943 msgin = msgout
16944#endif
16945 CALL mp_timestop(handle)
16946 END SUBROUTINE mp_allgather_d2
16947
16948! **************************************************************************************************
16949!> \brief Gathers a datum from all processes and all processes receive the
16950!> same data
16951!> \param[in] msgout Datum to send
16952!> \param[out] msgin Received data
16953!> \param[in] comm Message passing environment identifier
16954!> \par Data size
16955!> All processes send equal-sized data
16956!> \par MPI mapping
16957!> mpi_allgather
16958! **************************************************************************************************
16959 SUBROUTINE mp_iallgather_d (msgout, msgin, comm, request)
16960 REAL(kind=real_8), INTENT(IN) :: msgout
16961 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
16962 CLASS(mp_comm_type), INTENT(IN) :: comm
16963 TYPE(mp_request_type), INTENT(OUT) :: request
16964
16965 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d'
16966
16967 INTEGER :: handle
16968#if defined(__parallel)
16969 INTEGER :: ierr, rcount, scount
16970#endif
16971
16972 CALL mp_timeset(routinen, handle)
16973
16974#if defined(__parallel)
16975#if !defined(__GNUC__) || __GNUC__ >= 9
16976 cpassert(is_contiguous(msgin))
16977#endif
16978 scount = 1
16979 rcount = 1
16980 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
16981 msgin, rcount, mpi_double_precision, &
16982 comm%handle, request%handle, ierr)
16983 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16984#else
16985 mark_used(comm)
16986 msgin = msgout
16987 request = mp_request_null
16988#endif
16989 CALL mp_timestop(handle)
16990 END SUBROUTINE mp_iallgather_d
16991
16992! **************************************************************************************************
16993!> \brief Gathers vector data from all processes and all processes receive the
16994!> same data
16995!> \param[in] msgout Rank-1 data to send
16996!> \param[out] msgin Received data
16997!> \param[in] comm Message passing environment identifier
16998!> \par Data size
16999!> All processes send equal-sized data
17000!> \par Ranks
17001!> The last rank counts the processes
17002!> \par MPI mapping
17003!> mpi_allgather
17004! **************************************************************************************************
17005 SUBROUTINE mp_allgather_d12(msgout, msgin, comm)
17006 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:)
17007 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
17008 CLASS(mp_comm_type), INTENT(IN) :: comm
17009
17010 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d12'
17011
17012 INTEGER :: handle
17013#if defined(__parallel)
17014 INTEGER :: ierr, rcount, scount
17015#endif
17016
17017 CALL mp_timeset(routinen, handle)
17018
17019#if defined(__parallel)
17020 scount = SIZE(msgout(:))
17021 rcount = scount
17022 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17023 msgin, rcount, mpi_double_precision, &
17024 comm%handle, ierr)
17025 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17026#else
17027 mark_used(comm)
17028 msgin(:, 1) = msgout(:)
17029#endif
17030 CALL mp_timestop(handle)
17031 END SUBROUTINE mp_allgather_d12
17032
17033! **************************************************************************************************
17034!> \brief Gathers matrix data from all processes and all processes receive the
17035!> same data
17036!> \param[in] msgout Rank-2 data to send
17037!> \param msgin ...
17038!> \param comm ...
17039!> \note see mp_allgather_d12
17040! **************************************************************************************************
17041 SUBROUTINE mp_allgather_d23(msgout, msgin, comm)
17042 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
17043 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
17044 CLASS(mp_comm_type), INTENT(IN) :: comm
17045
17046 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d23'
17047
17048 INTEGER :: handle
17049#if defined(__parallel)
17050 INTEGER :: ierr, rcount, scount
17051#endif
17052
17053 CALL mp_timeset(routinen, handle)
17054
17055#if defined(__parallel)
17056 scount = SIZE(msgout(:, :))
17057 rcount = scount
17058 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17059 msgin, rcount, mpi_double_precision, &
17060 comm%handle, ierr)
17061 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17062#else
17063 mark_used(comm)
17064 msgin(:, :, 1) = msgout(:, :)
17065#endif
17066 CALL mp_timestop(handle)
17067 END SUBROUTINE mp_allgather_d23
17068
17069! **************************************************************************************************
17070!> \brief Gathers rank-3 data from all processes and all processes receive the
17071!> same data
17072!> \param[in] msgout Rank-3 data to send
17073!> \param msgin ...
17074!> \param comm ...
17075!> \note see mp_allgather_d12
17076! **************************************************************************************************
17077 SUBROUTINE mp_allgather_d34(msgout, msgin, comm)
17078 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
17079 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
17080 CLASS(mp_comm_type), INTENT(IN) :: comm
17081
17082 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d34'
17083
17084 INTEGER :: handle
17085#if defined(__parallel)
17086 INTEGER :: ierr, rcount, scount
17087#endif
17088
17089 CALL mp_timeset(routinen, handle)
17090
17091#if defined(__parallel)
17092 scount = SIZE(msgout(:, :, :))
17093 rcount = scount
17094 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17095 msgin, rcount, mpi_double_precision, &
17096 comm%handle, ierr)
17097 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17098#else
17099 mark_used(comm)
17100 msgin(:, :, :, 1) = msgout(:, :, :)
17101#endif
17102 CALL mp_timestop(handle)
17103 END SUBROUTINE mp_allgather_d34
17104
17105! **************************************************************************************************
17106!> \brief Gathers rank-2 data from all processes and all processes receive the
17107!> same data
17108!> \param[in] msgout Rank-2 data to send
17109!> \param msgin ...
17110!> \param comm ...
17111!> \note see mp_allgather_d12
17112! **************************************************************************************************
17113 SUBROUTINE mp_allgather_d22(msgout, msgin, comm)
17114 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
17115 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
17116 CLASS(mp_comm_type), INTENT(IN) :: comm
17117
17118 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d22'
17119
17120 INTEGER :: handle
17121#if defined(__parallel)
17122 INTEGER :: ierr, rcount, scount
17123#endif
17124
17125 CALL mp_timeset(routinen, handle)
17126
17127#if defined(__parallel)
17128 scount = SIZE(msgout(:, :))
17129 rcount = scount
17130 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17131 msgin, rcount, mpi_double_precision, &
17132 comm%handle, ierr)
17133 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17134#else
17135 mark_used(comm)
17136 msgin(:, :) = msgout(:, :)
17137#endif
17138 CALL mp_timestop(handle)
17139 END SUBROUTINE mp_allgather_d22
17140
17141! **************************************************************************************************
17142!> \brief Gathers rank-1 data from all processes and all processes receive the
17143!> same data
17144!> \param[in] msgout Rank-1 data to send
17145!> \param msgin ...
17146!> \param comm ...
17147!> \param request ...
17148!> \note see mp_allgather_d11
17149! **************************************************************************************************
17150 SUBROUTINE mp_iallgather_d11(msgout, msgin, comm, request)
17151 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17152 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17153 CLASS(mp_comm_type), INTENT(IN) :: comm
17154 TYPE(mp_request_type), INTENT(OUT) :: request
17155
17156 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d11'
17157
17158 INTEGER :: handle
17159#if defined(__parallel)
17160 INTEGER :: ierr, rcount, scount
17161#endif
17162
17163 CALL mp_timeset(routinen, handle)
17164
17165#if defined(__parallel)
17166#if !defined(__GNUC__) || __GNUC__ >= 9
17167 cpassert(is_contiguous(msgout))
17168 cpassert(is_contiguous(msgin))
17169#endif
17170 scount = SIZE(msgout(:))
17171 rcount = scount
17172 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17173 msgin, rcount, mpi_double_precision, &
17174 comm%handle, request%handle, ierr)
17175 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17176#else
17177 mark_used(comm)
17178 msgin = msgout
17179 request = mp_request_null
17180#endif
17181 CALL mp_timestop(handle)
17182 END SUBROUTINE mp_iallgather_d11
17183
17184! **************************************************************************************************
17185!> \brief Gathers rank-2 data from all processes and all processes receive the
17186!> same data
17187!> \param[in] msgout Rank-2 data to send
17188!> \param msgin ...
17189!> \param comm ...
17190!> \param request ...
17191!> \note see mp_allgather_d12
17192! **************************************************************************************************
17193 SUBROUTINE mp_iallgather_d13(msgout, msgin, comm, request)
17194 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17195 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
17196 CLASS(mp_comm_type), INTENT(IN) :: comm
17197 TYPE(mp_request_type), INTENT(OUT) :: request
17198
17199 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d13'
17200
17201 INTEGER :: handle
17202#if defined(__parallel)
17203 INTEGER :: ierr, rcount, scount
17204#endif
17205
17206 CALL mp_timeset(routinen, handle)
17207
17208#if defined(__parallel)
17209#if !defined(__GNUC__) || __GNUC__ >= 9
17210 cpassert(is_contiguous(msgout))
17211 cpassert(is_contiguous(msgin))
17212#endif
17213
17214 scount = SIZE(msgout(:))
17215 rcount = scount
17216 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17217 msgin, rcount, mpi_double_precision, &
17218 comm%handle, request%handle, ierr)
17219 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17220#else
17221 mark_used(comm)
17222 msgin(:, 1, 1) = msgout(:)
17223 request = mp_request_null
17224#endif
17225 CALL mp_timestop(handle)
17226 END SUBROUTINE mp_iallgather_d13
17227
17228! **************************************************************************************************
17229!> \brief Gathers rank-2 data from all processes and all processes receive the
17230!> same data
17231!> \param[in] msgout Rank-2 data to send
17232!> \param msgin ...
17233!> \param comm ...
17234!> \param request ...
17235!> \note see mp_allgather_d12
17236! **************************************************************************************************
17237 SUBROUTINE mp_iallgather_d22(msgout, msgin, comm, request)
17238 REAL(kind=real_8), INTENT(IN) :: msgout(:, :)
17239 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :)
17240 CLASS(mp_comm_type), INTENT(IN) :: comm
17241 TYPE(mp_request_type), INTENT(OUT) :: request
17242
17243 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d22'
17244
17245 INTEGER :: handle
17246#if defined(__parallel)
17247 INTEGER :: ierr, rcount, scount
17248#endif
17249
17250 CALL mp_timeset(routinen, handle)
17251
17252#if defined(__parallel)
17253#if !defined(__GNUC__) || __GNUC__ >= 9
17254 cpassert(is_contiguous(msgout))
17255 cpassert(is_contiguous(msgin))
17256#endif
17257
17258 scount = SIZE(msgout(:, :))
17259 rcount = scount
17260 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17261 msgin, rcount, mpi_double_precision, &
17262 comm%handle, request%handle, ierr)
17263 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17264#else
17265 mark_used(comm)
17266 msgin(:, :) = msgout(:, :)
17267 request = mp_request_null
17268#endif
17269 CALL mp_timestop(handle)
17270 END SUBROUTINE mp_iallgather_d22
17271
17272! **************************************************************************************************
17273!> \brief Gathers rank-2 data from all processes and all processes receive the
17274!> same data
17275!> \param[in] msgout Rank-2 data to send
17276!> \param msgin ...
17277!> \param comm ...
17278!> \param request ...
17279!> \note see mp_allgather_d12
17280! **************************************************************************************************
17281 SUBROUTINE mp_iallgather_d24(msgout, msgin, comm, request)
17282 REAL(kind=real_8), INTENT(IN) :: msgout(:, :)
17283 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :, :)
17284 CLASS(mp_comm_type), INTENT(IN) :: comm
17285 TYPE(mp_request_type), INTENT(OUT) :: request
17286
17287 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d24'
17288
17289 INTEGER :: handle
17290#if defined(__parallel)
17291 INTEGER :: ierr, rcount, scount
17292#endif
17293
17294 CALL mp_timeset(routinen, handle)
17295
17296#if defined(__parallel)
17297#if !defined(__GNUC__) || __GNUC__ >= 9
17298 cpassert(is_contiguous(msgout))
17299 cpassert(is_contiguous(msgin))
17300#endif
17301
17302 scount = SIZE(msgout(:, :))
17303 rcount = scount
17304 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17305 msgin, rcount, mpi_double_precision, &
17306 comm%handle, request%handle, ierr)
17307 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17308#else
17309 mark_used(comm)
17310 msgin(:, :, 1, 1) = msgout(:, :)
17311 request = mp_request_null
17312#endif
17313 CALL mp_timestop(handle)
17314 END SUBROUTINE mp_iallgather_d24
17315
17316! **************************************************************************************************
17317!> \brief Gathers rank-3 data from all processes and all processes receive the
17318!> same data
17319!> \param[in] msgout Rank-3 data to send
17320!> \param msgin ...
17321!> \param comm ...
17322!> \param request ...
17323!> \note see mp_allgather_d12
17324! **************************************************************************************************
17325 SUBROUTINE mp_iallgather_d33(msgout, msgin, comm, request)
17326 REAL(kind=real_8), INTENT(IN) :: msgout(:, :, :)
17327 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
17328 CLASS(mp_comm_type), INTENT(IN) :: comm
17329 TYPE(mp_request_type), INTENT(OUT) :: request
17330
17331 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d33'
17332
17333 INTEGER :: handle
17334#if defined(__parallel)
17335 INTEGER :: ierr, rcount, scount
17336#endif
17337
17338 CALL mp_timeset(routinen, handle)
17339
17340#if defined(__parallel)
17341#if !defined(__GNUC__) || __GNUC__ >= 9
17342 cpassert(is_contiguous(msgout))
17343 cpassert(is_contiguous(msgin))
17344#endif
17345
17346 scount = SIZE(msgout(:, :, :))
17347 rcount = scount
17348 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17349 msgin, rcount, mpi_double_precision, &
17350 comm%handle, request%handle, ierr)
17351 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17352#else
17353 mark_used(comm)
17354 msgin(:, :, :) = msgout(:, :, :)
17355 request = mp_request_null
17356#endif
17357 CALL mp_timestop(handle)
17358 END SUBROUTINE mp_iallgather_d33
17359
17360! **************************************************************************************************
17361!> \brief Gathers vector data from all processes and all processes receive the
17362!> same data
17363!> \param[in] msgout Rank-1 data to send
17364!> \param[out] msgin Received data
17365!> \param[in] rcount Size of sent data for every process
17366!> \param[in] rdispl Offset of sent data for every process
17367!> \param[in] comm Message passing environment identifier
17368!> \par Data size
17369!> Processes can send different-sized data
17370!> \par Ranks
17371!> The last rank counts the processes
17372!> \par Offsets
17373!> Offsets are from 0
17374!> \par MPI mapping
17375!> mpi_allgather
17376! **************************************************************************************************
17377 SUBROUTINE mp_allgatherv_dv(msgout, msgin, rcount, rdispl, comm)
17378 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
17379 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17380 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17381 CLASS(mp_comm_type), INTENT(IN) :: comm
17382
17383 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_dv'
17384
17385 INTEGER :: handle
17386#if defined(__parallel)
17387 INTEGER :: ierr, scount
17388#endif
17389
17390 CALL mp_timeset(routinen, handle)
17391
17392#if defined(__parallel)
17393 scount = SIZE(msgout)
17394 CALL mpi_allgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17395 rdispl, mpi_double_precision, comm%handle, ierr)
17396 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
17397#else
17398 mark_used(rcount)
17399 mark_used(rdispl)
17400 mark_used(comm)
17401 msgin = msgout
17402#endif
17403 CALL mp_timestop(handle)
17404 END SUBROUTINE mp_allgatherv_dv
17405
17406! **************************************************************************************************
17407!> \brief Gathers vector data from all processes and all processes receive the
17408!> same data
17409!> \param[in] msgout Rank-1 data to send
17410!> \param[out] msgin Received data
17411!> \param[in] rcount Size of sent data for every process
17412!> \param[in] rdispl Offset of sent data for every process
17413!> \param[in] comm Message passing environment identifier
17414!> \par Data size
17415!> Processes can send different-sized data
17416!> \par Ranks
17417!> The last rank counts the processes
17418!> \par Offsets
17419!> Offsets are from 0
17420!> \par MPI mapping
17421!> mpi_allgather
17422! **************************************************************************************************
17423 SUBROUTINE mp_allgatherv_dm2(msgout, msgin, rcount, rdispl, comm)
17424 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
17425 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
17426 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17427 CLASS(mp_comm_type), INTENT(IN) :: comm
17428
17429 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_dv'
17430
17431 INTEGER :: handle
17432#if defined(__parallel)
17433 INTEGER :: ierr, scount
17434#endif
17435
17436 CALL mp_timeset(routinen, handle)
17437
17438#if defined(__parallel)
17439 scount = SIZE(msgout)
17440 CALL mpi_allgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17441 rdispl, mpi_double_precision, comm%handle, ierr)
17442 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
17443#else
17444 mark_used(rcount)
17445 mark_used(rdispl)
17446 mark_used(comm)
17447 msgin = msgout
17448#endif
17449 CALL mp_timestop(handle)
17450 END SUBROUTINE mp_allgatherv_dm2
17451
17452! **************************************************************************************************
17453!> \brief Gathers vector data from all processes and all processes receive the
17454!> same data
17455!> \param[in] msgout Rank-1 data to send
17456!> \param[out] msgin Received data
17457!> \param[in] rcount Size of sent data for every process
17458!> \param[in] rdispl Offset of sent data for every process
17459!> \param[in] comm Message passing environment identifier
17460!> \par Data size
17461!> Processes can send different-sized data
17462!> \par Ranks
17463!> The last rank counts the processes
17464!> \par Offsets
17465!> Offsets are from 0
17466!> \par MPI mapping
17467!> mpi_allgather
17468! **************************************************************************************************
17469 SUBROUTINE mp_iallgatherv_dv(msgout, msgin, rcount, rdispl, comm, request)
17470 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17471 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17472 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17473 CLASS(mp_comm_type), INTENT(IN) :: comm
17474 TYPE(mp_request_type), INTENT(OUT) :: request
17475
17476 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_dv'
17477
17478 INTEGER :: handle
17479#if defined(__parallel)
17480 INTEGER :: ierr, scount, rsize
17481#endif
17482
17483 CALL mp_timeset(routinen, handle)
17484
17485#if defined(__parallel)
17486#if !defined(__GNUC__) || __GNUC__ >= 9
17487 cpassert(is_contiguous(msgout))
17488 cpassert(is_contiguous(msgin))
17489 cpassert(is_contiguous(rcount))
17490 cpassert(is_contiguous(rdispl))
17491#endif
17492
17493 scount = SIZE(msgout)
17494 rsize = SIZE(rcount)
17495 CALL mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, &
17496 rdispl, comm, request, ierr)
17497 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
17498#else
17499 mark_used(rcount)
17500 mark_used(rdispl)
17501 mark_used(comm)
17502 msgin = msgout
17503 request = mp_request_null
17504#endif
17505 CALL mp_timestop(handle)
17506 END SUBROUTINE mp_iallgatherv_dv
17507
17508! **************************************************************************************************
17509!> \brief Gathers vector data from all processes and all processes receive the
17510!> same data
17511!> \param[in] msgout Rank-1 data to send
17512!> \param[out] msgin Received data
17513!> \param[in] rcount Size of sent data for every process
17514!> \param[in] rdispl Offset of sent data for every process
17515!> \param[in] comm Message passing environment identifier
17516!> \par Data size
17517!> Processes can send different-sized data
17518!> \par Ranks
17519!> The last rank counts the processes
17520!> \par Offsets
17521!> Offsets are from 0
17522!> \par MPI mapping
17523!> mpi_allgather
17524! **************************************************************************************************
17525 SUBROUTINE mp_iallgatherv_dv2(msgout, msgin, rcount, rdispl, comm, request)
17526 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17527 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17528 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
17529 CLASS(mp_comm_type), INTENT(IN) :: comm
17530 TYPE(mp_request_type), INTENT(OUT) :: request
17531
17532 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_dv2'
17533
17534 INTEGER :: handle
17535#if defined(__parallel)
17536 INTEGER :: ierr, scount, rsize
17537#endif
17538
17539 CALL mp_timeset(routinen, handle)
17540
17541#if defined(__parallel)
17542#if !defined(__GNUC__) || __GNUC__ >= 9
17543 cpassert(is_contiguous(msgout))
17544 cpassert(is_contiguous(msgin))
17545 cpassert(is_contiguous(rcount))
17546 cpassert(is_contiguous(rdispl))
17547#endif
17548
17549 scount = SIZE(msgout)
17550 rsize = SIZE(rcount)
17551 CALL mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, &
17552 rdispl, comm, request, ierr)
17553 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
17554#else
17555 mark_used(rcount)
17556 mark_used(rdispl)
17557 mark_used(comm)
17558 msgin = msgout
17559 request = mp_request_null
17560#endif
17561 CALL mp_timestop(handle)
17562 END SUBROUTINE mp_iallgatherv_dv2
17563
17564! **************************************************************************************************
17565!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
17566!> the issue is with the rank of rcount and rdispl
17567!> \param count ...
17568!> \param array_of_requests ...
17569!> \param array_of_statuses ...
17570!> \param ierr ...
17571!> \author Alfio Lazzaro
17572! **************************************************************************************************
17573#if defined(__parallel)
17574 SUBROUTINE mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
17575 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
17576 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17577 INTEGER, INTENT(IN) :: rsize
17578 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
17579 CLASS(mp_comm_type), INTENT(IN) :: comm
17580 TYPE(mp_request_type), INTENT(OUT) :: request
17581 INTEGER, INTENT(INOUT) :: ierr
17582
17583 CALL mpi_iallgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17584 rdispl, mpi_double_precision, comm%handle, request%handle, ierr)
17585
17586 END SUBROUTINE mp_iallgatherv_dv_internal
17587#endif
17588
17589! **************************************************************************************************
17590!> \brief Sums a vector and partitions the result among processes
17591!> \param[in] msgout Data to sum
17592!> \param[out] msgin Received portion of summed data
17593!> \param[in] rcount Partition sizes of the summed data for
17594!> every process
17595!> \param[in] comm Message passing environment identifier
17596! **************************************************************************************************
17597 SUBROUTINE mp_sum_scatter_dv(msgout, msgin, rcount, comm)
17598 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
17599 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17600 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
17601 CLASS(mp_comm_type), INTENT(IN) :: comm
17602
17603 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_dv'
17604
17605 INTEGER :: handle
17606#if defined(__parallel)
17607 INTEGER :: ierr
17608#endif
17609
17610 CALL mp_timeset(routinen, handle)
17611
17612#if defined(__parallel)
17613 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_double_precision, mpi_sum, &
17614 comm%handle, ierr)
17615 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
17616
17617 CALL add_perf(perf_id=3, count=1, &
17618 msg_size=rcount(1)*2*real_8_size)
17619#else
17620 mark_used(rcount)
17621 mark_used(comm)
17622 msgin = msgout(:, 1)
17623#endif
17624 CALL mp_timestop(handle)
17625 END SUBROUTINE mp_sum_scatter_dv
17626
17627! **************************************************************************************************
17628!> \brief Sends and receives vector data
17629!> \param[in] msgin Data to send
17630!> \param[in] dest Process to send data to
17631!> \param[out] msgout Received data
17632!> \param[in] source Process from which to receive
17633!> \param[in] comm Message passing environment identifier
17634!> \param[in] tag Send and recv tag (default: 0)
17635! **************************************************************************************************
17636 SUBROUTINE mp_sendrecv_d (msgin, dest, msgout, source, comm, tag)
17637 REAL(kind=real_8), INTENT(IN) :: msgin
17638 INTEGER, INTENT(IN) :: dest
17639 REAL(kind=real_8), INTENT(OUT) :: msgout
17640 INTEGER, INTENT(IN) :: source
17641 CLASS(mp_comm_type), INTENT(IN) :: comm
17642 INTEGER, INTENT(IN), OPTIONAL :: tag
17643
17644 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_d'
17645
17646 INTEGER :: handle
17647#if defined(__parallel)
17648 INTEGER :: ierr, msglen_in, msglen_out, &
17649 recv_tag, send_tag
17650#endif
17651
17652 CALL mp_timeset(routinen, handle)
17653
17654#if defined(__parallel)
17655 msglen_in = 1
17656 msglen_out = 1
17657 send_tag = 0 ! cannot think of something better here, this might be dangerous
17658 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17659 IF (PRESENT(tag)) THEN
17660 send_tag = tag
17661 recv_tag = tag
17662 END IF
17663 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17664 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17665 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17666 CALL add_perf(perf_id=7, count=1, &
17667 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17668#else
17669 mark_used(dest)
17670 mark_used(source)
17671 mark_used(comm)
17672 mark_used(tag)
17673 msgout = msgin
17674#endif
17675 CALL mp_timestop(handle)
17676 END SUBROUTINE mp_sendrecv_d
17677
17678! **************************************************************************************************
17679!> \brief Sends and receives vector data
17680!> \param[in] msgin Data to send
17681!> \param[in] dest Process to send data to
17682!> \param[out] msgout Received data
17683!> \param[in] source Process from which to receive
17684!> \param[in] comm Message passing environment identifier
17685!> \param[in] tag Send and recv tag (default: 0)
17686! **************************************************************************************************
17687 SUBROUTINE mp_sendrecv_dv(msgin, dest, msgout, source, comm, tag)
17688 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
17689 INTEGER, INTENT(IN) :: dest
17690 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
17691 INTEGER, INTENT(IN) :: source
17692 CLASS(mp_comm_type), INTENT(IN) :: comm
17693 INTEGER, INTENT(IN), OPTIONAL :: tag
17694
17695 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dv'
17696
17697 INTEGER :: handle
17698#if defined(__parallel)
17699 INTEGER :: ierr, msglen_in, msglen_out, &
17700 recv_tag, send_tag
17701#endif
17702
17703 CALL mp_timeset(routinen, handle)
17704
17705#if defined(__parallel)
17706 msglen_in = SIZE(msgin)
17707 msglen_out = SIZE(msgout)
17708 send_tag = 0 ! cannot think of something better here, this might be dangerous
17709 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17710 IF (PRESENT(tag)) THEN
17711 send_tag = tag
17712 recv_tag = tag
17713 END IF
17714 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17715 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17716 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17717 CALL add_perf(perf_id=7, count=1, &
17718 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17719#else
17720 mark_used(dest)
17721 mark_used(source)
17722 mark_used(comm)
17723 mark_used(tag)
17724 msgout = msgin
17725#endif
17726 CALL mp_timestop(handle)
17727 END SUBROUTINE mp_sendrecv_dv
17728
17729! **************************************************************************************************
17730!> \brief Sends and receives matrix data
17731!> \param msgin ...
17732!> \param dest ...
17733!> \param msgout ...
17734!> \param source ...
17735!> \param comm ...
17736!> \param tag ...
17737!> \note see mp_sendrecv_dv
17738! **************************************************************************************************
17739 SUBROUTINE mp_sendrecv_dm2(msgin, dest, msgout, source, comm, tag)
17740 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
17741 INTEGER, INTENT(IN) :: dest
17742 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
17743 INTEGER, INTENT(IN) :: source
17744 CLASS(mp_comm_type), INTENT(IN) :: comm
17745 INTEGER, INTENT(IN), OPTIONAL :: tag
17746
17747 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm2'
17748
17749 INTEGER :: handle
17750#if defined(__parallel)
17751 INTEGER :: ierr, msglen_in, msglen_out, &
17752 recv_tag, send_tag
17753#endif
17754
17755 CALL mp_timeset(routinen, handle)
17756
17757#if defined(__parallel)
17758 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
17759 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
17760 send_tag = 0 ! cannot think of something better here, this might be dangerous
17761 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17762 IF (PRESENT(tag)) THEN
17763 send_tag = tag
17764 recv_tag = tag
17765 END IF
17766 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17767 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17768 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17769 CALL add_perf(perf_id=7, count=1, &
17770 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17771#else
17772 mark_used(dest)
17773 mark_used(source)
17774 mark_used(comm)
17775 mark_used(tag)
17776 msgout = msgin
17777#endif
17778 CALL mp_timestop(handle)
17779 END SUBROUTINE mp_sendrecv_dm2
17780
17781! **************************************************************************************************
17782!> \brief Sends and receives rank-3 data
17783!> \param msgin ...
17784!> \param dest ...
17785!> \param msgout ...
17786!> \param source ...
17787!> \param comm ...
17788!> \note see mp_sendrecv_dv
17789! **************************************************************************************************
17790 SUBROUTINE mp_sendrecv_dm3(msgin, dest, msgout, source, comm, tag)
17791 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
17792 INTEGER, INTENT(IN) :: dest
17793 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
17794 INTEGER, INTENT(IN) :: source
17795 CLASS(mp_comm_type), INTENT(IN) :: comm
17796 INTEGER, INTENT(IN), OPTIONAL :: tag
17797
17798 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm3'
17799
17800 INTEGER :: handle
17801#if defined(__parallel)
17802 INTEGER :: ierr, msglen_in, msglen_out, &
17803 recv_tag, send_tag
17804#endif
17805
17806 CALL mp_timeset(routinen, handle)
17807
17808#if defined(__parallel)
17809 msglen_in = SIZE(msgin)
17810 msglen_out = SIZE(msgout)
17811 send_tag = 0 ! cannot think of something better here, this might be dangerous
17812 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17813 IF (PRESENT(tag)) THEN
17814 send_tag = tag
17815 recv_tag = tag
17816 END IF
17817 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17818 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17819 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17820 CALL add_perf(perf_id=7, count=1, &
17821 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17822#else
17823 mark_used(dest)
17824 mark_used(source)
17825 mark_used(comm)
17826 mark_used(tag)
17827 msgout = msgin
17828#endif
17829 CALL mp_timestop(handle)
17830 END SUBROUTINE mp_sendrecv_dm3
17831
17832! **************************************************************************************************
17833!> \brief Sends and receives rank-4 data
17834!> \param msgin ...
17835!> \param dest ...
17836!> \param msgout ...
17837!> \param source ...
17838!> \param comm ...
17839!> \note see mp_sendrecv_dv
17840! **************************************************************************************************
17841 SUBROUTINE mp_sendrecv_dm4(msgin, dest, msgout, source, comm, tag)
17842 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
17843 INTEGER, INTENT(IN) :: dest
17844 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
17845 INTEGER, INTENT(IN) :: source
17846 CLASS(mp_comm_type), INTENT(IN) :: comm
17847 INTEGER, INTENT(IN), OPTIONAL :: tag
17848
17849 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm4'
17850
17851 INTEGER :: handle
17852#if defined(__parallel)
17853 INTEGER :: ierr, msglen_in, msglen_out, &
17854 recv_tag, send_tag
17855#endif
17856
17857 CALL mp_timeset(routinen, handle)
17858
17859#if defined(__parallel)
17860 msglen_in = SIZE(msgin)
17861 msglen_out = SIZE(msgout)
17862 send_tag = 0 ! cannot think of something better here, this might be dangerous
17863 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17864 IF (PRESENT(tag)) THEN
17865 send_tag = tag
17866 recv_tag = tag
17867 END IF
17868 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17869 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17870 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17871 CALL add_perf(perf_id=7, count=1, &
17872 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17873#else
17874 mark_used(dest)
17875 mark_used(source)
17876 mark_used(comm)
17877 mark_used(tag)
17878 msgout = msgin
17879#endif
17880 CALL mp_timestop(handle)
17881 END SUBROUTINE mp_sendrecv_dm4
17882
17883! **************************************************************************************************
17884!> \brief Non-blocking send and receive of a scalar
17885!> \param[in] msgin Scalar data to send
17886!> \param[in] dest Which process to send to
17887!> \param[out] msgout Receive data into this pointer
17888!> \param[in] source Process to receive from
17889!> \param[in] comm Message passing environment identifier
17890!> \param[out] send_request Request handle for the send
17891!> \param[out] recv_request Request handle for the receive
17892!> \param[in] tag (optional) tag to differentiate requests
17893!> \par Implementation
17894!> Calls mpi_isend and mpi_irecv.
17895!> \par History
17896!> 02.2005 created [Alfio Lazzaro]
17897! **************************************************************************************************
17898 SUBROUTINE mp_isendrecv_d (msgin, dest, msgout, source, comm, send_request, &
17899 recv_request, tag)
17900 REAL(kind=real_8), INTENT(IN) :: msgin
17901 INTEGER, INTENT(IN) :: dest
17902 REAL(kind=real_8), INTENT(INOUT) :: msgout
17903 INTEGER, INTENT(IN) :: source
17904 CLASS(mp_comm_type), INTENT(IN) :: comm
17905 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
17906 INTEGER, INTENT(in), OPTIONAL :: tag
17907
17908 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_d'
17909
17910 INTEGER :: handle
17911#if defined(__parallel)
17912 INTEGER :: ierr, my_tag
17913#endif
17914
17915 CALL mp_timeset(routinen, handle)
17916
17917#if defined(__parallel)
17918 my_tag = 0
17919 IF (PRESENT(tag)) my_tag = tag
17920
17921 CALL mpi_irecv(msgout, 1, mpi_double_precision, source, my_tag, &
17922 comm%handle, recv_request%handle, ierr)
17923 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
17924
17925 CALL mpi_isend(msgin, 1, mpi_double_precision, dest, my_tag, &
17926 comm%handle, send_request%handle, ierr)
17927 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
17928
17929 CALL add_perf(perf_id=8, count=1, msg_size=2*real_8_size)
17930#else
17931 mark_used(dest)
17932 mark_used(source)
17933 mark_used(comm)
17934 mark_used(tag)
17935 send_request = mp_request_null
17936 recv_request = mp_request_null
17937 msgout = msgin
17938#endif
17939 CALL mp_timestop(handle)
17940 END SUBROUTINE mp_isendrecv_d
17941
17942! **************************************************************************************************
17943!> \brief Non-blocking send and receive of a vector
17944!> \param[in] msgin Vector data to send
17945!> \param[in] dest Which process to send to
17946!> \param[out] msgout Receive data into this pointer
17947!> \param[in] source Process to receive from
17948!> \param[in] comm Message passing environment identifier
17949!> \param[out] send_request Request handle for the send
17950!> \param[out] recv_request Request handle for the receive
17951!> \param[in] tag (optional) tag to differentiate requests
17952!> \par Implementation
17953!> Calls mpi_isend and mpi_irecv.
17954!> \par History
17955!> 11.2004 created [Joost VandeVondele]
17956!> \note
17957!> arrays can be pointers or assumed shape, but they must be contiguous!
17958! **************************************************************************************************
17959 SUBROUTINE mp_isendrecv_dv(msgin, dest, msgout, source, comm, send_request, &
17960 recv_request, tag)
17961 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
17962 INTEGER, INTENT(IN) :: dest
17963 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
17964 INTEGER, INTENT(IN) :: source
17965 CLASS(mp_comm_type), INTENT(IN) :: comm
17966 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
17967 INTEGER, INTENT(in), OPTIONAL :: tag
17968
17969 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_dv'
17970
17971 INTEGER :: handle
17972#if defined(__parallel)
17973 INTEGER :: ierr, msglen, my_tag
17974 REAL(kind=real_8) :: foo
17975#endif
17976
17977 CALL mp_timeset(routinen, handle)
17978
17979#if defined(__parallel)
17980#if !defined(__GNUC__) || __GNUC__ >= 9
17981 cpassert(is_contiguous(msgout))
17982 cpassert(is_contiguous(msgin))
17983#endif
17984
17985 my_tag = 0
17986 IF (PRESENT(tag)) my_tag = tag
17987
17988 msglen = SIZE(msgout, 1)
17989 IF (msglen > 0) THEN
17990 CALL mpi_irecv(msgout(1), msglen, mpi_double_precision, source, my_tag, &
17991 comm%handle, recv_request%handle, ierr)
17992 ELSE
17993 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
17994 comm%handle, recv_request%handle, ierr)
17995 END IF
17996 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
17997
17998 msglen = SIZE(msgin, 1)
17999 IF (msglen > 0) THEN
18000 CALL mpi_isend(msgin(1), msglen, mpi_double_precision, dest, my_tag, &
18001 comm%handle, send_request%handle, ierr)
18002 ELSE
18003 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18004 comm%handle, send_request%handle, ierr)
18005 END IF
18006 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18007
18008 msglen = (msglen + SIZE(msgout, 1) + 1)/2
18009 CALL add_perf(perf_id=8, count=1, msg_size=msglen*real_8_size)
18010#else
18011 mark_used(dest)
18012 mark_used(source)
18013 mark_used(comm)
18014 mark_used(tag)
18015 send_request = mp_request_null
18016 recv_request = mp_request_null
18017 msgout = msgin
18018#endif
18019 CALL mp_timestop(handle)
18020 END SUBROUTINE mp_isendrecv_dv
18021
18022! **************************************************************************************************
18023!> \brief Non-blocking send of vector data
18024!> \param msgin ...
18025!> \param dest ...
18026!> \param comm ...
18027!> \param request ...
18028!> \param tag ...
18029!> \par History
18030!> 08.2003 created [f&j]
18031!> \note see mp_isendrecv_dv
18032!> \note
18033!> arrays can be pointers or assumed shape, but they must be contiguous!
18034! **************************************************************************************************
18035 SUBROUTINE mp_isend_dv(msgin, dest, comm, request, tag)
18036 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
18037 INTEGER, INTENT(IN) :: dest
18038 CLASS(mp_comm_type), INTENT(IN) :: comm
18039 TYPE(mp_request_type), INTENT(out) :: request
18040 INTEGER, INTENT(in), OPTIONAL :: tag
18041
18042 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dv'
18043
18044 INTEGER :: handle, ierr
18045#if defined(__parallel)
18046 INTEGER :: msglen, my_tag
18047 REAL(kind=real_8) :: foo(1)
18048#endif
18049
18050 CALL mp_timeset(routinen, handle)
18051
18052#if defined(__parallel)
18053#if !defined(__GNUC__) || __GNUC__ >= 9
18054 cpassert(is_contiguous(msgin))
18055#endif
18056 my_tag = 0
18057 IF (PRESENT(tag)) my_tag = tag
18058
18059 msglen = SIZE(msgin)
18060 IF (msglen > 0) THEN
18061 CALL mpi_isend(msgin(1), msglen, mpi_double_precision, dest, my_tag, &
18062 comm%handle, request%handle, ierr)
18063 ELSE
18064 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18065 comm%handle, request%handle, ierr)
18066 END IF
18067 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18068
18069 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18070#else
18071 mark_used(msgin)
18072 mark_used(dest)
18073 mark_used(comm)
18074 mark_used(request)
18075 mark_used(tag)
18076 ierr = 1
18077 request = mp_request_null
18078 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18079#endif
18080 CALL mp_timestop(handle)
18081 END SUBROUTINE mp_isend_dv
18082
18083! **************************************************************************************************
18084!> \brief Non-blocking send of matrix data
18085!> \param msgin ...
18086!> \param dest ...
18087!> \param comm ...
18088!> \param request ...
18089!> \param tag ...
18090!> \par History
18091!> 2009-11-25 [UB] Made type-generic for templates
18092!> \author fawzi
18093!> \note see mp_isendrecv_dv
18094!> \note see mp_isend_dv
18095!> \note
18096!> arrays can be pointers or assumed shape, but they must be contiguous!
18097! **************************************************************************************************
18098 SUBROUTINE mp_isend_dm2(msgin, dest, comm, request, tag)
18099 REAL(kind=real_8), DIMENSION(:, :), INTENT(IN) :: msgin
18100 INTEGER, INTENT(IN) :: dest
18101 CLASS(mp_comm_type), INTENT(IN) :: comm
18102 TYPE(mp_request_type), INTENT(out) :: request
18103 INTEGER, INTENT(in), OPTIONAL :: tag
18104
18105 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm2'
18106
18107 INTEGER :: handle, ierr
18108#if defined(__parallel)
18109 INTEGER :: msglen, my_tag
18110 REAL(kind=real_8) :: foo(1)
18111#endif
18112
18113 CALL mp_timeset(routinen, handle)
18114
18115#if defined(__parallel)
18116#if !defined(__GNUC__) || __GNUC__ >= 9
18117 cpassert(is_contiguous(msgin))
18118#endif
18119
18120 my_tag = 0
18121 IF (PRESENT(tag)) my_tag = tag
18122
18123 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
18124 IF (msglen > 0) THEN
18125 CALL mpi_isend(msgin(1, 1), msglen, mpi_double_precision, dest, my_tag, &
18126 comm%handle, request%handle, ierr)
18127 ELSE
18128 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18129 comm%handle, request%handle, ierr)
18130 END IF
18131 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18132
18133 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18134#else
18135 mark_used(msgin)
18136 mark_used(dest)
18137 mark_used(comm)
18138 mark_used(request)
18139 mark_used(tag)
18140 ierr = 1
18141 request = mp_request_null
18142 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18143#endif
18144 CALL mp_timestop(handle)
18145 END SUBROUTINE mp_isend_dm2
18146
18147! **************************************************************************************************
18148!> \brief Non-blocking send of rank-3 data
18149!> \param msgin ...
18150!> \param dest ...
18151!> \param comm ...
18152!> \param request ...
18153!> \param tag ...
18154!> \par History
18155!> 9.2008 added _rm3 subroutine [Iain Bethune]
18156!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
18157!> 2009-11-25 [UB] Made type-generic for templates
18158!> \author fawzi
18159!> \note see mp_isendrecv_dv
18160!> \note see mp_isend_dv
18161!> \note
18162!> arrays can be pointers or assumed shape, but they must be contiguous!
18163! **************************************************************************************************
18164 SUBROUTINE mp_isend_dm3(msgin, dest, comm, request, tag)
18165 REAL(kind=real_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
18166 INTEGER, INTENT(IN) :: dest
18167 CLASS(mp_comm_type), INTENT(IN) :: comm
18168 TYPE(mp_request_type), INTENT(out) :: request
18169 INTEGER, INTENT(in), OPTIONAL :: tag
18170
18171 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm3'
18172
18173 INTEGER :: handle, ierr
18174#if defined(__parallel)
18175 INTEGER :: msglen, my_tag
18176 REAL(kind=real_8) :: foo(1)
18177#endif
18178
18179 CALL mp_timeset(routinen, handle)
18180
18181#if defined(__parallel)
18182#if !defined(__GNUC__) || __GNUC__ >= 9
18183 cpassert(is_contiguous(msgin))
18184#endif
18185
18186 my_tag = 0
18187 IF (PRESENT(tag)) my_tag = tag
18188
18189 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
18190 IF (msglen > 0) THEN
18191 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_double_precision, dest, my_tag, &
18192 comm%handle, request%handle, ierr)
18193 ELSE
18194 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18195 comm%handle, request%handle, ierr)
18196 END IF
18197 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18198
18199 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18200#else
18201 mark_used(msgin)
18202 mark_used(dest)
18203 mark_used(comm)
18204 mark_used(request)
18205 mark_used(tag)
18206 ierr = 1
18207 request = mp_request_null
18208 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18209#endif
18210 CALL mp_timestop(handle)
18211 END SUBROUTINE mp_isend_dm3
18212
18213! **************************************************************************************************
18214!> \brief Non-blocking send of rank-4 data
18215!> \param msgin the input message
18216!> \param dest the destination processor
18217!> \param comm the communicator object
18218!> \param request the communication request id
18219!> \param tag the message tag
18220!> \par History
18221!> 2.2016 added _dm4 subroutine [Nico Holmberg]
18222!> \author fawzi
18223!> \note see mp_isend_dv
18224!> \note
18225!> arrays can be pointers or assumed shape, but they must be contiguous!
18226! **************************************************************************************************
18227 SUBROUTINE mp_isend_dm4(msgin, dest, comm, request, tag)
18228 REAL(kind=real_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
18229 INTEGER, INTENT(IN) :: dest
18230 CLASS(mp_comm_type), INTENT(IN) :: comm
18231 TYPE(mp_request_type), INTENT(out) :: request
18232 INTEGER, INTENT(in), OPTIONAL :: tag
18233
18234 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm4'
18235
18236 INTEGER :: handle, ierr
18237#if defined(__parallel)
18238 INTEGER :: msglen, my_tag
18239 REAL(kind=real_8) :: foo(1)
18240#endif
18241
18242 CALL mp_timeset(routinen, handle)
18243
18244#if defined(__parallel)
18245#if !defined(__GNUC__) || __GNUC__ >= 9
18246 cpassert(is_contiguous(msgin))
18247#endif
18248
18249 my_tag = 0
18250 IF (PRESENT(tag)) my_tag = tag
18251
18252 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
18253 IF (msglen > 0) THEN
18254 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_double_precision, dest, my_tag, &
18255 comm%handle, request%handle, ierr)
18256 ELSE
18257 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18258 comm%handle, request%handle, ierr)
18259 END IF
18260 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18261
18262 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18263#else
18264 mark_used(msgin)
18265 mark_used(dest)
18266 mark_used(comm)
18267 mark_used(request)
18268 mark_used(tag)
18269 ierr = 1
18270 request = mp_request_null
18271 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18272#endif
18273 CALL mp_timestop(handle)
18274 END SUBROUTINE mp_isend_dm4
18275
18276! **************************************************************************************************
18277!> \brief Non-blocking receive of vector data
18278!> \param msgout ...
18279!> \param source ...
18280!> \param comm ...
18281!> \param request ...
18282!> \param tag ...
18283!> \par History
18284!> 08.2003 created [f&j]
18285!> 2009-11-25 [UB] Made type-generic for templates
18286!> \note see mp_isendrecv_dv
18287!> \note
18288!> arrays can be pointers or assumed shape, but they must be contiguous!
18289! **************************************************************************************************
18290 SUBROUTINE mp_irecv_dv(msgout, source, comm, request, tag)
18291 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
18292 INTEGER, INTENT(IN) :: source
18293 CLASS(mp_comm_type), INTENT(IN) :: comm
18294 TYPE(mp_request_type), INTENT(out) :: request
18295 INTEGER, INTENT(in), OPTIONAL :: tag
18296
18297 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dv'
18298
18299 INTEGER :: handle
18300#if defined(__parallel)
18301 INTEGER :: ierr, msglen, my_tag
18302 REAL(kind=real_8) :: foo(1)
18303#endif
18304
18305 CALL mp_timeset(routinen, handle)
18306
18307#if defined(__parallel)
18308#if !defined(__GNUC__) || __GNUC__ >= 9
18309 cpassert(is_contiguous(msgout))
18310#endif
18311
18312 my_tag = 0
18313 IF (PRESENT(tag)) my_tag = tag
18314
18315 msglen = SIZE(msgout)
18316 IF (msglen > 0) THEN
18317 CALL mpi_irecv(msgout(1), msglen, mpi_double_precision, source, my_tag, &
18318 comm%handle, request%handle, ierr)
18319 ELSE
18320 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18321 comm%handle, request%handle, ierr)
18322 END IF
18323 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18324
18325 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18326#else
18327 cpabort("mp_irecv called in non parallel case")
18328 mark_used(msgout)
18329 mark_used(source)
18330 mark_used(comm)
18331 mark_used(tag)
18332 request = mp_request_null
18333#endif
18334 CALL mp_timestop(handle)
18335 END SUBROUTINE mp_irecv_dv
18336
18337! **************************************************************************************************
18338!> \brief Non-blocking receive of matrix data
18339!> \param msgout ...
18340!> \param source ...
18341!> \param comm ...
18342!> \param request ...
18343!> \param tag ...
18344!> \par History
18345!> 2009-11-25 [UB] Made type-generic for templates
18346!> \author fawzi
18347!> \note see mp_isendrecv_dv
18348!> \note see mp_irecv_dv
18349!> \note
18350!> arrays can be pointers or assumed shape, but they must be contiguous!
18351! **************************************************************************************************
18352 SUBROUTINE mp_irecv_dm2(msgout, source, comm, request, tag)
18353 REAL(kind=real_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
18354 INTEGER, INTENT(IN) :: source
18355 CLASS(mp_comm_type), INTENT(IN) :: comm
18356 TYPE(mp_request_type), INTENT(out) :: request
18357 INTEGER, INTENT(in), OPTIONAL :: tag
18358
18359 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm2'
18360
18361 INTEGER :: handle
18362#if defined(__parallel)
18363 INTEGER :: ierr, msglen, my_tag
18364 REAL(kind=real_8) :: foo(1)
18365#endif
18366
18367 CALL mp_timeset(routinen, handle)
18368
18369#if defined(__parallel)
18370#if !defined(__GNUC__) || __GNUC__ >= 9
18371 cpassert(is_contiguous(msgout))
18372#endif
18373
18374 my_tag = 0
18375 IF (PRESENT(tag)) my_tag = tag
18376
18377 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
18378 IF (msglen > 0) THEN
18379 CALL mpi_irecv(msgout(1, 1), msglen, mpi_double_precision, source, my_tag, &
18380 comm%handle, request%handle, ierr)
18381 ELSE
18382 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18383 comm%handle, request%handle, ierr)
18384 END IF
18385 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18386
18387 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18388#else
18389 mark_used(msgout)
18390 mark_used(source)
18391 mark_used(comm)
18392 mark_used(tag)
18393 request = mp_request_null
18394 cpabort("mp_irecv called in non parallel case")
18395#endif
18396 CALL mp_timestop(handle)
18397 END SUBROUTINE mp_irecv_dm2
18398
18399! **************************************************************************************************
18400!> \brief Non-blocking send of rank-3 data
18401!> \param msgout ...
18402!> \param source ...
18403!> \param comm ...
18404!> \param request ...
18405!> \param tag ...
18406!> \par History
18407!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
18408!> 2009-11-25 [UB] Made type-generic for templates
18409!> \author fawzi
18410!> \note see mp_isendrecv_dv
18411!> \note see mp_irecv_dv
18412!> \note
18413!> arrays can be pointers or assumed shape, but they must be contiguous!
18414! **************************************************************************************************
18415 SUBROUTINE mp_irecv_dm3(msgout, source, comm, request, tag)
18416 REAL(kind=real_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
18417 INTEGER, INTENT(IN) :: source
18418 CLASS(mp_comm_type), INTENT(IN) :: comm
18419 TYPE(mp_request_type), INTENT(out) :: request
18420 INTEGER, INTENT(in), OPTIONAL :: tag
18421
18422 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm3'
18423
18424 INTEGER :: handle
18425#if defined(__parallel)
18426 INTEGER :: ierr, msglen, my_tag
18427 REAL(kind=real_8) :: foo(1)
18428#endif
18429
18430 CALL mp_timeset(routinen, handle)
18431
18432#if defined(__parallel)
18433#if !defined(__GNUC__) || __GNUC__ >= 9
18434 cpassert(is_contiguous(msgout))
18435#endif
18436
18437 my_tag = 0
18438 IF (PRESENT(tag)) my_tag = tag
18439
18440 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
18441 IF (msglen > 0) THEN
18442 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_double_precision, source, my_tag, &
18443 comm%handle, request%handle, ierr)
18444 ELSE
18445 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18446 comm%handle, request%handle, ierr)
18447 END IF
18448 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
18449
18450 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18451#else
18452 mark_used(msgout)
18453 mark_used(source)
18454 mark_used(comm)
18455 mark_used(tag)
18456 request = mp_request_null
18457 cpabort("mp_irecv called in non parallel case")
18458#endif
18459 CALL mp_timestop(handle)
18460 END SUBROUTINE mp_irecv_dm3
18461
18462! **************************************************************************************************
18463!> \brief Non-blocking receive of rank-4 data
18464!> \param msgout the output message
18465!> \param source the source processor
18466!> \param comm the communicator object
18467!> \param request the communication request id
18468!> \param tag the message tag
18469!> \par History
18470!> 2.2016 added _dm4 subroutine [Nico Holmberg]
18471!> \author fawzi
18472!> \note see mp_irecv_dv
18473!> \note
18474!> arrays can be pointers or assumed shape, but they must be contiguous!
18475! **************************************************************************************************
18476 SUBROUTINE mp_irecv_dm4(msgout, source, comm, request, tag)
18477 REAL(kind=real_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
18478 INTEGER, INTENT(IN) :: source
18479 CLASS(mp_comm_type), INTENT(IN) :: comm
18480 TYPE(mp_request_type), INTENT(out) :: request
18481 INTEGER, INTENT(in), OPTIONAL :: tag
18482
18483 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm4'
18484
18485 INTEGER :: handle
18486#if defined(__parallel)
18487 INTEGER :: ierr, msglen, my_tag
18488 REAL(kind=real_8) :: foo(1)
18489#endif
18490
18491 CALL mp_timeset(routinen, handle)
18492
18493#if defined(__parallel)
18494#if !defined(__GNUC__) || __GNUC__ >= 9
18495 cpassert(is_contiguous(msgout))
18496#endif
18497
18498 my_tag = 0
18499 IF (PRESENT(tag)) my_tag = tag
18500
18501 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
18502 IF (msglen > 0) THEN
18503 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_double_precision, source, my_tag, &
18504 comm%handle, request%handle, ierr)
18505 ELSE
18506 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18507 comm%handle, request%handle, ierr)
18508 END IF
18509 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
18510
18511 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18512#else
18513 mark_used(msgout)
18514 mark_used(source)
18515 mark_used(comm)
18516 mark_used(tag)
18517 request = mp_request_null
18518 cpabort("mp_irecv called in non parallel case")
18519#endif
18520 CALL mp_timestop(handle)
18521 END SUBROUTINE mp_irecv_dm4
18522
18523! **************************************************************************************************
18524!> \brief Window initialization function for vector data
18525!> \param base ...
18526!> \param comm ...
18527!> \param win ...
18528!> \par History
18529!> 02.2015 created [Alfio Lazzaro]
18530!> \note
18531!> arrays can be pointers or assumed shape, but they must be contiguous!
18532! **************************************************************************************************
18533 SUBROUTINE mp_win_create_dv(base, comm, win)
18534 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
18535 TYPE(mp_comm_type), INTENT(IN) :: comm
18536 CLASS(mp_win_type), INTENT(INOUT) :: win
18537
18538 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_dv'
18539
18540 INTEGER :: handle
18541#if defined(__parallel)
18542 INTEGER :: ierr
18543 INTEGER(kind=mpi_address_kind) :: len
18544 REAL(kind=real_8) :: foo(1)
18545#endif
18546
18547 CALL mp_timeset(routinen, handle)
18548
18549#if defined(__parallel)
18550
18551 len = SIZE(base)*real_8_size
18552 IF (len > 0) THEN
18553 CALL mpi_win_create(base(1), len, real_8_size, mpi_info_null, comm%handle, win%handle, ierr)
18554 ELSE
18555 CALL mpi_win_create(foo, len, real_8_size, mpi_info_null, comm%handle, win%handle, ierr)
18556 END IF
18557 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
18558
18559 CALL add_perf(perf_id=20, count=1)
18560#else
18561 mark_used(base)
18562 mark_used(comm)
18563 win%handle = mp_win_null_handle
18564#endif
18565 CALL mp_timestop(handle)
18566 END SUBROUTINE mp_win_create_dv
18567
18568! **************************************************************************************************
18569!> \brief Single-sided get function for vector data
18570!> \param base ...
18571!> \param comm ...
18572!> \param win ...
18573!> \par History
18574!> 02.2015 created [Alfio Lazzaro]
18575!> \note
18576!> arrays can be pointers or assumed shape, but they must be contiguous!
18577! **************************************************************************************************
18578 SUBROUTINE mp_rget_dv(base, source, win, win_data, myproc, disp, request, &
18579 origin_datatype, target_datatype)
18580 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
18581 INTEGER, INTENT(IN) :: source
18582 CLASS(mp_win_type), INTENT(IN) :: win
18583 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: win_data
18584 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
18585 TYPE(mp_request_type), INTENT(OUT) :: request
18586 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
18587
18588 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_dv'
18589
18590 INTEGER :: handle
18591#if defined(__parallel)
18592 INTEGER :: ierr, len, &
18593 origin_len, target_len
18594 LOGICAL :: do_local_copy
18595 INTEGER(kind=mpi_address_kind) :: disp_aint
18596 mpi_data_type :: handle_origin_datatype, handle_target_datatype
18597#endif
18598
18599 CALL mp_timeset(routinen, handle)
18600
18601#if defined(__parallel)
18602 len = SIZE(base)
18603 disp_aint = 0
18604 IF (PRESENT(disp)) THEN
18605 disp_aint = int(disp, kind=mpi_address_kind)
18606 END IF
18607 handle_origin_datatype = mpi_double_precision
18608 origin_len = len
18609 IF (PRESENT(origin_datatype)) THEN
18610 handle_origin_datatype = origin_datatype%type_handle
18611 origin_len = 1
18612 END IF
18613 handle_target_datatype = mpi_double_precision
18614 target_len = len
18615 IF (PRESENT(target_datatype)) THEN
18616 handle_target_datatype = target_datatype%type_handle
18617 target_len = 1
18618 END IF
18619 IF (len > 0) THEN
18620 do_local_copy = .false.
18621 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
18622 IF (myproc .EQ. source) do_local_copy = .true.
18623 END IF
18624 IF (do_local_copy) THEN
18625 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
18626 base(:) = win_data(disp_aint + 1:disp_aint + len)
18627 !$OMP END PARALLEL WORKSHARE
18628 request = mp_request_null
18629 ierr = 0
18630 ELSE
18631 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
18632 target_len, handle_target_datatype, win%handle, request%handle, ierr)
18633 END IF
18634 ELSE
18635 request = mp_request_null
18636 ierr = 0
18637 END IF
18638 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
18639
18640 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*real_8_size)
18641#else
18642 mark_used(source)
18643 mark_used(win)
18644 mark_used(myproc)
18645 mark_used(origin_datatype)
18646 mark_used(target_datatype)
18647
18648 request = mp_request_null
18649 !
18650 IF (PRESENT(disp)) THEN
18651 base(:) = win_data(disp + 1:disp + SIZE(base))
18652 ELSE
18653 base(:) = win_data(:SIZE(base))
18654 END IF
18655
18656#endif
18657 CALL mp_timestop(handle)
18658 END SUBROUTINE mp_rget_dv
18659
18660! **************************************************************************************************
18661!> \brief ...
18662!> \param count ...
18663!> \param lengths ...
18664!> \param displs ...
18665!> \return ...
18666! ***************************************************************************
18667 FUNCTION mp_type_indexed_make_d (count, lengths, displs) &
18668 result(type_descriptor)
18669 INTEGER, INTENT(IN) :: count
18670 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
18671 TYPE(mp_type_descriptor_type) :: type_descriptor
18672
18673 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_d'
18674
18675 INTEGER :: handle
18676#if defined(__parallel)
18677 INTEGER :: ierr
18678#endif
18679
18680 CALL mp_timeset(routinen, handle)
18681
18682#if defined(__parallel)
18683 CALL mpi_type_indexed(count, lengths, displs, mpi_double_precision, &
18684 type_descriptor%type_handle, ierr)
18685 IF (ierr /= 0) &
18686 cpabort("MPI_Type_Indexed @ "//routinen)
18687 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
18688 IF (ierr /= 0) &
18689 cpabort("MPI_Type_commit @ "//routinen)
18690#else
18691 type_descriptor%type_handle = 3
18692#endif
18693 type_descriptor%length = count
18694 NULLIFY (type_descriptor%subtype)
18695 type_descriptor%vector_descriptor(1:2) = 1
18696 type_descriptor%has_indexing = .true.
18697 type_descriptor%index_descriptor%index => lengths
18698 type_descriptor%index_descriptor%chunks => displs
18699
18700 CALL mp_timestop(handle)
18701
18702 END FUNCTION mp_type_indexed_make_d
18703
18704! **************************************************************************************************
18705!> \brief Allocates special parallel memory
18706!> \param[in] DATA pointer to integer array to allocate
18707!> \param[in] len number of integers to allocate
18708!> \param[out] stat (optional) allocation status result
18709!> \author UB
18710! **************************************************************************************************
18711 SUBROUTINE mp_allocate_d (DATA, len, stat)
18712 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
18713 INTEGER, INTENT(IN) :: len
18714 INTEGER, INTENT(OUT), OPTIONAL :: stat
18715
18716 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_d'
18717
18718 INTEGER :: handle, ierr
18719
18720 CALL mp_timeset(routinen, handle)
18721
18722#if defined(__parallel)
18723 NULLIFY (data)
18724 CALL mp_alloc_mem(DATA, len, stat=ierr)
18725 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
18726 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
18727 CALL add_perf(perf_id=15, count=1)
18728#else
18729 ALLOCATE (DATA(len), stat=ierr)
18730 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
18731 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
18732#endif
18733 IF (PRESENT(stat)) stat = ierr
18734 CALL mp_timestop(handle)
18735 END SUBROUTINE mp_allocate_d
18736
18737! **************************************************************************************************
18738!> \brief Deallocates special parallel memory
18739!> \param[in] DATA pointer to special memory to deallocate
18740!> \param stat ...
18741!> \author UB
18742! **************************************************************************************************
18743 SUBROUTINE mp_deallocate_d (DATA, stat)
18744 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
18745 INTEGER, INTENT(OUT), OPTIONAL :: stat
18746
18747 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_d'
18748
18749 INTEGER :: handle
18750#if defined(__parallel)
18751 INTEGER :: ierr
18752#endif
18753
18754 CALL mp_timeset(routinen, handle)
18755
18756#if defined(__parallel)
18757 CALL mp_free_mem(DATA, ierr)
18758 IF (PRESENT(stat)) THEN
18759 stat = ierr
18760 ELSE
18761 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
18762 END IF
18763 NULLIFY (data)
18764 CALL add_perf(perf_id=15, count=1)
18765#else
18766 DEALLOCATE (data)
18767 IF (PRESENT(stat)) stat = 0
18768#endif
18769 CALL mp_timestop(handle)
18770 END SUBROUTINE mp_deallocate_d
18771
18772! **************************************************************************************************
18773!> \brief (parallel) Blocking individual file write using explicit offsets
18774!> (serial) Unformatted stream write
18775!> \param[in] fh file handle (file storage unit)
18776!> \param[in] offset file offset (position)
18777!> \param[in] msg data to be written to the file
18778!> \param msglen ...
18779!> \par MPI-I/O mapping mpi_file_write_at
18780!> \par STREAM-I/O mapping WRITE
18781!> \param[in](optional) msglen number of the elements of data
18782! **************************************************************************************************
18783 SUBROUTINE mp_file_write_at_dv(fh, offset, msg, msglen)
18784 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
18785 CLASS(mp_file_type), INTENT(IN) :: fh
18786 INTEGER, INTENT(IN), OPTIONAL :: msglen
18787 INTEGER(kind=file_offset), INTENT(IN) :: offset
18788
18789 INTEGER :: msg_len
18790#if defined(__parallel)
18791 INTEGER :: ierr
18792#endif
18793
18794 msg_len = SIZE(msg)
18795 IF (PRESENT(msglen)) msg_len = msglen
18796#if defined(__parallel)
18797 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18798 IF (ierr .NE. 0) &
18799 cpabort("mpi_file_write_at_dv @ mp_file_write_at_dv")
18800#else
18801 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18802#endif
18803 END SUBROUTINE mp_file_write_at_dv
18804
18805! **************************************************************************************************
18806!> \brief ...
18807!> \param fh ...
18808!> \param offset ...
18809!> \param msg ...
18810! **************************************************************************************************
18811 SUBROUTINE mp_file_write_at_d (fh, offset, msg)
18812 REAL(kind=real_8), INTENT(IN) :: msg
18813 CLASS(mp_file_type), INTENT(IN) :: fh
18814 INTEGER(kind=file_offset), INTENT(IN) :: offset
18815
18816#if defined(__parallel)
18817 INTEGER :: ierr
18818
18819 ierr = 0
18820 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18821 IF (ierr .NE. 0) &
18822 cpabort("mpi_file_write_at_d @ mp_file_write_at_d")
18823#else
18824 WRITE (unit=fh%handle, pos=offset + 1) msg
18825#endif
18826 END SUBROUTINE mp_file_write_at_d
18827
18828! **************************************************************************************************
18829!> \brief (parallel) Blocking collective file write using explicit offsets
18830!> (serial) Unformatted stream write
18831!> \param fh ...
18832!> \param offset ...
18833!> \param msg ...
18834!> \param msglen ...
18835!> \par MPI-I/O mapping mpi_file_write_at_all
18836!> \par STREAM-I/O mapping WRITE
18837! **************************************************************************************************
18838 SUBROUTINE mp_file_write_at_all_dv(fh, offset, msg, msglen)
18839 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
18840 CLASS(mp_file_type), INTENT(IN) :: fh
18841 INTEGER, INTENT(IN), OPTIONAL :: msglen
18842 INTEGER(kind=file_offset), INTENT(IN) :: offset
18843
18844 INTEGER :: msg_len
18845#if defined(__parallel)
18846 INTEGER :: ierr
18847#endif
18848
18849 msg_len = SIZE(msg)
18850 IF (PRESENT(msglen)) msg_len = msglen
18851#if defined(__parallel)
18852 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18853 IF (ierr .NE. 0) &
18854 cpabort("mpi_file_write_at_all_dv @ mp_file_write_at_all_dv")
18855#else
18856 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18857#endif
18858 END SUBROUTINE mp_file_write_at_all_dv
18859
18860! **************************************************************************************************
18861!> \brief ...
18862!> \param fh ...
18863!> \param offset ...
18864!> \param msg ...
18865! **************************************************************************************************
18866 SUBROUTINE mp_file_write_at_all_d (fh, offset, msg)
18867 REAL(kind=real_8), INTENT(IN) :: msg
18868 CLASS(mp_file_type), INTENT(IN) :: fh
18869 INTEGER(kind=file_offset), INTENT(IN) :: offset
18870
18871#if defined(__parallel)
18872 INTEGER :: ierr
18873
18874 ierr = 0
18875 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18876 IF (ierr .NE. 0) &
18877 cpabort("mpi_file_write_at_all_d @ mp_file_write_at_all_d")
18878#else
18879 WRITE (unit=fh%handle, pos=offset + 1) msg
18880#endif
18881 END SUBROUTINE mp_file_write_at_all_d
18882
18883! **************************************************************************************************
18884!> \brief (parallel) Blocking individual file read using explicit offsets
18885!> (serial) Unformatted stream read
18886!> \param[in] fh file handle (file storage unit)
18887!> \param[in] offset file offset (position)
18888!> \param[out] msg data to be read from the file
18889!> \param msglen ...
18890!> \par MPI-I/O mapping mpi_file_read_at
18891!> \par STREAM-I/O mapping READ
18892!> \param[in](optional) msglen number of elements of data
18893! **************************************************************************************************
18894 SUBROUTINE mp_file_read_at_dv(fh, offset, msg, msglen)
18895 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
18896 CLASS(mp_file_type), INTENT(IN) :: fh
18897 INTEGER, INTENT(IN), OPTIONAL :: msglen
18898 INTEGER(kind=file_offset), INTENT(IN) :: offset
18899
18900 INTEGER :: msg_len
18901#if defined(__parallel)
18902 INTEGER :: ierr
18903#endif
18904
18905 msg_len = SIZE(msg)
18906 IF (PRESENT(msglen)) msg_len = msglen
18907#if defined(__parallel)
18908 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18909 IF (ierr .NE. 0) &
18910 cpabort("mpi_file_read_at_dv @ mp_file_read_at_dv")
18911#else
18912 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18913#endif
18914 END SUBROUTINE mp_file_read_at_dv
18915
18916! **************************************************************************************************
18917!> \brief ...
18918!> \param fh ...
18919!> \param offset ...
18920!> \param msg ...
18921! **************************************************************************************************
18922 SUBROUTINE mp_file_read_at_d (fh, offset, msg)
18923 REAL(kind=real_8), INTENT(OUT) :: msg
18924 CLASS(mp_file_type), INTENT(IN) :: fh
18925 INTEGER(kind=file_offset), INTENT(IN) :: offset
18926
18927#if defined(__parallel)
18928 INTEGER :: ierr
18929
18930 ierr = 0
18931 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18932 IF (ierr .NE. 0) &
18933 cpabort("mpi_file_read_at_d @ mp_file_read_at_d")
18934#else
18935 READ (unit=fh%handle, pos=offset + 1) msg
18936#endif
18937 END SUBROUTINE mp_file_read_at_d
18938
18939! **************************************************************************************************
18940!> \brief (parallel) Blocking collective file read using explicit offsets
18941!> (serial) Unformatted stream read
18942!> \param fh ...
18943!> \param offset ...
18944!> \param msg ...
18945!> \param msglen ...
18946!> \par MPI-I/O mapping mpi_file_read_at_all
18947!> \par STREAM-I/O mapping READ
18948! **************************************************************************************************
18949 SUBROUTINE mp_file_read_at_all_dv(fh, offset, msg, msglen)
18950 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
18951 CLASS(mp_file_type), INTENT(IN) :: fh
18952 INTEGER, INTENT(IN), OPTIONAL :: msglen
18953 INTEGER(kind=file_offset), INTENT(IN) :: offset
18954
18955 INTEGER :: msg_len
18956#if defined(__parallel)
18957 INTEGER :: ierr
18958#endif
18959
18960 msg_len = SIZE(msg)
18961 IF (PRESENT(msglen)) msg_len = msglen
18962#if defined(__parallel)
18963 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18964 IF (ierr .NE. 0) &
18965 cpabort("mpi_file_read_at_all_dv @ mp_file_read_at_all_dv")
18966#else
18967 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18968#endif
18969 END SUBROUTINE mp_file_read_at_all_dv
18970
18971! **************************************************************************************************
18972!> \brief ...
18973!> \param fh ...
18974!> \param offset ...
18975!> \param msg ...
18976! **************************************************************************************************
18977 SUBROUTINE mp_file_read_at_all_d (fh, offset, msg)
18978 REAL(kind=real_8), INTENT(OUT) :: msg
18979 CLASS(mp_file_type), INTENT(IN) :: fh
18980 INTEGER(kind=file_offset), INTENT(IN) :: offset
18981
18982#if defined(__parallel)
18983 INTEGER :: ierr
18984
18985 ierr = 0
18986 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18987 IF (ierr .NE. 0) &
18988 cpabort("mpi_file_read_at_all_d @ mp_file_read_at_all_d")
18989#else
18990 READ (unit=fh%handle, pos=offset + 1) msg
18991#endif
18992 END SUBROUTINE mp_file_read_at_all_d
18993
18994! **************************************************************************************************
18995!> \brief ...
18996!> \param ptr ...
18997!> \param vector_descriptor ...
18998!> \param index_descriptor ...
18999!> \return ...
19000! **************************************************************************************************
19001 FUNCTION mp_type_make_d (ptr, &
19002 vector_descriptor, index_descriptor) &
19003 result(type_descriptor)
19004 REAL(kind=real_8), DIMENSION(:), TARGET, asynchronous :: ptr
19005 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
19006 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
19007 TYPE(mp_type_descriptor_type) :: type_descriptor
19008
19009 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_d'
19010
19011#if defined(__parallel)
19012 INTEGER :: ierr
19013#endif
19014
19015 NULLIFY (type_descriptor%subtype)
19016 type_descriptor%length = SIZE(ptr)
19017#if defined(__parallel)
19018 type_descriptor%type_handle = mpi_double_precision
19019 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
19020 IF (ierr /= 0) &
19021 cpabort("MPI_Get_address @ "//routinen)
19022#else
19023 type_descriptor%type_handle = 3
19024#endif
19025 type_descriptor%vector_descriptor(1:2) = 1
19026 type_descriptor%has_indexing = .false.
19027 type_descriptor%data_d => ptr
19028 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
19029 cpabort(routinen//": Vectors and indices NYI")
19030 END IF
19031 END FUNCTION mp_type_make_d
19032
19033! **************************************************************************************************
19034!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
19035!> as the Fortran version returns an integer, which we take to be a C_PTR
19036!> \param DATA data array to allocate
19037!> \param[in] len length (in data elements) of data array allocation
19038!> \param[out] stat (optional) allocation status result
19039! **************************************************************************************************
19040 SUBROUTINE mp_alloc_mem_d (DATA, len, stat)
19041 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
19042 INTEGER, INTENT(IN) :: len
19043 INTEGER, INTENT(OUT), OPTIONAL :: stat
19044
19045#if defined(__parallel)
19046 INTEGER :: size, ierr, length, &
19047 mp_res
19048 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
19049 TYPE(c_ptr) :: mp_baseptr
19050 mpi_info_type :: mp_info
19051
19052 length = max(len, 1)
19053 CALL mpi_type_size(mpi_double_precision, size, ierr)
19054 mp_size = int(length, kind=mpi_address_kind)*size
19055 IF (mp_size .GT. mp_max_memory_size) THEN
19056 cpabort("MPI cannot allocate more than 2 GiByte")
19057 END IF
19058 mp_info = mpi_info_null
19059 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
19060 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
19061 IF (PRESENT(stat)) stat = mp_res
19062#else
19063 INTEGER :: length, mystat
19064 length = max(len, 1)
19065 IF (PRESENT(stat)) THEN
19066 ALLOCATE (DATA(length), stat=mystat)
19067 stat = mystat ! show to convention checker that stat is used
19068 ELSE
19069 ALLOCATE (DATA(length))
19070 END IF
19071#endif
19072 END SUBROUTINE mp_alloc_mem_d
19073
19074! **************************************************************************************************
19075!> \brief Deallocates am array, ... this is hackish
19076!> as the Fortran version takes an integer, which we hope to get by reference
19077!> \param DATA data array to allocate
19078!> \param[out] stat (optional) allocation status result
19079! **************************************************************************************************
19080 SUBROUTINE mp_free_mem_d (DATA, stat)
19081 REAL(kind=real_8), DIMENSION(:), &
19082 POINTER, asynchronous :: DATA
19083 INTEGER, INTENT(OUT), OPTIONAL :: stat
19084
19085#if defined(__parallel)
19086 INTEGER :: mp_res
19087 CALL mpi_free_mem(DATA, mp_res)
19088 IF (PRESENT(stat)) stat = mp_res
19089#else
19090 DEALLOCATE (data)
19091 IF (PRESENT(stat)) stat = 0
19092#endif
19093 END SUBROUTINE mp_free_mem_d
19094! **************************************************************************************************
19095!> \brief Shift around the data in msg
19096!> \param[in,out] msg Rank-2 data to shift
19097!> \param[in] comm message passing environment identifier
19098!> \param[in] displ_in displacements (?)
19099!> \par Example
19100!> msg will be moved from rank to rank+displ_in (in a circular way)
19101!> \par Limitations
19102!> * displ_in will be 1 by default (others not tested)
19103!> * the message array needs to be the same size on all processes
19104! **************************************************************************************************
19105 SUBROUTINE mp_shift_rm(msg, comm, displ_in)
19106
19107 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
19108 CLASS(mp_comm_type), INTENT(IN) :: comm
19109 INTEGER, INTENT(IN), OPTIONAL :: displ_in
19110
19111 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_rm'
19112
19113 INTEGER :: handle, ierror
19114#if defined(__parallel)
19115 INTEGER :: displ, left, &
19116 msglen, myrank, nprocs, &
19117 right, tag
19118#endif
19119
19120 ierror = 0
19121 CALL mp_timeset(routinen, handle)
19122
19123#if defined(__parallel)
19124 CALL mpi_comm_rank(comm%handle, myrank, ierror)
19125 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
19126 CALL mpi_comm_size(comm%handle, nprocs, ierror)
19127 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
19128 IF (PRESENT(displ_in)) THEN
19129 displ = displ_in
19130 ELSE
19131 displ = 1
19132 END IF
19133 right = modulo(myrank + displ, nprocs)
19134 left = modulo(myrank - displ, nprocs)
19135 tag = 17
19136 msglen = SIZE(msg)
19137 CALL mpi_sendrecv_replace(msg, msglen, mpi_real, right, tag, left, tag, &
19138 comm%handle, mpi_status_ignore, ierror)
19139 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
19140 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_4_size)
19141#else
19142 mark_used(msg)
19143 mark_used(comm)
19144 mark_used(displ_in)
19145#endif
19146 CALL mp_timestop(handle)
19147
19148 END SUBROUTINE mp_shift_rm
19149
19150! **************************************************************************************************
19151!> \brief Shift around the data in msg
19152!> \param[in,out] msg Data to shift
19153!> \param[in] comm message passing environment identifier
19154!> \param[in] displ_in displacements (?)
19155!> \par Example
19156!> msg will be moved from rank to rank+displ_in (in a circular way)
19157!> \par Limitations
19158!> * displ_in will be 1 by default (others not tested)
19159!> * the message array needs to be the same size on all processes
19160! **************************************************************************************************
19161 SUBROUTINE mp_shift_r (msg, comm, displ_in)
19162
19163 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19164 CLASS(mp_comm_type), INTENT(IN) :: comm
19165 INTEGER, INTENT(IN), OPTIONAL :: displ_in
19166
19167 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_r'
19168
19169 INTEGER :: handle, ierror
19170#if defined(__parallel)
19171 INTEGER :: displ, left, &
19172 msglen, myrank, nprocs, &
19173 right, tag
19174#endif
19175
19176 ierror = 0
19177 CALL mp_timeset(routinen, handle)
19178
19179#if defined(__parallel)
19180 CALL mpi_comm_rank(comm%handle, myrank, ierror)
19181 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
19182 CALL mpi_comm_size(comm%handle, nprocs, ierror)
19183 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
19184 IF (PRESENT(displ_in)) THEN
19185 displ = displ_in
19186 ELSE
19187 displ = 1
19188 END IF
19189 right = modulo(myrank + displ, nprocs)
19190 left = modulo(myrank - displ, nprocs)
19191 tag = 19
19192 msglen = SIZE(msg)
19193 CALL mpi_sendrecv_replace(msg, msglen, mpi_real, right, tag, left, &
19194 tag, comm%handle, mpi_status_ignore, ierror)
19195 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
19196 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_4_size)
19197#else
19198 mark_used(msg)
19199 mark_used(comm)
19200 mark_used(displ_in)
19201#endif
19202 CALL mp_timestop(handle)
19203
19204 END SUBROUTINE mp_shift_r
19205
19206! **************************************************************************************************
19207!> \brief All-to-all data exchange, rank-1 data of different sizes
19208!> \param[in] sb Data to send
19209!> \param[in] scount Data counts for data sent to other processes
19210!> \param[in] sdispl Respective data offsets for data sent to process
19211!> \param[in,out] rb Buffer into which to receive data
19212!> \param[in] rcount Data counts for data received from other
19213!> processes
19214!> \param[in] rdispl Respective data offsets for data received from
19215!> other processes
19216!> \param[in] comm Message passing environment identifier
19217!> \par MPI mapping
19218!> mpi_alltoallv
19219!> \par Array sizes
19220!> The scount, rcount, and the sdispl and rdispl arrays have a
19221!> size equal to the number of processes.
19222!> \par Offsets
19223!> Values in sdispl and rdispl start with 0.
19224! **************************************************************************************************
19225 SUBROUTINE mp_alltoall_r11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
19226
19227 REAL(kind=real_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
19228 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
19229 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
19230 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
19231 CLASS(mp_comm_type), INTENT(IN) :: comm
19232
19233 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r11v'
19234
19235 INTEGER :: handle
19236#if defined(__parallel)
19237 INTEGER :: ierr, msglen
19238#else
19239 INTEGER :: i
19240#endif
19241
19242 CALL mp_timeset(routinen, handle)
19243
19244#if defined(__parallel)
19245 CALL mpi_alltoallv(sb, scount, sdispl, mpi_real, &
19246 rb, rcount, rdispl, mpi_real, comm%handle, ierr)
19247 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
19248 msglen = sum(scount) + sum(rcount)
19249 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19250#else
19251 mark_used(comm)
19252 mark_used(scount)
19253 mark_used(sdispl)
19254 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
19255 DO i = 1, rcount(1)
19256 rb(rdispl(1) + i) = sb(sdispl(1) + i)
19257 END DO
19258#endif
19259 CALL mp_timestop(handle)
19260
19261 END SUBROUTINE mp_alltoall_r11v
19262
19263! **************************************************************************************************
19264!> \brief All-to-all data exchange, rank-2 data of different sizes
19265!> \param sb ...
19266!> \param scount ...
19267!> \param sdispl ...
19268!> \param rb ...
19269!> \param rcount ...
19270!> \param rdispl ...
19271!> \param comm ...
19272!> \par MPI mapping
19273!> mpi_alltoallv
19274!> \note see mp_alltoall_r11v
19275! **************************************************************************************************
19276 SUBROUTINE mp_alltoall_r22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
19277
19278 REAL(kind=real_4), DIMENSION(:, :), &
19279 INTENT(IN), CONTIGUOUS :: sb
19280 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
19281 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, &
19282 INTENT(INOUT) :: rb
19283 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
19284 CLASS(mp_comm_type), INTENT(IN) :: comm
19285
19286 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r22v'
19287
19288 INTEGER :: handle
19289#if defined(__parallel)
19290 INTEGER :: ierr, msglen
19291#endif
19292
19293 CALL mp_timeset(routinen, handle)
19294
19295#if defined(__parallel)
19296 CALL mpi_alltoallv(sb, scount, sdispl, mpi_real, &
19297 rb, rcount, rdispl, mpi_real, comm%handle, ierr)
19298 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
19299 msglen = sum(scount) + sum(rcount)
19300 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*real_4_size)
19301#else
19302 mark_used(comm)
19303 mark_used(scount)
19304 mark_used(sdispl)
19305 mark_used(rcount)
19306 mark_used(rdispl)
19307 rb = sb
19308#endif
19309 CALL mp_timestop(handle)
19310
19311 END SUBROUTINE mp_alltoall_r22v
19312
19313! **************************************************************************************************
19314!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
19315!> \param[in] sb array with data to send
19316!> \param[out] rb array into which data is received
19317!> \param[in] count number of elements to send/receive (product of the
19318!> extents of the first two dimensions)
19319!> \param[in] comm Message passing environment identifier
19320!> \par Index meaning
19321!> \par The first two indices specify the data while the last index counts
19322!> the processes
19323!> \par Sizes of ranks
19324!> All processes have the same data size.
19325!> \par MPI mapping
19326!> mpi_alltoall
19327! **************************************************************************************************
19328 SUBROUTINE mp_alltoall_r (sb, rb, count, comm)
19329
19330 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
19331 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
19332 INTEGER, INTENT(IN) :: count
19333 CLASS(mp_comm_type), INTENT(IN) :: comm
19334
19335 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r'
19336
19337 INTEGER :: handle
19338#if defined(__parallel)
19339 INTEGER :: ierr, msglen, np
19340#endif
19341
19342 CALL mp_timeset(routinen, handle)
19343
19344#if defined(__parallel)
19345 CALL mpi_alltoall(sb, count, mpi_real, &
19346 rb, count, mpi_real, comm%handle, ierr)
19347 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19348 CALL mpi_comm_size(comm%handle, np, ierr)
19349 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19350 msglen = 2*count*np
19351 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19352#else
19353 mark_used(count)
19354 mark_used(comm)
19355 rb = sb
19356#endif
19357 CALL mp_timestop(handle)
19358
19359 END SUBROUTINE mp_alltoall_r
19360
19361! **************************************************************************************************
19362!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
19363!> \param sb ...
19364!> \param rb ...
19365!> \param count ...
19366!> \param commp ...
19367!> \note see mp_alltoall_r
19368! **************************************************************************************************
19369 SUBROUTINE mp_alltoall_r22(sb, rb, count, comm)
19370
19371 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
19372 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
19373 INTEGER, INTENT(IN) :: count
19374 CLASS(mp_comm_type), INTENT(IN) :: comm
19375
19376 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r22'
19377
19378 INTEGER :: handle
19379#if defined(__parallel)
19380 INTEGER :: ierr, msglen, np
19381#endif
19382
19383 CALL mp_timeset(routinen, handle)
19384
19385#if defined(__parallel)
19386 CALL mpi_alltoall(sb, count, mpi_real, &
19387 rb, count, mpi_real, comm%handle, ierr)
19388 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19389 CALL mpi_comm_size(comm%handle, np, ierr)
19390 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19391 msglen = 2*SIZE(sb)*np
19392 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19393#else
19394 mark_used(count)
19395 mark_used(comm)
19396 rb = sb
19397#endif
19398 CALL mp_timestop(handle)
19399
19400 END SUBROUTINE mp_alltoall_r22
19401
19402! **************************************************************************************************
19403!> \brief All-to-all data exchange, rank-3 data with equal sizes
19404!> \param sb ...
19405!> \param rb ...
19406!> \param count ...
19407!> \param comm ...
19408!> \note see mp_alltoall_r
19409! **************************************************************************************************
19410 SUBROUTINE mp_alltoall_r33(sb, rb, count, comm)
19411
19412 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
19413 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
19414 INTEGER, INTENT(IN) :: count
19415 CLASS(mp_comm_type), INTENT(IN) :: comm
19416
19417 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r33'
19418
19419 INTEGER :: handle
19420#if defined(__parallel)
19421 INTEGER :: ierr, msglen, np
19422#endif
19423
19424 CALL mp_timeset(routinen, handle)
19425
19426#if defined(__parallel)
19427 CALL mpi_alltoall(sb, count, mpi_real, &
19428 rb, count, mpi_real, comm%handle, ierr)
19429 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19430 CALL mpi_comm_size(comm%handle, np, ierr)
19431 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19432 msglen = 2*count*np
19433 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19434#else
19435 mark_used(count)
19436 mark_used(comm)
19437 rb = sb
19438#endif
19439 CALL mp_timestop(handle)
19440
19441 END SUBROUTINE mp_alltoall_r33
19442
19443! **************************************************************************************************
19444!> \brief All-to-all data exchange, rank 4 data, equal sizes
19445!> \param sb ...
19446!> \param rb ...
19447!> \param count ...
19448!> \param comm ...
19449!> \note see mp_alltoall_r
19450! **************************************************************************************************
19451 SUBROUTINE mp_alltoall_r44(sb, rb, count, comm)
19452
19453 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19454 INTENT(IN) :: sb
19455 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19456 INTENT(OUT) :: rb
19457 INTEGER, INTENT(IN) :: count
19458 CLASS(mp_comm_type), INTENT(IN) :: comm
19459
19460 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r44'
19461
19462 INTEGER :: handle
19463#if defined(__parallel)
19464 INTEGER :: ierr, msglen, np
19465#endif
19466
19467 CALL mp_timeset(routinen, handle)
19468
19469#if defined(__parallel)
19470 CALL mpi_alltoall(sb, count, mpi_real, &
19471 rb, count, mpi_real, comm%handle, ierr)
19472 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19473 CALL mpi_comm_size(comm%handle, np, ierr)
19474 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19475 msglen = 2*count*np
19476 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19477#else
19478 mark_used(count)
19479 mark_used(comm)
19480 rb = sb
19481#endif
19482 CALL mp_timestop(handle)
19483
19484 END SUBROUTINE mp_alltoall_r44
19485
19486! **************************************************************************************************
19487!> \brief All-to-all data exchange, rank 5 data, equal sizes
19488!> \param sb ...
19489!> \param rb ...
19490!> \param count ...
19491!> \param comm ...
19492!> \note see mp_alltoall_r
19493! **************************************************************************************************
19494 SUBROUTINE mp_alltoall_r55(sb, rb, count, comm)
19495
19496 REAL(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
19497 INTENT(IN) :: sb
19498 REAL(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
19499 INTENT(OUT) :: rb
19500 INTEGER, INTENT(IN) :: count
19501 CLASS(mp_comm_type), INTENT(IN) :: comm
19502
19503 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r55'
19504
19505 INTEGER :: handle
19506#if defined(__parallel)
19507 INTEGER :: ierr, msglen, np
19508#endif
19509
19510 CALL mp_timeset(routinen, handle)
19511
19512#if defined(__parallel)
19513 CALL mpi_alltoall(sb, count, mpi_real, &
19514 rb, count, mpi_real, comm%handle, ierr)
19515 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19516 CALL mpi_comm_size(comm%handle, np, ierr)
19517 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19518 msglen = 2*count*np
19519 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19520#else
19521 mark_used(count)
19522 mark_used(comm)
19523 rb = sb
19524#endif
19525 CALL mp_timestop(handle)
19526
19527 END SUBROUTINE mp_alltoall_r55
19528
19529! **************************************************************************************************
19530!> \brief All-to-all data exchange, rank-4 data to rank-5 data
19531!> \param sb ...
19532!> \param rb ...
19533!> \param count ...
19534!> \param comm ...
19535!> \note see mp_alltoall_r
19536!> \note User must ensure size consistency.
19537! **************************************************************************************************
19538 SUBROUTINE mp_alltoall_r45(sb, rb, count, comm)
19539
19540 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19541 INTENT(IN) :: sb
19542 REAL(kind=real_4), &
19543 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
19544 INTEGER, INTENT(IN) :: count
19545 CLASS(mp_comm_type), INTENT(IN) :: comm
19546
19547 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r45'
19548
19549 INTEGER :: handle
19550#if defined(__parallel)
19551 INTEGER :: ierr, msglen, np
19552#endif
19553
19554 CALL mp_timeset(routinen, handle)
19555
19556#if defined(__parallel)
19557 CALL mpi_alltoall(sb, count, mpi_real, &
19558 rb, count, mpi_real, comm%handle, ierr)
19559 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19560 CALL mpi_comm_size(comm%handle, np, ierr)
19561 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19562 msglen = 2*count*np
19563 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19564#else
19565 mark_used(count)
19566 mark_used(comm)
19567 rb = reshape(sb, shape(rb))
19568#endif
19569 CALL mp_timestop(handle)
19570
19571 END SUBROUTINE mp_alltoall_r45
19572
19573! **************************************************************************************************
19574!> \brief All-to-all data exchange, rank-3 data to rank-4 data
19575!> \param sb ...
19576!> \param rb ...
19577!> \param count ...
19578!> \param comm ...
19579!> \note see mp_alltoall_r
19580!> \note User must ensure size consistency.
19581! **************************************************************************************************
19582 SUBROUTINE mp_alltoall_r34(sb, rb, count, comm)
19583
19584 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, &
19585 INTENT(IN) :: sb
19586 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19587 INTENT(OUT) :: rb
19588 INTEGER, INTENT(IN) :: count
19589 CLASS(mp_comm_type), INTENT(IN) :: comm
19590
19591 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r34'
19592
19593 INTEGER :: handle
19594#if defined(__parallel)
19595 INTEGER :: ierr, msglen, np
19596#endif
19597
19598 CALL mp_timeset(routinen, handle)
19599
19600#if defined(__parallel)
19601 CALL mpi_alltoall(sb, count, mpi_real, &
19602 rb, count, mpi_real, comm%handle, ierr)
19603 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19604 CALL mpi_comm_size(comm%handle, np, ierr)
19605 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19606 msglen = 2*count*np
19607 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19608#else
19609 mark_used(count)
19610 mark_used(comm)
19611 rb = reshape(sb, shape(rb))
19612#endif
19613 CALL mp_timestop(handle)
19614
19615 END SUBROUTINE mp_alltoall_r34
19616
19617! **************************************************************************************************
19618!> \brief All-to-all data exchange, rank-5 data to rank-4 data
19619!> \param sb ...
19620!> \param rb ...
19621!> \param count ...
19622!> \param comm ...
19623!> \note see mp_alltoall_r
19624!> \note User must ensure size consistency.
19625! **************************************************************************************************
19626 SUBROUTINE mp_alltoall_r54(sb, rb, count, comm)
19627
19628 REAL(kind=real_4), &
19629 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
19630 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19631 INTENT(OUT) :: rb
19632 INTEGER, INTENT(IN) :: count
19633 CLASS(mp_comm_type), INTENT(IN) :: comm
19634
19635 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r54'
19636
19637 INTEGER :: handle
19638#if defined(__parallel)
19639 INTEGER :: ierr, msglen, np
19640#endif
19641
19642 CALL mp_timeset(routinen, handle)
19643
19644#if defined(__parallel)
19645 CALL mpi_alltoall(sb, count, mpi_real, &
19646 rb, count, mpi_real, comm%handle, ierr)
19647 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19648 CALL mpi_comm_size(comm%handle, np, ierr)
19649 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19650 msglen = 2*count*np
19651 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19652#else
19653 mark_used(count)
19654 mark_used(comm)
19655 rb = reshape(sb, shape(rb))
19656#endif
19657 CALL mp_timestop(handle)
19658
19659 END SUBROUTINE mp_alltoall_r54
19660
19661! **************************************************************************************************
19662!> \brief Send one datum to another process
19663!> \param[in] msg Scalar to send
19664!> \param[in] dest Destination process
19665!> \param[in] tag Transfer identifier
19666!> \param[in] comm Message passing environment identifier
19667!> \par MPI mapping
19668!> mpi_send
19669! **************************************************************************************************
19670 SUBROUTINE mp_send_r (msg, dest, tag, comm)
19671 REAL(kind=real_4), INTENT(IN) :: msg
19672 INTEGER, INTENT(IN) :: dest, tag
19673 CLASS(mp_comm_type), INTENT(IN) :: comm
19674
19675 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_r'
19676
19677 INTEGER :: handle
19678#if defined(__parallel)
19679 INTEGER :: ierr, msglen
19680#endif
19681
19682 CALL mp_timeset(routinen, handle)
19683
19684#if defined(__parallel)
19685 msglen = 1
19686 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19687 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19688 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19689#else
19690 mark_used(msg)
19691 mark_used(dest)
19692 mark_used(tag)
19693 mark_used(comm)
19694 ! only defined in parallel
19695 cpabort("not in parallel mode")
19696#endif
19697 CALL mp_timestop(handle)
19698 END SUBROUTINE mp_send_r
19699
19700! **************************************************************************************************
19701!> \brief Send rank-1 data to another process
19702!> \param[in] msg Rank-1 data to send
19703!> \param dest ...
19704!> \param tag ...
19705!> \param comm ...
19706!> \note see mp_send_r
19707! **************************************************************************************************
19708 SUBROUTINE mp_send_rv(msg, dest, tag, comm)
19709 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
19710 INTEGER, INTENT(IN) :: dest, tag
19711 CLASS(mp_comm_type), INTENT(IN) :: comm
19712
19713 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_rv'
19714
19715 INTEGER :: handle
19716#if defined(__parallel)
19717 INTEGER :: ierr, msglen
19718#endif
19719
19720 CALL mp_timeset(routinen, handle)
19721
19722#if defined(__parallel)
19723 msglen = SIZE(msg)
19724 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19725 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19726 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19727#else
19728 mark_used(msg)
19729 mark_used(dest)
19730 mark_used(tag)
19731 mark_used(comm)
19732 ! only defined in parallel
19733 cpabort("not in parallel mode")
19734#endif
19735 CALL mp_timestop(handle)
19736 END SUBROUTINE mp_send_rv
19737
19738! **************************************************************************************************
19739!> \brief Send rank-2 data to another process
19740!> \param[in] msg Rank-2 data to send
19741!> \param dest ...
19742!> \param tag ...
19743!> \param comm ...
19744!> \note see mp_send_r
19745! **************************************************************************************************
19746 SUBROUTINE mp_send_rm2(msg, dest, tag, comm)
19747 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
19748 INTEGER, INTENT(IN) :: dest, tag
19749 CLASS(mp_comm_type), INTENT(IN) :: comm
19750
19751 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_rm2'
19752
19753 INTEGER :: handle
19754#if defined(__parallel)
19755 INTEGER :: ierr, msglen
19756#endif
19757
19758 CALL mp_timeset(routinen, handle)
19759
19760#if defined(__parallel)
19761 msglen = SIZE(msg)
19762 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19763 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19764 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19765#else
19766 mark_used(msg)
19767 mark_used(dest)
19768 mark_used(tag)
19769 mark_used(comm)
19770 ! only defined in parallel
19771 cpabort("not in parallel mode")
19772#endif
19773 CALL mp_timestop(handle)
19774 END SUBROUTINE mp_send_rm2
19775
19776! **************************************************************************************************
19777!> \brief Send rank-3 data to another process
19778!> \param[in] msg Rank-3 data to send
19779!> \param dest ...
19780!> \param tag ...
19781!> \param comm ...
19782!> \note see mp_send_r
19783! **************************************************************************************************
19784 SUBROUTINE mp_send_rm3(msg, dest, tag, comm)
19785 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
19786 INTEGER, INTENT(IN) :: dest, tag
19787 CLASS(mp_comm_type), INTENT(IN) :: comm
19788
19789 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
19790
19791 INTEGER :: handle
19792#if defined(__parallel)
19793 INTEGER :: ierr, msglen
19794#endif
19795
19796 CALL mp_timeset(routinen, handle)
19797
19798#if defined(__parallel)
19799 msglen = SIZE(msg)
19800 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19801 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19802 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19803#else
19804 mark_used(msg)
19805 mark_used(dest)
19806 mark_used(tag)
19807 mark_used(comm)
19808 ! only defined in parallel
19809 cpabort("not in parallel mode")
19810#endif
19811 CALL mp_timestop(handle)
19812 END SUBROUTINE mp_send_rm3
19813
19814! **************************************************************************************************
19815!> \brief Receive one datum from another process
19816!> \param[in,out] msg Place received data into this variable
19817!> \param[in,out] source Process to receive from
19818!> \param[in,out] tag Transfer identifier
19819!> \param[in] comm Message passing environment identifier
19820!> \par MPI mapping
19821!> mpi_send
19822! **************************************************************************************************
19823 SUBROUTINE mp_recv_r (msg, source, tag, comm)
19824 REAL(kind=real_4), INTENT(INOUT) :: msg
19825 INTEGER, INTENT(INOUT) :: source, tag
19826 CLASS(mp_comm_type), INTENT(IN) :: comm
19827
19828 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_r'
19829
19830 INTEGER :: handle
19831#if defined(__parallel)
19832 INTEGER :: ierr, msglen
19833 mpi_status_type :: status
19834#endif
19835
19836 CALL mp_timeset(routinen, handle)
19837
19838#if defined(__parallel)
19839 msglen = 1
19840 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19841 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19842 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19843 ELSE
19844 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19845 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19846 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19847 source = status mpi_status_extract(mpi_source)
19848 tag = status mpi_status_extract(mpi_tag)
19849 END IF
19850#else
19851 mark_used(msg)
19852 mark_used(source)
19853 mark_used(tag)
19854 mark_used(comm)
19855 ! only defined in parallel
19856 cpabort("not in parallel mode")
19857#endif
19858 CALL mp_timestop(handle)
19859 END SUBROUTINE mp_recv_r
19860
19861! **************************************************************************************************
19862!> \brief Receive rank-1 data from another process
19863!> \param[in,out] msg Place received data into this rank-1 array
19864!> \param source ...
19865!> \param tag ...
19866!> \param comm ...
19867!> \note see mp_recv_r
19868! **************************************************************************************************
19869 SUBROUTINE mp_recv_rv(msg, source, tag, comm)
19870 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19871 INTEGER, INTENT(INOUT) :: source, tag
19872 CLASS(mp_comm_type), INTENT(IN) :: comm
19873
19874 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rv'
19875
19876 INTEGER :: handle
19877#if defined(__parallel)
19878 INTEGER :: ierr, msglen
19879 mpi_status_type :: status
19880#endif
19881
19882 CALL mp_timeset(routinen, handle)
19883
19884#if defined(__parallel)
19885 msglen = SIZE(msg)
19886 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19887 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19888 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19889 ELSE
19890 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19891 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19892 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19893 source = status mpi_status_extract(mpi_source)
19894 tag = status mpi_status_extract(mpi_tag)
19895 END IF
19896#else
19897 mark_used(msg)
19898 mark_used(source)
19899 mark_used(tag)
19900 mark_used(comm)
19901 ! only defined in parallel
19902 cpabort("not in parallel mode")
19903#endif
19904 CALL mp_timestop(handle)
19905 END SUBROUTINE mp_recv_rv
19906
19907! **************************************************************************************************
19908!> \brief Receive rank-2 data from another process
19909!> \param[in,out] msg Place received data into this rank-2 array
19910!> \param source ...
19911!> \param tag ...
19912!> \param comm ...
19913!> \note see mp_recv_r
19914! **************************************************************************************************
19915 SUBROUTINE mp_recv_rm2(msg, source, tag, comm)
19916 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
19917 INTEGER, INTENT(INOUT) :: source, tag
19918 CLASS(mp_comm_type), INTENT(IN) :: comm
19919
19920 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rm2'
19921
19922 INTEGER :: handle
19923#if defined(__parallel)
19924 INTEGER :: ierr, msglen
19925 mpi_status_type :: status
19926#endif
19927
19928 CALL mp_timeset(routinen, handle)
19929
19930#if defined(__parallel)
19931 msglen = SIZE(msg)
19932 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19933 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19934 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19935 ELSE
19936 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19937 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19938 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19939 source = status mpi_status_extract(mpi_source)
19940 tag = status mpi_status_extract(mpi_tag)
19941 END IF
19942#else
19943 mark_used(msg)
19944 mark_used(source)
19945 mark_used(tag)
19946 mark_used(comm)
19947 ! only defined in parallel
19948 cpabort("not in parallel mode")
19949#endif
19950 CALL mp_timestop(handle)
19951 END SUBROUTINE mp_recv_rm2
19952
19953! **************************************************************************************************
19954!> \brief Receive rank-3 data from another process
19955!> \param[in,out] msg Place received data into this rank-3 array
19956!> \param source ...
19957!> \param tag ...
19958!> \param comm ...
19959!> \note see mp_recv_r
19960! **************************************************************************************************
19961 SUBROUTINE mp_recv_rm3(msg, source, tag, comm)
19962 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
19963 INTEGER, INTENT(INOUT) :: source, tag
19964 CLASS(mp_comm_type), INTENT(IN) :: comm
19965
19966 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rm3'
19967
19968 INTEGER :: handle
19969#if defined(__parallel)
19970 INTEGER :: ierr, msglen
19971 mpi_status_type :: status
19972#endif
19973
19974 CALL mp_timeset(routinen, handle)
19975
19976#if defined(__parallel)
19977 msglen = SIZE(msg)
19978 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19979 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19980 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19981 ELSE
19982 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19983 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19984 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19985 source = status mpi_status_extract(mpi_source)
19986 tag = status mpi_status_extract(mpi_tag)
19987 END IF
19988#else
19989 mark_used(msg)
19990 mark_used(source)
19991 mark_used(tag)
19992 mark_used(comm)
19993 ! only defined in parallel
19994 cpabort("not in parallel mode")
19995#endif
19996 CALL mp_timestop(handle)
19997 END SUBROUTINE mp_recv_rm3
19998
19999! **************************************************************************************************
20000!> \brief Broadcasts a datum to all processes.
20001!> \param[in] msg Datum to broadcast
20002!> \param[in] source Processes which broadcasts
20003!> \param[in] comm Message passing environment identifier
20004!> \par MPI mapping
20005!> mpi_bcast
20006! **************************************************************************************************
20007 SUBROUTINE mp_bcast_r (msg, source, comm)
20008 REAL(kind=real_4), INTENT(INOUT) :: msg
20009 INTEGER, INTENT(IN) :: source
20010 CLASS(mp_comm_type), INTENT(IN) :: comm
20011
20012 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r'
20013
20014 INTEGER :: handle
20015#if defined(__parallel)
20016 INTEGER :: ierr, msglen
20017#endif
20018
20019 CALL mp_timeset(routinen, handle)
20020
20021#if defined(__parallel)
20022 msglen = 1
20023 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20024 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20025 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20026#else
20027 mark_used(msg)
20028 mark_used(source)
20029 mark_used(comm)
20030#endif
20031 CALL mp_timestop(handle)
20032 END SUBROUTINE mp_bcast_r
20033
20034! **************************************************************************************************
20035!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
20036!> \param[in] msg Datum to broadcast
20037!> \param[in] comm Message passing environment identifier
20038!> \par MPI mapping
20039!> mpi_bcast
20040! **************************************************************************************************
20041 SUBROUTINE mp_bcast_r_src(msg, comm)
20042 REAL(kind=real_4), INTENT(INOUT) :: msg
20043 CLASS(mp_comm_type), INTENT(IN) :: comm
20044
20045 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r_src'
20046
20047 INTEGER :: handle
20048#if defined(__parallel)
20049 INTEGER :: ierr, msglen
20050#endif
20051
20052 CALL mp_timeset(routinen, handle)
20053
20054#if defined(__parallel)
20055 msglen = 1
20056 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20057 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20058 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20059#else
20060 mark_used(msg)
20061 mark_used(comm)
20062#endif
20063 CALL mp_timestop(handle)
20064 END SUBROUTINE mp_bcast_r_src
20065
20066! **************************************************************************************************
20067!> \brief Broadcasts a datum to all processes.
20068!> \param[in] msg Datum to broadcast
20069!> \param[in] source Processes which broadcasts
20070!> \param[in] comm Message passing environment identifier
20071!> \par MPI mapping
20072!> mpi_bcast
20073! **************************************************************************************************
20074 SUBROUTINE mp_ibcast_r (msg, source, comm, request)
20075 REAL(kind=real_4), INTENT(INOUT) :: msg
20076 INTEGER, INTENT(IN) :: source
20077 CLASS(mp_comm_type), INTENT(IN) :: comm
20078 TYPE(mp_request_type), INTENT(OUT) :: request
20079
20080 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_r'
20081
20082 INTEGER :: handle
20083#if defined(__parallel)
20084 INTEGER :: ierr, msglen
20085#endif
20086
20087 CALL mp_timeset(routinen, handle)
20088
20089#if defined(__parallel)
20090 msglen = 1
20091 CALL mpi_ibcast(msg, msglen, mpi_real, source, comm%handle, request%handle, ierr)
20092 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
20093 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_4_size)
20094#else
20095 mark_used(msg)
20096 mark_used(source)
20097 mark_used(comm)
20098 request = mp_request_null
20099#endif
20100 CALL mp_timestop(handle)
20101 END SUBROUTINE mp_ibcast_r
20102
20103! **************************************************************************************************
20104!> \brief Broadcasts rank-1 data to all processes
20105!> \param[in] msg Data to broadcast
20106!> \param source ...
20107!> \param comm ...
20108!> \note see mp_bcast_r1
20109! **************************************************************************************************
20110 SUBROUTINE mp_bcast_rv(msg, source, comm)
20111 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20112 INTEGER, INTENT(IN) :: source
20113 CLASS(mp_comm_type), INTENT(IN) :: comm
20114
20115 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rv'
20116
20117 INTEGER :: handle
20118#if defined(__parallel)
20119 INTEGER :: ierr, msglen
20120#endif
20121
20122 CALL mp_timeset(routinen, handle)
20123
20124#if defined(__parallel)
20125 msglen = SIZE(msg)
20126 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20127 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20128 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20129#else
20130 mark_used(msg)
20131 mark_used(source)
20132 mark_used(comm)
20133#endif
20134 CALL mp_timestop(handle)
20135 END SUBROUTINE mp_bcast_rv
20136
20137! **************************************************************************************************
20138!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
20139!> \param[in] msg Data to broadcast
20140!> \param comm ...
20141!> \note see mp_bcast_r1
20142! **************************************************************************************************
20143 SUBROUTINE mp_bcast_rv_src(msg, comm)
20144 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20145 CLASS(mp_comm_type), INTENT(IN) :: comm
20146
20147 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rv_src'
20148
20149 INTEGER :: handle
20150#if defined(__parallel)
20151 INTEGER :: ierr, msglen
20152#endif
20153
20154 CALL mp_timeset(routinen, handle)
20155
20156#if defined(__parallel)
20157 msglen = SIZE(msg)
20158 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20159 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20160 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20161#else
20162 mark_used(msg)
20163 mark_used(comm)
20164#endif
20165 CALL mp_timestop(handle)
20166 END SUBROUTINE mp_bcast_rv_src
20167
20168! **************************************************************************************************
20169!> \brief Broadcasts rank-1 data to all processes
20170!> \param[in] msg Data to broadcast
20171!> \param source ...
20172!> \param comm ...
20173!> \note see mp_bcast_r1
20174! **************************************************************************************************
20175 SUBROUTINE mp_ibcast_rv(msg, source, comm, request)
20176 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20177 INTEGER, INTENT(IN) :: source
20178 CLASS(mp_comm_type), INTENT(IN) :: comm
20179 TYPE(mp_request_type) :: request
20180
20181 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_rv'
20182
20183 INTEGER :: handle
20184#if defined(__parallel)
20185 INTEGER :: ierr, msglen
20186#endif
20187
20188 CALL mp_timeset(routinen, handle)
20189
20190#if defined(__parallel)
20191#if !defined(__GNUC__) || __GNUC__ >= 9
20192 cpassert(is_contiguous(msg))
20193#endif
20194 msglen = SIZE(msg)
20195 CALL mpi_ibcast(msg, msglen, mpi_real, source, comm%handle, request%handle, ierr)
20196 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
20197 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_4_size)
20198#else
20199 mark_used(msg)
20200 mark_used(source)
20201 mark_used(comm)
20202 request = mp_request_null
20203#endif
20204 CALL mp_timestop(handle)
20205 END SUBROUTINE mp_ibcast_rv
20206
20207! **************************************************************************************************
20208!> \brief Broadcasts rank-2 data to all processes
20209!> \param[in] msg Data to broadcast
20210!> \param source ...
20211!> \param comm ...
20212!> \note see mp_bcast_r1
20213! **************************************************************************************************
20214 SUBROUTINE mp_bcast_rm(msg, source, comm)
20215 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20216 INTEGER, INTENT(IN) :: source
20217 CLASS(mp_comm_type), INTENT(IN) :: comm
20218
20219 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rm'
20220
20221 INTEGER :: handle
20222#if defined(__parallel)
20223 INTEGER :: ierr, msglen
20224#endif
20225
20226 CALL mp_timeset(routinen, handle)
20227
20228#if defined(__parallel)
20229 msglen = SIZE(msg)
20230 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20231 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20232 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20233#else
20234 mark_used(msg)
20235 mark_used(source)
20236 mark_used(comm)
20237#endif
20238 CALL mp_timestop(handle)
20239 END SUBROUTINE mp_bcast_rm
20240
20241! **************************************************************************************************
20242!> \brief Broadcasts rank-2 data to all processes
20243!> \param[in] msg Data to broadcast
20244!> \param source ...
20245!> \param comm ...
20246!> \note see mp_bcast_r1
20247! **************************************************************************************************
20248 SUBROUTINE mp_bcast_rm_src(msg, comm)
20249 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20250 CLASS(mp_comm_type), INTENT(IN) :: comm
20251
20252 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rm_src'
20253
20254 INTEGER :: handle
20255#if defined(__parallel)
20256 INTEGER :: ierr, msglen
20257#endif
20258
20259 CALL mp_timeset(routinen, handle)
20260
20261#if defined(__parallel)
20262 msglen = SIZE(msg)
20263 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20264 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20265 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20266#else
20267 mark_used(msg)
20268 mark_used(comm)
20269#endif
20270 CALL mp_timestop(handle)
20271 END SUBROUTINE mp_bcast_rm_src
20272
20273! **************************************************************************************************
20274!> \brief Broadcasts rank-3 data to all processes
20275!> \param[in] msg Data to broadcast
20276!> \param source ...
20277!> \param comm ...
20278!> \note see mp_bcast_r1
20279! **************************************************************************************************
20280 SUBROUTINE mp_bcast_r3(msg, source, comm)
20281 REAL(kind=real_4), CONTIGUOUS :: msg(:, :, :)
20282 INTEGER, INTENT(IN) :: source
20283 CLASS(mp_comm_type), INTENT(IN) :: comm
20284
20285 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r3'
20286
20287 INTEGER :: handle
20288#if defined(__parallel)
20289 INTEGER :: ierr, msglen
20290#endif
20291
20292 CALL mp_timeset(routinen, handle)
20293
20294#if defined(__parallel)
20295 msglen = SIZE(msg)
20296 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20297 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20298 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20299#else
20300 mark_used(msg)
20301 mark_used(source)
20302 mark_used(comm)
20303#endif
20304 CALL mp_timestop(handle)
20305 END SUBROUTINE mp_bcast_r3
20306
20307! **************************************************************************************************
20308!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
20309!> \param[in] msg Data to broadcast
20310!> \param source ...
20311!> \param comm ...
20312!> \note see mp_bcast_r1
20313! **************************************************************************************************
20314 SUBROUTINE mp_bcast_r3_src(msg, comm)
20315 REAL(kind=real_4), CONTIGUOUS :: msg(:, :, :)
20316 CLASS(mp_comm_type), INTENT(IN) :: comm
20317
20318 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r3_src'
20319
20320 INTEGER :: handle
20321#if defined(__parallel)
20322 INTEGER :: ierr, msglen
20323#endif
20324
20325 CALL mp_timeset(routinen, handle)
20326
20327#if defined(__parallel)
20328 msglen = SIZE(msg)
20329 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20330 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20331 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20332#else
20333 mark_used(msg)
20334 mark_used(comm)
20335#endif
20336 CALL mp_timestop(handle)
20337 END SUBROUTINE mp_bcast_r3_src
20338
20339! **************************************************************************************************
20340!> \brief Sums a datum from all processes with result left on all processes.
20341!> \param[in,out] msg Datum to sum (input) and result (output)
20342!> \param[in] comm Message passing environment identifier
20343!> \par MPI mapping
20344!> mpi_allreduce
20345! **************************************************************************************************
20346 SUBROUTINE mp_sum_r (msg, comm)
20347 REAL(kind=real_4), INTENT(INOUT) :: msg
20348 CLASS(mp_comm_type), INTENT(IN) :: comm
20349
20350 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_r'
20351
20352 INTEGER :: handle
20353#if defined(__parallel)
20354 INTEGER :: ierr, msglen
20355#endif
20356
20357 CALL mp_timeset(routinen, handle)
20358
20359#if defined(__parallel)
20360 msglen = 1
20361 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20362 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20363 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20364#else
20365 mark_used(msg)
20366 mark_used(comm)
20367#endif
20368 CALL mp_timestop(handle)
20369 END SUBROUTINE mp_sum_r
20370
20371! **************************************************************************************************
20372!> \brief Element-wise sum of a rank-1 array on all processes.
20373!> \param[in,out] msg Vector to sum and result
20374!> \param comm ...
20375!> \note see mp_sum_r
20376! **************************************************************************************************
20377 SUBROUTINE mp_sum_rv(msg, comm)
20378 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20379 CLASS(mp_comm_type), INTENT(IN) :: comm
20380
20381 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rv'
20382
20383 INTEGER :: handle
20384#if defined(__parallel)
20385 INTEGER :: ierr, msglen
20386#endif
20387
20388 CALL mp_timeset(routinen, handle)
20389
20390#if defined(__parallel)
20391 msglen = SIZE(msg)
20392 IF (msglen > 0) THEN
20393 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20394 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20395 END IF
20396 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20397#else
20398 mark_used(msg)
20399 mark_used(comm)
20400#endif
20401 CALL mp_timestop(handle)
20402 END SUBROUTINE mp_sum_rv
20403
20404! **************************************************************************************************
20405!> \brief Element-wise sum of a rank-1 array on all processes.
20406!> \param[in,out] msg Vector to sum and result
20407!> \param comm ...
20408!> \note see mp_sum_r
20409! **************************************************************************************************
20410 SUBROUTINE mp_isum_rv(msg, comm, request)
20411 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20412 CLASS(mp_comm_type), INTENT(IN) :: comm
20413 TYPE(mp_request_type), INTENT(OUT) :: request
20414
20415 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_rv'
20416
20417 INTEGER :: handle
20418#if defined(__parallel)
20419 INTEGER :: ierr, msglen
20420#endif
20421
20422 CALL mp_timeset(routinen, handle)
20423
20424#if defined(__parallel)
20425#if !defined(__GNUC__) || __GNUC__ >= 9
20426 cpassert(is_contiguous(msg))
20427#endif
20428 msglen = SIZE(msg)
20429 IF (msglen > 0) THEN
20430 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, request%handle, ierr)
20431 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
20432 ELSE
20433 request = mp_request_null
20434 END IF
20435 CALL add_perf(perf_id=23, count=1, msg_size=msglen*real_4_size)
20436#else
20437 mark_used(msg)
20438 mark_used(comm)
20439 request = mp_request_null
20440#endif
20441 CALL mp_timestop(handle)
20442 END SUBROUTINE mp_isum_rv
20443
20444! **************************************************************************************************
20445!> \brief Element-wise sum of a rank-2 array on all processes.
20446!> \param[in] msg Matrix to sum and result
20447!> \param comm ...
20448!> \note see mp_sum_r
20449! **************************************************************************************************
20450 SUBROUTINE mp_sum_rm(msg, comm)
20451 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20452 CLASS(mp_comm_type), INTENT(IN) :: comm
20453
20454 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm'
20455
20456 INTEGER :: handle
20457#if defined(__parallel)
20458 INTEGER, PARAMETER :: max_msg = 2**25
20459 INTEGER :: ierr, m1, msglen, step, msglensum
20460#endif
20461
20462 CALL mp_timeset(routinen, handle)
20463
20464#if defined(__parallel)
20465 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
20466 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
20467 msglensum = 0
20468 DO m1 = lbound(msg, 2), ubound(msg, 2), step
20469 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
20470 msglensum = msglensum + msglen
20471 IF (msglen > 0) THEN
20472 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_real, mpi_sum, comm%handle, ierr)
20473 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20474 END IF
20475 END DO
20476 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_4_size)
20477#else
20478 mark_used(msg)
20479 mark_used(comm)
20480#endif
20481 CALL mp_timestop(handle)
20482 END SUBROUTINE mp_sum_rm
20483
20484! **************************************************************************************************
20485!> \brief Element-wise sum of a rank-3 array on all processes.
20486!> \param[in] msg Array to sum and result
20487!> \param comm ...
20488!> \note see mp_sum_r
20489! **************************************************************************************************
20490 SUBROUTINE mp_sum_rm3(msg, comm)
20491 REAL(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
20492 CLASS(mp_comm_type), INTENT(IN) :: comm
20493
20494 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm3'
20495
20496 INTEGER :: handle
20497#if defined(__parallel)
20498 INTEGER :: ierr, msglen
20499#endif
20500
20501 CALL mp_timeset(routinen, handle)
20502
20503#if defined(__parallel)
20504 msglen = SIZE(msg)
20505 IF (msglen > 0) THEN
20506 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20507 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20508 END IF
20509 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20510#else
20511 mark_used(msg)
20512 mark_used(comm)
20513#endif
20514 CALL mp_timestop(handle)
20515 END SUBROUTINE mp_sum_rm3
20516
20517! **************************************************************************************************
20518!> \brief Element-wise sum of a rank-4 array on all processes.
20519!> \param[in] msg Array to sum and result
20520!> \param comm ...
20521!> \note see mp_sum_r
20522! **************************************************************************************************
20523 SUBROUTINE mp_sum_rm4(msg, comm)
20524 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
20525 CLASS(mp_comm_type), INTENT(IN) :: comm
20526
20527 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm4'
20528
20529 INTEGER :: handle
20530#if defined(__parallel)
20531 INTEGER :: ierr, msglen
20532#endif
20533
20534 CALL mp_timeset(routinen, handle)
20535
20536#if defined(__parallel)
20537 msglen = SIZE(msg)
20538 IF (msglen > 0) THEN
20539 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20540 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20541 END IF
20542 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20543#else
20544 mark_used(msg)
20545 mark_used(comm)
20546#endif
20547 CALL mp_timestop(handle)
20548 END SUBROUTINE mp_sum_rm4
20549
20550! **************************************************************************************************
20551!> \brief Element-wise sum of data from all processes with result left only on
20552!> one.
20553!> \param[in,out] msg Vector to sum (input) and (only on process root)
20554!> result (output)
20555!> \param root ...
20556!> \param[in] comm Message passing environment identifier
20557!> \par MPI mapping
20558!> mpi_reduce
20559! **************************************************************************************************
20560 SUBROUTINE mp_sum_root_rv(msg, root, comm)
20561 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20562 INTEGER, INTENT(IN) :: root
20563 CLASS(mp_comm_type), INTENT(IN) :: comm
20564
20565 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rv'
20566
20567 INTEGER :: handle
20568#if defined(__parallel)
20569 INTEGER :: ierr, m1, msglen, taskid
20570 REAL(kind=real_4), ALLOCATABLE :: res(:)
20571#endif
20572
20573 CALL mp_timeset(routinen, handle)
20574
20575#if defined(__parallel)
20576 msglen = SIZE(msg)
20577 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20578 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20579 IF (msglen > 0) THEN
20580 m1 = SIZE(msg, 1)
20581 ALLOCATE (res(m1))
20582 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_sum, &
20583 root, comm%handle, ierr)
20584 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20585 IF (taskid == root) THEN
20586 msg = res
20587 END IF
20588 DEALLOCATE (res)
20589 END IF
20590 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20591#else
20592 mark_used(msg)
20593 mark_used(root)
20594 mark_used(comm)
20595#endif
20596 CALL mp_timestop(handle)
20597 END SUBROUTINE mp_sum_root_rv
20598
20599! **************************************************************************************************
20600!> \brief Element-wise sum of data from all processes with result left only on
20601!> one.
20602!> \param[in,out] msg Matrix to sum (input) and (only on process root)
20603!> result (output)
20604!> \param root ...
20605!> \param comm ...
20606!> \note see mp_sum_root_rv
20607! **************************************************************************************************
20608 SUBROUTINE mp_sum_root_rm(msg, root, comm)
20609 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20610 INTEGER, INTENT(IN) :: root
20611 CLASS(mp_comm_type), INTENT(IN) :: comm
20612
20613 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
20614
20615 INTEGER :: handle
20616#if defined(__parallel)
20617 INTEGER :: ierr, m1, m2, msglen, taskid
20618 REAL(kind=real_4), ALLOCATABLE :: res(:, :)
20619#endif
20620
20621 CALL mp_timeset(routinen, handle)
20622
20623#if defined(__parallel)
20624 msglen = SIZE(msg)
20625 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20626 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20627 IF (msglen > 0) THEN
20628 m1 = SIZE(msg, 1)
20629 m2 = SIZE(msg, 2)
20630 ALLOCATE (res(m1, m2))
20631 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_sum, root, comm%handle, ierr)
20632 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20633 IF (taskid == root) THEN
20634 msg = res
20635 END IF
20636 DEALLOCATE (res)
20637 END IF
20638 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20639#else
20640 mark_used(root)
20641 mark_used(msg)
20642 mark_used(comm)
20643#endif
20644 CALL mp_timestop(handle)
20645 END SUBROUTINE mp_sum_root_rm
20646
20647! **************************************************************************************************
20648!> \brief Partial sum of data from all processes with result on each process.
20649!> \param[in] msg Matrix to sum (input)
20650!> \param[out] res Matrix containing result (output)
20651!> \param[in] comm Message passing environment identifier
20652! **************************************************************************************************
20653 SUBROUTINE mp_sum_partial_rm(msg, res, comm)
20654 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
20655 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
20656 CLASS(mp_comm_type), INTENT(IN) :: comm
20657
20658 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_rm'
20659
20660 INTEGER :: handle
20661#if defined(__parallel)
20662 INTEGER :: ierr, msglen, taskid
20663#endif
20664
20665 CALL mp_timeset(routinen, handle)
20666
20667#if defined(__parallel)
20668 msglen = SIZE(msg)
20669 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20670 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20671 IF (msglen > 0) THEN
20672 CALL mpi_scan(msg, res, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20673 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
20674 END IF
20675 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20676 ! perf_id is same as for other summation routines
20677#else
20678 res = msg
20679 mark_used(comm)
20680#endif
20681 CALL mp_timestop(handle)
20682 END SUBROUTINE mp_sum_partial_rm
20683
20684! **************************************************************************************************
20685!> \brief Finds the maximum of a datum with the result left on all processes.
20686!> \param[in,out] msg Find maximum among these data (input) and
20687!> maximum (output)
20688!> \param[in] comm Message passing environment identifier
20689!> \par MPI mapping
20690!> mpi_allreduce
20691! **************************************************************************************************
20692 SUBROUTINE mp_max_r (msg, comm)
20693 REAL(kind=real_4), INTENT(INOUT) :: msg
20694 CLASS(mp_comm_type), INTENT(IN) :: comm
20695
20696 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_r'
20697
20698 INTEGER :: handle
20699#if defined(__parallel)
20700 INTEGER :: ierr, msglen
20701#endif
20702
20703 CALL mp_timeset(routinen, handle)
20704
20705#if defined(__parallel)
20706 msglen = 1
20707 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_max, comm%handle, ierr)
20708 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20709 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20710#else
20711 mark_used(msg)
20712 mark_used(comm)
20713#endif
20714 CALL mp_timestop(handle)
20715 END SUBROUTINE mp_max_r
20716
20717! **************************************************************************************************
20718!> \brief Finds the maximum of a datum with the result left on all processes.
20719!> \param[in,out] msg Find maximum among these data (input) and
20720!> maximum (output)
20721!> \param[in] comm Message passing environment identifier
20722!> \par MPI mapping
20723!> mpi_allreduce
20724! **************************************************************************************************
20725 SUBROUTINE mp_max_root_r (msg, root, comm)
20726 REAL(kind=real_4), INTENT(INOUT) :: msg
20727 INTEGER, INTENT(IN) :: root
20728 CLASS(mp_comm_type), INTENT(IN) :: comm
20729
20730 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_r'
20731
20732 INTEGER :: handle
20733#if defined(__parallel)
20734 INTEGER :: ierr, msglen
20735 REAL(kind=real_4) :: res
20736#endif
20737
20738 CALL mp_timeset(routinen, handle)
20739
20740#if defined(__parallel)
20741 msglen = 1
20742 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_max, root, comm%handle, ierr)
20743 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20744 IF (root == comm%mepos) msg = res
20745 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20746#else
20747 mark_used(msg)
20748 mark_used(comm)
20749 mark_used(root)
20750#endif
20751 CALL mp_timestop(handle)
20752 END SUBROUTINE mp_max_root_r
20753
20754! **************************************************************************************************
20755!> \brief Finds the element-wise maximum of a vector with the result left on
20756!> all processes.
20757!> \param[in,out] msg Find maximum among these data (input) and
20758!> maximum (output)
20759!> \param comm ...
20760!> \note see mp_max_r
20761! **************************************************************************************************
20762 SUBROUTINE mp_max_rv(msg, comm)
20763 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20764 CLASS(mp_comm_type), INTENT(IN) :: comm
20765
20766 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_rv'
20767
20768 INTEGER :: handle
20769#if defined(__parallel)
20770 INTEGER :: ierr, msglen
20771#endif
20772
20773 CALL mp_timeset(routinen, handle)
20774
20775#if defined(__parallel)
20776 msglen = SIZE(msg)
20777 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_max, comm%handle, ierr)
20778 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20779 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20780#else
20781 mark_used(msg)
20782 mark_used(comm)
20783#endif
20784 CALL mp_timestop(handle)
20785 END SUBROUTINE mp_max_rv
20786
20787! **************************************************************************************************
20788!> \brief Finds the element-wise maximum of a vector with the result left on
20789!> all processes.
20790!> \param[in,out] msg Find maximum among these data (input) and
20791!> maximum (output)
20792!> \param comm ...
20793!> \note see mp_max_r
20794! **************************************************************************************************
20795 SUBROUTINE mp_max_root_rm(msg, root, comm)
20796 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20797 INTEGER :: root
20798 CLASS(mp_comm_type), INTENT(IN) :: comm
20799
20800 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_rm'
20801
20802 INTEGER :: handle
20803#if defined(__parallel)
20804 INTEGER :: ierr, msglen
20805 REAL(kind=real_4) :: res(SIZE(msg, 1), SIZE(msg, 2))
20806#endif
20807
20808 CALL mp_timeset(routinen, handle)
20809
20810#if defined(__parallel)
20811 msglen = SIZE(msg)
20812 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_max, root, comm%handle, ierr)
20813 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20814 IF (root == comm%mepos) msg = res
20815 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20816#else
20817 mark_used(msg)
20818 mark_used(comm)
20819 mark_used(root)
20820#endif
20821 CALL mp_timestop(handle)
20822 END SUBROUTINE mp_max_root_rm
20823
20824! **************************************************************************************************
20825!> \brief Finds the minimum of a datum with the result left on all processes.
20826!> \param[in,out] msg Find minimum among these data (input) and
20827!> maximum (output)
20828!> \param[in] comm Message passing environment identifier
20829!> \par MPI mapping
20830!> mpi_allreduce
20831! **************************************************************************************************
20832 SUBROUTINE mp_min_r (msg, comm)
20833 REAL(kind=real_4), INTENT(INOUT) :: msg
20834 CLASS(mp_comm_type), INTENT(IN) :: comm
20835
20836 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_r'
20837
20838 INTEGER :: handle
20839#if defined(__parallel)
20840 INTEGER :: ierr, msglen
20841#endif
20842
20843 CALL mp_timeset(routinen, handle)
20844
20845#if defined(__parallel)
20846 msglen = 1
20847 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_min, comm%handle, ierr)
20848 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20849 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20850#else
20851 mark_used(msg)
20852 mark_used(comm)
20853#endif
20854 CALL mp_timestop(handle)
20855 END SUBROUTINE mp_min_r
20856
20857! **************************************************************************************************
20858!> \brief Finds the element-wise minimum of vector with the result left on
20859!> all processes.
20860!> \param[in,out] msg Find minimum among these data (input) and
20861!> maximum (output)
20862!> \param comm ...
20863!> \par MPI mapping
20864!> mpi_allreduce
20865!> \note see mp_min_r
20866! **************************************************************************************************
20867 SUBROUTINE mp_min_rv(msg, comm)
20868 REAL(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
20869 CLASS(mp_comm_type), INTENT(IN) :: comm
20870
20871 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_rv'
20872
20873 INTEGER :: handle
20874#if defined(__parallel)
20875 INTEGER :: ierr, msglen
20876#endif
20877
20878 CALL mp_timeset(routinen, handle)
20879
20880#if defined(__parallel)
20881 msglen = SIZE(msg)
20882 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_min, comm%handle, ierr)
20883 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20884 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20885#else
20886 mark_used(msg)
20887 mark_used(comm)
20888#endif
20889 CALL mp_timestop(handle)
20890 END SUBROUTINE mp_min_rv
20891
20892! **************************************************************************************************
20893!> \brief Multiplies a set of numbers scattered across a number of processes,
20894!> then replicates the result.
20895!> \param[in,out] msg a number to multiply (input) and result (output)
20896!> \param[in] comm message passing environment identifier
20897!> \par MPI mapping
20898!> mpi_allreduce
20899! **************************************************************************************************
20900 SUBROUTINE mp_prod_r (msg, comm)
20901 REAL(kind=real_4), INTENT(INOUT) :: msg
20902 CLASS(mp_comm_type), INTENT(IN) :: comm
20903
20904 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_r'
20905
20906 INTEGER :: handle
20907#if defined(__parallel)
20908 INTEGER :: ierr, msglen
20909#endif
20910
20911 CALL mp_timeset(routinen, handle)
20912
20913#if defined(__parallel)
20914 msglen = 1
20915 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_prod, comm%handle, ierr)
20916 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20917 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20918#else
20919 mark_used(msg)
20920 mark_used(comm)
20921#endif
20922 CALL mp_timestop(handle)
20923 END SUBROUTINE mp_prod_r
20924
20925! **************************************************************************************************
20926!> \brief Scatters data from one processes to all others
20927!> \param[in] msg_scatter Data to scatter (for root process)
20928!> \param[out] msg Received data
20929!> \param[in] root Process which scatters data
20930!> \param[in] comm Message passing environment identifier
20931!> \par MPI mapping
20932!> mpi_scatter
20933! **************************************************************************************************
20934 SUBROUTINE mp_scatter_rv(msg_scatter, msg, root, comm)
20935 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
20936 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
20937 INTEGER, INTENT(IN) :: root
20938 CLASS(mp_comm_type), INTENT(IN) :: comm
20939
20940 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_rv'
20941
20942 INTEGER :: handle
20943#if defined(__parallel)
20944 INTEGER :: ierr, msglen
20945#endif
20946
20947 CALL mp_timeset(routinen, handle)
20948
20949#if defined(__parallel)
20950 msglen = SIZE(msg)
20951 CALL mpi_scatter(msg_scatter, msglen, mpi_real, msg, &
20952 msglen, mpi_real, root, comm%handle, ierr)
20953 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
20954 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
20955#else
20956 mark_used(root)
20957 mark_used(comm)
20958 msg = msg_scatter
20959#endif
20960 CALL mp_timestop(handle)
20961 END SUBROUTINE mp_scatter_rv
20962
20963! **************************************************************************************************
20964!> \brief Scatters data from one processes to all others
20965!> \param[in] msg_scatter Data to scatter (for root process)
20966!> \param[in] root Process which scatters data
20967!> \param[in] comm Message passing environment identifier
20968!> \par MPI mapping
20969!> mpi_scatter
20970! **************************************************************************************************
20971 SUBROUTINE mp_iscatter_r (msg_scatter, msg, root, comm, request)
20972 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:)
20973 REAL(kind=real_4), INTENT(INOUT) :: msg
20974 INTEGER, INTENT(IN) :: root
20975 CLASS(mp_comm_type), INTENT(IN) :: comm
20976 TYPE(mp_request_type), INTENT(OUT) :: request
20977
20978 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_r'
20979
20980 INTEGER :: handle
20981#if defined(__parallel)
20982 INTEGER :: ierr, msglen
20983#endif
20984
20985 CALL mp_timeset(routinen, handle)
20986
20987#if defined(__parallel)
20988#if !defined(__GNUC__) || __GNUC__ >= 9
20989 cpassert(is_contiguous(msg_scatter))
20990#endif
20991 msglen = 1
20992 CALL mpi_iscatter(msg_scatter, msglen, mpi_real, msg, &
20993 msglen, mpi_real, root, comm%handle, request%handle, ierr)
20994 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
20995 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
20996#else
20997 mark_used(root)
20998 mark_used(comm)
20999 msg = msg_scatter(1)
21000 request = mp_request_null
21001#endif
21002 CALL mp_timestop(handle)
21003 END SUBROUTINE mp_iscatter_r
21004
21005! **************************************************************************************************
21006!> \brief Scatters data from one processes to all others
21007!> \param[in] msg_scatter Data to scatter (for root process)
21008!> \param[in] root Process which scatters data
21009!> \param[in] comm Message passing environment identifier
21010!> \par MPI mapping
21011!> mpi_scatter
21012! **************************************************************************************************
21013 SUBROUTINE mp_iscatter_rv2(msg_scatter, msg, root, comm, request)
21014 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:, :)
21015 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
21016 INTEGER, INTENT(IN) :: root
21017 CLASS(mp_comm_type), INTENT(IN) :: comm
21018 TYPE(mp_request_type), INTENT(OUT) :: request
21019
21020 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_rv2'
21021
21022 INTEGER :: handle
21023#if defined(__parallel)
21024 INTEGER :: ierr, msglen
21025#endif
21026
21027 CALL mp_timeset(routinen, handle)
21028
21029#if defined(__parallel)
21030#if !defined(__GNUC__) || __GNUC__ >= 9
21031 cpassert(is_contiguous(msg_scatter))
21032#endif
21033 msglen = SIZE(msg)
21034 CALL mpi_iscatter(msg_scatter, msglen, mpi_real, msg, &
21035 msglen, mpi_real, root, comm%handle, request%handle, ierr)
21036 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
21037 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
21038#else
21039 mark_used(root)
21040 mark_used(comm)
21041 msg(:) = msg_scatter(:, 1)
21042 request = mp_request_null
21043#endif
21044 CALL mp_timestop(handle)
21045 END SUBROUTINE mp_iscatter_rv2
21046
21047! **************************************************************************************************
21048!> \brief Scatters data from one processes to all others
21049!> \param[in] msg_scatter Data to scatter (for root process)
21050!> \param[in] root Process which scatters data
21051!> \param[in] comm Message passing environment identifier
21052!> \par MPI mapping
21053!> mpi_scatter
21054! **************************************************************************************************
21055 SUBROUTINE mp_iscatterv_rv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
21056 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:)
21057 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
21058 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
21059 INTEGER, INTENT(IN) :: recvcount, root
21060 CLASS(mp_comm_type), INTENT(IN) :: comm
21061 TYPE(mp_request_type), INTENT(OUT) :: request
21062
21063 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_rv'
21064
21065 INTEGER :: handle
21066#if defined(__parallel)
21067 INTEGER :: ierr
21068#endif
21069
21070 CALL mp_timeset(routinen, handle)
21071
21072#if defined(__parallel)
21073#if !defined(__GNUC__) || __GNUC__ >= 9
21074 cpassert(is_contiguous(msg_scatter))
21075 cpassert(is_contiguous(msg))
21076 cpassert(is_contiguous(sendcounts))
21077 cpassert(is_contiguous(displs))
21078#endif
21079 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_real, msg, &
21080 recvcount, mpi_real, root, comm%handle, request%handle, ierr)
21081 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
21082 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
21083#else
21084 mark_used(sendcounts)
21085 mark_used(displs)
21086 mark_used(recvcount)
21087 mark_used(root)
21088 mark_used(comm)
21089 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
21090 request = mp_request_null
21091#endif
21092 CALL mp_timestop(handle)
21093 END SUBROUTINE mp_iscatterv_rv
21094
21095! **************************************************************************************************
21096!> \brief Gathers a datum from all processes to one
21097!> \param[in] msg Datum to send to root
21098!> \param[out] msg_gather Received data (on root)
21099!> \param[in] root Process which gathers the data
21100!> \param[in] comm Message passing environment identifier
21101!> \par MPI mapping
21102!> mpi_gather
21103! **************************************************************************************************
21104 SUBROUTINE mp_gather_r (msg, msg_gather, root, comm)
21105 REAL(kind=real_4), INTENT(IN) :: msg
21106 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21107 INTEGER, INTENT(IN) :: root
21108 CLASS(mp_comm_type), INTENT(IN) :: comm
21109
21110 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_r'
21111
21112 INTEGER :: handle
21113#if defined(__parallel)
21114 INTEGER :: ierr, msglen
21115#endif
21116
21117 CALL mp_timeset(routinen, handle)
21118
21119#if defined(__parallel)
21120 msglen = 1
21121 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21122 msglen, mpi_real, root, comm%handle, ierr)
21123 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21124 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21125#else
21126 mark_used(root)
21127 mark_used(comm)
21128 msg_gather(1) = msg
21129#endif
21130 CALL mp_timestop(handle)
21131 END SUBROUTINE mp_gather_r
21132
21133! **************************************************************************************************
21134!> \brief Gathers a datum from all processes to one, uses the source process of comm
21135!> \param[in] msg Datum to send to root
21136!> \param[out] msg_gather Received data (on root)
21137!> \param[in] comm Message passing environment identifier
21138!> \par MPI mapping
21139!> mpi_gather
21140! **************************************************************************************************
21141 SUBROUTINE mp_gather_r_src(msg, msg_gather, comm)
21142 REAL(kind=real_4), INTENT(IN) :: msg
21143 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21144 CLASS(mp_comm_type), INTENT(IN) :: comm
21145
21146 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_r_src'
21147
21148 INTEGER :: handle
21149#if defined(__parallel)
21150 INTEGER :: ierr, msglen
21151#endif
21152
21153 CALL mp_timeset(routinen, handle)
21154
21155#if defined(__parallel)
21156 msglen = 1
21157 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21158 msglen, mpi_real, comm%source, comm%handle, ierr)
21159 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21160 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21161#else
21162 mark_used(comm)
21163 msg_gather(1) = msg
21164#endif
21165 CALL mp_timestop(handle)
21166 END SUBROUTINE mp_gather_r_src
21167
21168! **************************************************************************************************
21169!> \brief Gathers data from all processes to one
21170!> \param[in] msg Datum to send to root
21171!> \param msg_gather ...
21172!> \param root ...
21173!> \param comm ...
21174!> \par Data length
21175!> All data (msg) is equal-sized
21176!> \par MPI mapping
21177!> mpi_gather
21178!> \note see mp_gather_r
21179! **************************************************************************************************
21180 SUBROUTINE mp_gather_rv(msg, msg_gather, root, comm)
21181 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
21182 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21183 INTEGER, INTENT(IN) :: root
21184 CLASS(mp_comm_type), INTENT(IN) :: comm
21185
21186 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rv'
21187
21188 INTEGER :: handle
21189#if defined(__parallel)
21190 INTEGER :: ierr, msglen
21191#endif
21192
21193 CALL mp_timeset(routinen, handle)
21194
21195#if defined(__parallel)
21196 msglen = SIZE(msg)
21197 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21198 msglen, mpi_real, root, comm%handle, ierr)
21199 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21200 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21201#else
21202 mark_used(root)
21203 mark_used(comm)
21204 msg_gather = msg
21205#endif
21206 CALL mp_timestop(handle)
21207 END SUBROUTINE mp_gather_rv
21208
21209! **************************************************************************************************
21210!> \brief Gathers data from all processes to one. Gathers from comm%source
21211!> \param[in] msg Datum to send to root
21212!> \param msg_gather ...
21213!> \param comm ...
21214!> \par Data length
21215!> All data (msg) is equal-sized
21216!> \par MPI mapping
21217!> mpi_gather
21218!> \note see mp_gather_r
21219! **************************************************************************************************
21220 SUBROUTINE mp_gather_rv_src(msg, msg_gather, comm)
21221 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
21222 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21223 CLASS(mp_comm_type), INTENT(IN) :: comm
21224
21225 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rv_src'
21226
21227 INTEGER :: handle
21228#if defined(__parallel)
21229 INTEGER :: ierr, msglen
21230#endif
21231
21232 CALL mp_timeset(routinen, handle)
21233
21234#if defined(__parallel)
21235 msglen = SIZE(msg)
21236 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21237 msglen, mpi_real, comm%source, comm%handle, ierr)
21238 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21239 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21240#else
21241 mark_used(comm)
21242 msg_gather = msg
21243#endif
21244 CALL mp_timestop(handle)
21245 END SUBROUTINE mp_gather_rv_src
21246
21247! **************************************************************************************************
21248!> \brief Gathers data from all processes to one
21249!> \param[in] msg Datum to send to root
21250!> \param msg_gather ...
21251!> \param root ...
21252!> \param comm ...
21253!> \par Data length
21254!> All data (msg) is equal-sized
21255!> \par MPI mapping
21256!> mpi_gather
21257!> \note see mp_gather_r
21258! **************************************************************************************************
21259 SUBROUTINE mp_gather_rm(msg, msg_gather, root, comm)
21260 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
21261 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
21262 INTEGER, INTENT(IN) :: root
21263 CLASS(mp_comm_type), INTENT(IN) :: comm
21264
21265 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rm'
21266
21267 INTEGER :: handle
21268#if defined(__parallel)
21269 INTEGER :: ierr, msglen
21270#endif
21271
21272 CALL mp_timeset(routinen, handle)
21273
21274#if defined(__parallel)
21275 msglen = SIZE(msg)
21276 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21277 msglen, mpi_real, root, comm%handle, ierr)
21278 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21279 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21280#else
21281 mark_used(root)
21282 mark_used(comm)
21283 msg_gather = msg
21284#endif
21285 CALL mp_timestop(handle)
21286 END SUBROUTINE mp_gather_rm
21287
21288! **************************************************************************************************
21289!> \brief Gathers data from all processes to one. Gathers from comm%source
21290!> \param[in] msg Datum to send to root
21291!> \param msg_gather ...
21292!> \param comm ...
21293!> \par Data length
21294!> All data (msg) is equal-sized
21295!> \par MPI mapping
21296!> mpi_gather
21297!> \note see mp_gather_r
21298! **************************************************************************************************
21299 SUBROUTINE mp_gather_rm_src(msg, msg_gather, comm)
21300 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
21301 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
21302 CLASS(mp_comm_type), INTENT(IN) :: comm
21303
21304 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rm_src'
21305
21306 INTEGER :: handle
21307#if defined(__parallel)
21308 INTEGER :: ierr, msglen
21309#endif
21310
21311 CALL mp_timeset(routinen, handle)
21312
21313#if defined(__parallel)
21314 msglen = SIZE(msg)
21315 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21316 msglen, mpi_real, comm%source, comm%handle, ierr)
21317 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21318 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21319#else
21320 mark_used(comm)
21321 msg_gather = msg
21322#endif
21323 CALL mp_timestop(handle)
21324 END SUBROUTINE mp_gather_rm_src
21325
21326! **************************************************************************************************
21327!> \brief Gathers data from all processes to one.
21328!> \param[in] sendbuf Data to send to root
21329!> \param[out] recvbuf Received data (on root)
21330!> \param[in] recvcounts Sizes of data received from processes
21331!> \param[in] displs Offsets of data received from processes
21332!> \param[in] root Process which gathers the data
21333!> \param[in] comm Message passing environment identifier
21334!> \par Data length
21335!> Data can have different lengths
21336!> \par Offsets
21337!> Offsets start at 0
21338!> \par MPI mapping
21339!> mpi_gather
21340! **************************************************************************************************
21341 SUBROUTINE mp_gatherv_rv(sendbuf, recvbuf, recvcounts, displs, root, comm)
21342
21343 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
21344 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
21345 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21346 INTEGER, INTENT(IN) :: root
21347 CLASS(mp_comm_type), INTENT(IN) :: comm
21348
21349 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rv'
21350
21351 INTEGER :: handle
21352#if defined(__parallel)
21353 INTEGER :: ierr, sendcount
21354#endif
21355
21356 CALL mp_timeset(routinen, handle)
21357
21358#if defined(__parallel)
21359 sendcount = SIZE(sendbuf)
21360 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21361 recvbuf, recvcounts, displs, mpi_real, &
21362 root, comm%handle, ierr)
21363 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21364 CALL add_perf(perf_id=4, &
21365 count=1, &
21366 msg_size=sendcount*real_4_size)
21367#else
21368 mark_used(recvcounts)
21369 mark_used(root)
21370 mark_used(comm)
21371 recvbuf(1 + displs(1):) = sendbuf
21372#endif
21373 CALL mp_timestop(handle)
21374 END SUBROUTINE mp_gatherv_rv
21375
21376! **************************************************************************************************
21377!> \brief Gathers data from all processes to one. Gathers from comm%source
21378!> \param[in] sendbuf Data to send to root
21379!> \param[out] recvbuf Received data (on root)
21380!> \param[in] recvcounts Sizes of data received from processes
21381!> \param[in] displs Offsets of data received from processes
21382!> \param[in] comm Message passing environment identifier
21383!> \par Data length
21384!> Data can have different lengths
21385!> \par Offsets
21386!> Offsets start at 0
21387!> \par MPI mapping
21388!> mpi_gather
21389! **************************************************************************************************
21390 SUBROUTINE mp_gatherv_rv_src(sendbuf, recvbuf, recvcounts, displs, comm)
21391
21392 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
21393 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
21394 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21395 CLASS(mp_comm_type), INTENT(IN) :: comm
21396
21397 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rv_src'
21398
21399 INTEGER :: handle
21400#if defined(__parallel)
21401 INTEGER :: ierr, sendcount
21402#endif
21403
21404 CALL mp_timeset(routinen, handle)
21405
21406#if defined(__parallel)
21407 sendcount = SIZE(sendbuf)
21408 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21409 recvbuf, recvcounts, displs, mpi_real, &
21410 comm%source, comm%handle, ierr)
21411 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21412 CALL add_perf(perf_id=4, &
21413 count=1, &
21414 msg_size=sendcount*real_4_size)
21415#else
21416 mark_used(recvcounts)
21417 mark_used(comm)
21418 recvbuf(1 + displs(1):) = sendbuf
21419#endif
21420 CALL mp_timestop(handle)
21421 END SUBROUTINE mp_gatherv_rv_src
21422
21423! **************************************************************************************************
21424!> \brief Gathers data from all processes to one.
21425!> \param[in] sendbuf Data to send to root
21426!> \param[out] recvbuf Received data (on root)
21427!> \param[in] recvcounts Sizes of data received from processes
21428!> \param[in] displs Offsets of data received from processes
21429!> \param[in] root Process which gathers the data
21430!> \param[in] comm Message passing environment identifier
21431!> \par Data length
21432!> Data can have different lengths
21433!> \par Offsets
21434!> Offsets start at 0
21435!> \par MPI mapping
21436!> mpi_gather
21437! **************************************************************************************************
21438 SUBROUTINE mp_gatherv_rm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
21439
21440 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
21441 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
21442 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21443 INTEGER, INTENT(IN) :: root
21444 CLASS(mp_comm_type), INTENT(IN) :: comm
21445
21446 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rm2'
21447
21448 INTEGER :: handle
21449#if defined(__parallel)
21450 INTEGER :: ierr, sendcount
21451#endif
21452
21453 CALL mp_timeset(routinen, handle)
21454
21455#if defined(__parallel)
21456 sendcount = SIZE(sendbuf)
21457 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21458 recvbuf, recvcounts, displs, mpi_real, &
21459 root, comm%handle, ierr)
21460 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21461 CALL add_perf(perf_id=4, &
21462 count=1, &
21463 msg_size=sendcount*real_4_size)
21464#else
21465 mark_used(recvcounts)
21466 mark_used(root)
21467 mark_used(comm)
21468 recvbuf(:, 1 + displs(1):) = sendbuf
21469#endif
21470 CALL mp_timestop(handle)
21471 END SUBROUTINE mp_gatherv_rm2
21472
21473! **************************************************************************************************
21474!> \brief Gathers data from all processes to one.
21475!> \param[in] sendbuf Data to send to root
21476!> \param[out] recvbuf Received data (on root)
21477!> \param[in] recvcounts Sizes of data received from processes
21478!> \param[in] displs Offsets of data received from processes
21479!> \param[in] comm Message passing environment identifier
21480!> \par Data length
21481!> Data can have different lengths
21482!> \par Offsets
21483!> Offsets start at 0
21484!> \par MPI mapping
21485!> mpi_gather
21486! **************************************************************************************************
21487 SUBROUTINE mp_gatherv_rm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
21488
21489 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
21490 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
21491 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21492 CLASS(mp_comm_type), INTENT(IN) :: comm
21493
21494 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rm2_src'
21495
21496 INTEGER :: handle
21497#if defined(__parallel)
21498 INTEGER :: ierr, sendcount
21499#endif
21500
21501 CALL mp_timeset(routinen, handle)
21502
21503#if defined(__parallel)
21504 sendcount = SIZE(sendbuf)
21505 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21506 recvbuf, recvcounts, displs, mpi_real, &
21507 comm%source, comm%handle, ierr)
21508 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21509 CALL add_perf(perf_id=4, &
21510 count=1, &
21511 msg_size=sendcount*real_4_size)
21512#else
21513 mark_used(recvcounts)
21514 mark_used(comm)
21515 recvbuf(:, 1 + displs(1):) = sendbuf
21516#endif
21517 CALL mp_timestop(handle)
21518 END SUBROUTINE mp_gatherv_rm2_src
21519
21520! **************************************************************************************************
21521!> \brief Gathers data from all processes to one.
21522!> \param[in] sendbuf Data to send to root
21523!> \param[out] recvbuf Received data (on root)
21524!> \param[in] recvcounts Sizes of data received from processes
21525!> \param[in] displs Offsets of data received from processes
21526!> \param[in] root Process which gathers the data
21527!> \param[in] comm Message passing environment identifier
21528!> \par Data length
21529!> Data can have different lengths
21530!> \par Offsets
21531!> Offsets start at 0
21532!> \par MPI mapping
21533!> mpi_gather
21534! **************************************************************************************************
21535 SUBROUTINE mp_igatherv_rv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
21536 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: sendbuf
21537 REAL(kind=real_4), DIMENSION(:), INTENT(OUT) :: recvbuf
21538 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21539 INTEGER, INTENT(IN) :: sendcount, root
21540 CLASS(mp_comm_type), INTENT(IN) :: comm
21541 TYPE(mp_request_type), INTENT(OUT) :: request
21542
21543 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_rv'
21544
21545 INTEGER :: handle
21546#if defined(__parallel)
21547 INTEGER :: ierr
21548#endif
21549
21550 CALL mp_timeset(routinen, handle)
21551
21552#if defined(__parallel)
21553#if !defined(__GNUC__) || __GNUC__ >= 9
21554 cpassert(is_contiguous(sendbuf))
21555 cpassert(is_contiguous(recvbuf))
21556 cpassert(is_contiguous(recvcounts))
21557 cpassert(is_contiguous(displs))
21558#endif
21559 CALL mpi_igatherv(sendbuf, sendcount, mpi_real, &
21560 recvbuf, recvcounts, displs, mpi_real, &
21561 root, comm%handle, request%handle, ierr)
21562 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21563 CALL add_perf(perf_id=24, &
21564 count=1, &
21565 msg_size=sendcount*real_4_size)
21566#else
21567 mark_used(sendcount)
21568 mark_used(recvcounts)
21569 mark_used(root)
21570 mark_used(comm)
21571 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
21572 request = mp_request_null
21573#endif
21574 CALL mp_timestop(handle)
21575 END SUBROUTINE mp_igatherv_rv
21576
21577! **************************************************************************************************
21578!> \brief Gathers a datum from all processes and all processes receive the
21579!> same data
21580!> \param[in] msgout Datum to send
21581!> \param[out] msgin Received data
21582!> \param[in] comm Message passing environment identifier
21583!> \par Data size
21584!> All processes send equal-sized data
21585!> \par MPI mapping
21586!> mpi_allgather
21587! **************************************************************************************************
21588 SUBROUTINE mp_allgather_r (msgout, msgin, comm)
21589 REAL(kind=real_4), INTENT(IN) :: msgout
21590 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
21591 CLASS(mp_comm_type), INTENT(IN) :: comm
21592
21593 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r'
21594
21595 INTEGER :: handle
21596#if defined(__parallel)
21597 INTEGER :: ierr, rcount, scount
21598#endif
21599
21600 CALL mp_timeset(routinen, handle)
21601
21602#if defined(__parallel)
21603 scount = 1
21604 rcount = 1
21605 CALL mpi_allgather(msgout, scount, mpi_real, &
21606 msgin, rcount, mpi_real, &
21607 comm%handle, ierr)
21608 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21609#else
21610 mark_used(comm)
21611 msgin = msgout
21612#endif
21613 CALL mp_timestop(handle)
21614 END SUBROUTINE mp_allgather_r
21615
21616! **************************************************************************************************
21617!> \brief Gathers a datum from all processes and all processes receive the
21618!> same data
21619!> \param[in] msgout Datum to send
21620!> \param[out] msgin Received data
21621!> \param[in] comm Message passing environment identifier
21622!> \par Data size
21623!> All processes send equal-sized data
21624!> \par MPI mapping
21625!> mpi_allgather
21626! **************************************************************************************************
21627 SUBROUTINE mp_allgather_r2(msgout, msgin, comm)
21628 REAL(kind=real_4), INTENT(IN) :: msgout
21629 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
21630 CLASS(mp_comm_type), INTENT(IN) :: comm
21631
21632 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r2'
21633
21634 INTEGER :: handle
21635#if defined(__parallel)
21636 INTEGER :: ierr, rcount, scount
21637#endif
21638
21639 CALL mp_timeset(routinen, handle)
21640
21641#if defined(__parallel)
21642 scount = 1
21643 rcount = 1
21644 CALL mpi_allgather(msgout, scount, mpi_real, &
21645 msgin, rcount, mpi_real, &
21646 comm%handle, ierr)
21647 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21648#else
21649 mark_used(comm)
21650 msgin = msgout
21651#endif
21652 CALL mp_timestop(handle)
21653 END SUBROUTINE mp_allgather_r2
21654
21655! **************************************************************************************************
21656!> \brief Gathers a datum from all processes and all processes receive the
21657!> same data
21658!> \param[in] msgout Datum to send
21659!> \param[out] msgin Received data
21660!> \param[in] comm Message passing environment identifier
21661!> \par Data size
21662!> All processes send equal-sized data
21663!> \par MPI mapping
21664!> mpi_allgather
21665! **************************************************************************************************
21666 SUBROUTINE mp_iallgather_r (msgout, msgin, comm, request)
21667 REAL(kind=real_4), INTENT(IN) :: msgout
21668 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
21669 CLASS(mp_comm_type), INTENT(IN) :: comm
21670 TYPE(mp_request_type), INTENT(OUT) :: request
21671
21672 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r'
21673
21674 INTEGER :: handle
21675#if defined(__parallel)
21676 INTEGER :: ierr, rcount, scount
21677#endif
21678
21679 CALL mp_timeset(routinen, handle)
21680
21681#if defined(__parallel)
21682#if !defined(__GNUC__) || __GNUC__ >= 9
21683 cpassert(is_contiguous(msgin))
21684#endif
21685 scount = 1
21686 rcount = 1
21687 CALL mpi_iallgather(msgout, scount, mpi_real, &
21688 msgin, rcount, mpi_real, &
21689 comm%handle, request%handle, ierr)
21690 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21691#else
21692 mark_used(comm)
21693 msgin = msgout
21694 request = mp_request_null
21695#endif
21696 CALL mp_timestop(handle)
21697 END SUBROUTINE mp_iallgather_r
21698
21699! **************************************************************************************************
21700!> \brief Gathers vector data from all processes and all processes receive the
21701!> same data
21702!> \param[in] msgout Rank-1 data to send
21703!> \param[out] msgin Received data
21704!> \param[in] comm Message passing environment identifier
21705!> \par Data size
21706!> All processes send equal-sized data
21707!> \par Ranks
21708!> The last rank counts the processes
21709!> \par MPI mapping
21710!> mpi_allgather
21711! **************************************************************************************************
21712 SUBROUTINE mp_allgather_r12(msgout, msgin, comm)
21713 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:)
21714 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
21715 CLASS(mp_comm_type), INTENT(IN) :: comm
21716
21717 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r12'
21718
21719 INTEGER :: handle
21720#if defined(__parallel)
21721 INTEGER :: ierr, rcount, scount
21722#endif
21723
21724 CALL mp_timeset(routinen, handle)
21725
21726#if defined(__parallel)
21727 scount = SIZE(msgout(:))
21728 rcount = scount
21729 CALL mpi_allgather(msgout, scount, mpi_real, &
21730 msgin, rcount, mpi_real, &
21731 comm%handle, ierr)
21732 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21733#else
21734 mark_used(comm)
21735 msgin(:, 1) = msgout(:)
21736#endif
21737 CALL mp_timestop(handle)
21738 END SUBROUTINE mp_allgather_r12
21739
21740! **************************************************************************************************
21741!> \brief Gathers matrix data from all processes and all processes receive the
21742!> same data
21743!> \param[in] msgout Rank-2 data to send
21744!> \param msgin ...
21745!> \param comm ...
21746!> \note see mp_allgather_r12
21747! **************************************************************************************************
21748 SUBROUTINE mp_allgather_r23(msgout, msgin, comm)
21749 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
21750 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
21751 CLASS(mp_comm_type), INTENT(IN) :: comm
21752
21753 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r23'
21754
21755 INTEGER :: handle
21756#if defined(__parallel)
21757 INTEGER :: ierr, rcount, scount
21758#endif
21759
21760 CALL mp_timeset(routinen, handle)
21761
21762#if defined(__parallel)
21763 scount = SIZE(msgout(:, :))
21764 rcount = scount
21765 CALL mpi_allgather(msgout, scount, mpi_real, &
21766 msgin, rcount, mpi_real, &
21767 comm%handle, ierr)
21768 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21769#else
21770 mark_used(comm)
21771 msgin(:, :, 1) = msgout(:, :)
21772#endif
21773 CALL mp_timestop(handle)
21774 END SUBROUTINE mp_allgather_r23
21775
21776! **************************************************************************************************
21777!> \brief Gathers rank-3 data from all processes and all processes receive the
21778!> same data
21779!> \param[in] msgout Rank-3 data to send
21780!> \param msgin ...
21781!> \param comm ...
21782!> \note see mp_allgather_r12
21783! **************************************************************************************************
21784 SUBROUTINE mp_allgather_r34(msgout, msgin, comm)
21785 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
21786 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
21787 CLASS(mp_comm_type), INTENT(IN) :: comm
21788
21789 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r34'
21790
21791 INTEGER :: handle
21792#if defined(__parallel)
21793 INTEGER :: ierr, rcount, scount
21794#endif
21795
21796 CALL mp_timeset(routinen, handle)
21797
21798#if defined(__parallel)
21799 scount = SIZE(msgout(:, :, :))
21800 rcount = scount
21801 CALL mpi_allgather(msgout, scount, mpi_real, &
21802 msgin, rcount, mpi_real, &
21803 comm%handle, ierr)
21804 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21805#else
21806 mark_used(comm)
21807 msgin(:, :, :, 1) = msgout(:, :, :)
21808#endif
21809 CALL mp_timestop(handle)
21810 END SUBROUTINE mp_allgather_r34
21811
21812! **************************************************************************************************
21813!> \brief Gathers rank-2 data from all processes and all processes receive the
21814!> same data
21815!> \param[in] msgout Rank-2 data to send
21816!> \param msgin ...
21817!> \param comm ...
21818!> \note see mp_allgather_r12
21819! **************************************************************************************************
21820 SUBROUTINE mp_allgather_r22(msgout, msgin, comm)
21821 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
21822 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
21823 CLASS(mp_comm_type), INTENT(IN) :: comm
21824
21825 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r22'
21826
21827 INTEGER :: handle
21828#if defined(__parallel)
21829 INTEGER :: ierr, rcount, scount
21830#endif
21831
21832 CALL mp_timeset(routinen, handle)
21833
21834#if defined(__parallel)
21835 scount = SIZE(msgout(:, :))
21836 rcount = scount
21837 CALL mpi_allgather(msgout, scount, mpi_real, &
21838 msgin, rcount, mpi_real, &
21839 comm%handle, ierr)
21840 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21841#else
21842 mark_used(comm)
21843 msgin(:, :) = msgout(:, :)
21844#endif
21845 CALL mp_timestop(handle)
21846 END SUBROUTINE mp_allgather_r22
21847
21848! **************************************************************************************************
21849!> \brief Gathers rank-1 data from all processes and all processes receive the
21850!> same data
21851!> \param[in] msgout Rank-1 data to send
21852!> \param msgin ...
21853!> \param comm ...
21854!> \param request ...
21855!> \note see mp_allgather_r11
21856! **************************************************************************************************
21857 SUBROUTINE mp_iallgather_r11(msgout, msgin, comm, request)
21858 REAL(kind=real_4), INTENT(IN) :: msgout(:)
21859 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
21860 CLASS(mp_comm_type), INTENT(IN) :: comm
21861 TYPE(mp_request_type), INTENT(OUT) :: request
21862
21863 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r11'
21864
21865 INTEGER :: handle
21866#if defined(__parallel)
21867 INTEGER :: ierr, rcount, scount
21868#endif
21869
21870 CALL mp_timeset(routinen, handle)
21871
21872#if defined(__parallel)
21873#if !defined(__GNUC__) || __GNUC__ >= 9
21874 cpassert(is_contiguous(msgout))
21875 cpassert(is_contiguous(msgin))
21876#endif
21877 scount = SIZE(msgout(:))
21878 rcount = scount
21879 CALL mpi_iallgather(msgout, scount, mpi_real, &
21880 msgin, rcount, mpi_real, &
21881 comm%handle, request%handle, ierr)
21882 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21883#else
21884 mark_used(comm)
21885 msgin = msgout
21886 request = mp_request_null
21887#endif
21888 CALL mp_timestop(handle)
21889 END SUBROUTINE mp_iallgather_r11
21890
21891! **************************************************************************************************
21892!> \brief Gathers rank-2 data from all processes and all processes receive the
21893!> same data
21894!> \param[in] msgout Rank-2 data to send
21895!> \param msgin ...
21896!> \param comm ...
21897!> \param request ...
21898!> \note see mp_allgather_r12
21899! **************************************************************************************************
21900 SUBROUTINE mp_iallgather_r13(msgout, msgin, comm, request)
21901 REAL(kind=real_4), INTENT(IN) :: msgout(:)
21902 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
21903 CLASS(mp_comm_type), INTENT(IN) :: comm
21904 TYPE(mp_request_type), INTENT(OUT) :: request
21905
21906 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r13'
21907
21908 INTEGER :: handle
21909#if defined(__parallel)
21910 INTEGER :: ierr, rcount, scount
21911#endif
21912
21913 CALL mp_timeset(routinen, handle)
21914
21915#if defined(__parallel)
21916#if !defined(__GNUC__) || __GNUC__ >= 9
21917 cpassert(is_contiguous(msgout))
21918 cpassert(is_contiguous(msgin))
21919#endif
21920
21921 scount = SIZE(msgout(:))
21922 rcount = scount
21923 CALL mpi_iallgather(msgout, scount, mpi_real, &
21924 msgin, rcount, mpi_real, &
21925 comm%handle, request%handle, ierr)
21926 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21927#else
21928 mark_used(comm)
21929 msgin(:, 1, 1) = msgout(:)
21930 request = mp_request_null
21931#endif
21932 CALL mp_timestop(handle)
21933 END SUBROUTINE mp_iallgather_r13
21934
21935! **************************************************************************************************
21936!> \brief Gathers rank-2 data from all processes and all processes receive the
21937!> same data
21938!> \param[in] msgout Rank-2 data to send
21939!> \param msgin ...
21940!> \param comm ...
21941!> \param request ...
21942!> \note see mp_allgather_r12
21943! **************************************************************************************************
21944 SUBROUTINE mp_iallgather_r22(msgout, msgin, comm, request)
21945 REAL(kind=real_4), INTENT(IN) :: msgout(:, :)
21946 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :)
21947 CLASS(mp_comm_type), INTENT(IN) :: comm
21948 TYPE(mp_request_type), INTENT(OUT) :: request
21949
21950 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r22'
21951
21952 INTEGER :: handle
21953#if defined(__parallel)
21954 INTEGER :: ierr, rcount, scount
21955#endif
21956
21957 CALL mp_timeset(routinen, handle)
21958
21959#if defined(__parallel)
21960#if !defined(__GNUC__) || __GNUC__ >= 9
21961 cpassert(is_contiguous(msgout))
21962 cpassert(is_contiguous(msgin))
21963#endif
21964
21965 scount = SIZE(msgout(:, :))
21966 rcount = scount
21967 CALL mpi_iallgather(msgout, scount, mpi_real, &
21968 msgin, rcount, mpi_real, &
21969 comm%handle, request%handle, ierr)
21970 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21971#else
21972 mark_used(comm)
21973 msgin(:, :) = msgout(:, :)
21974 request = mp_request_null
21975#endif
21976 CALL mp_timestop(handle)
21977 END SUBROUTINE mp_iallgather_r22
21978
21979! **************************************************************************************************
21980!> \brief Gathers rank-2 data from all processes and all processes receive the
21981!> same data
21982!> \param[in] msgout Rank-2 data to send
21983!> \param msgin ...
21984!> \param comm ...
21985!> \param request ...
21986!> \note see mp_allgather_r12
21987! **************************************************************************************************
21988 SUBROUTINE mp_iallgather_r24(msgout, msgin, comm, request)
21989 REAL(kind=real_4), INTENT(IN) :: msgout(:, :)
21990 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :, :)
21991 CLASS(mp_comm_type), INTENT(IN) :: comm
21992 TYPE(mp_request_type), INTENT(OUT) :: request
21993
21994 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r24'
21995
21996 INTEGER :: handle
21997#if defined(__parallel)
21998 INTEGER :: ierr, rcount, scount
21999#endif
22000
22001 CALL mp_timeset(routinen, handle)
22002
22003#if defined(__parallel)
22004#if !defined(__GNUC__) || __GNUC__ >= 9
22005 cpassert(is_contiguous(msgout))
22006 cpassert(is_contiguous(msgin))
22007#endif
22008
22009 scount = SIZE(msgout(:, :))
22010 rcount = scount
22011 CALL mpi_iallgather(msgout, scount, mpi_real, &
22012 msgin, rcount, mpi_real, &
22013 comm%handle, request%handle, ierr)
22014 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22015#else
22016 mark_used(comm)
22017 msgin(:, :, 1, 1) = msgout(:, :)
22018 request = mp_request_null
22019#endif
22020 CALL mp_timestop(handle)
22021 END SUBROUTINE mp_iallgather_r24
22022
22023! **************************************************************************************************
22024!> \brief Gathers rank-3 data from all processes and all processes receive the
22025!> same data
22026!> \param[in] msgout Rank-3 data to send
22027!> \param msgin ...
22028!> \param comm ...
22029!> \param request ...
22030!> \note see mp_allgather_r12
22031! **************************************************************************************************
22032 SUBROUTINE mp_iallgather_r33(msgout, msgin, comm, request)
22033 REAL(kind=real_4), INTENT(IN) :: msgout(:, :, :)
22034 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
22035 CLASS(mp_comm_type), INTENT(IN) :: comm
22036 TYPE(mp_request_type), INTENT(OUT) :: request
22037
22038 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r33'
22039
22040 INTEGER :: handle
22041#if defined(__parallel)
22042 INTEGER :: ierr, rcount, scount
22043#endif
22044
22045 CALL mp_timeset(routinen, handle)
22046
22047#if defined(__parallel)
22048#if !defined(__GNUC__) || __GNUC__ >= 9
22049 cpassert(is_contiguous(msgout))
22050 cpassert(is_contiguous(msgin))
22051#endif
22052
22053 scount = SIZE(msgout(:, :, :))
22054 rcount = scount
22055 CALL mpi_iallgather(msgout, scount, mpi_real, &
22056 msgin, rcount, mpi_real, &
22057 comm%handle, request%handle, ierr)
22058 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22059#else
22060 mark_used(comm)
22061 msgin(:, :, :) = msgout(:, :, :)
22062 request = mp_request_null
22063#endif
22064 CALL mp_timestop(handle)
22065 END SUBROUTINE mp_iallgather_r33
22066
22067! **************************************************************************************************
22068!> \brief Gathers vector data from all processes and all processes receive the
22069!> same data
22070!> \param[in] msgout Rank-1 data to send
22071!> \param[out] msgin Received data
22072!> \param[in] rcount Size of sent data for every process
22073!> \param[in] rdispl Offset of sent data for every process
22074!> \param[in] comm Message passing environment identifier
22075!> \par Data size
22076!> Processes can send different-sized data
22077!> \par Ranks
22078!> The last rank counts the processes
22079!> \par Offsets
22080!> Offsets are from 0
22081!> \par MPI mapping
22082!> mpi_allgather
22083! **************************************************************************************************
22084 SUBROUTINE mp_allgatherv_rv(msgout, msgin, rcount, rdispl, comm)
22085 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
22086 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22087 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22088 CLASS(mp_comm_type), INTENT(IN) :: comm
22089
22090 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_rv'
22091
22092 INTEGER :: handle
22093#if defined(__parallel)
22094 INTEGER :: ierr, scount
22095#endif
22096
22097 CALL mp_timeset(routinen, handle)
22098
22099#if defined(__parallel)
22100 scount = SIZE(msgout)
22101 CALL mpi_allgatherv(msgout, scount, mpi_real, msgin, rcount, &
22102 rdispl, mpi_real, comm%handle, ierr)
22103 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
22104#else
22105 mark_used(rcount)
22106 mark_used(rdispl)
22107 mark_used(comm)
22108 msgin = msgout
22109#endif
22110 CALL mp_timestop(handle)
22111 END SUBROUTINE mp_allgatherv_rv
22112
22113! **************************************************************************************************
22114!> \brief Gathers vector data from all processes and all processes receive the
22115!> same data
22116!> \param[in] msgout Rank-1 data to send
22117!> \param[out] msgin Received data
22118!> \param[in] rcount Size of sent data for every process
22119!> \param[in] rdispl Offset of sent data for every process
22120!> \param[in] comm Message passing environment identifier
22121!> \par Data size
22122!> Processes can send different-sized data
22123!> \par Ranks
22124!> The last rank counts the processes
22125!> \par Offsets
22126!> Offsets are from 0
22127!> \par MPI mapping
22128!> mpi_allgather
22129! **************************************************************************************************
22130 SUBROUTINE mp_allgatherv_rm2(msgout, msgin, rcount, rdispl, comm)
22131 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
22132 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
22133 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22134 CLASS(mp_comm_type), INTENT(IN) :: comm
22135
22136 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_rv'
22137
22138 INTEGER :: handle
22139#if defined(__parallel)
22140 INTEGER :: ierr, scount
22141#endif
22142
22143 CALL mp_timeset(routinen, handle)
22144
22145#if defined(__parallel)
22146 scount = SIZE(msgout)
22147 CALL mpi_allgatherv(msgout, scount, mpi_real, msgin, rcount, &
22148 rdispl, mpi_real, comm%handle, ierr)
22149 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
22150#else
22151 mark_used(rcount)
22152 mark_used(rdispl)
22153 mark_used(comm)
22154 msgin = msgout
22155#endif
22156 CALL mp_timestop(handle)
22157 END SUBROUTINE mp_allgatherv_rm2
22158
22159! **************************************************************************************************
22160!> \brief Gathers vector data from all processes and all processes receive the
22161!> same data
22162!> \param[in] msgout Rank-1 data to send
22163!> \param[out] msgin Received data
22164!> \param[in] rcount Size of sent data for every process
22165!> \param[in] rdispl Offset of sent data for every process
22166!> \param[in] comm Message passing environment identifier
22167!> \par Data size
22168!> Processes can send different-sized data
22169!> \par Ranks
22170!> The last rank counts the processes
22171!> \par Offsets
22172!> Offsets are from 0
22173!> \par MPI mapping
22174!> mpi_allgather
22175! **************************************************************************************************
22176 SUBROUTINE mp_iallgatherv_rv(msgout, msgin, rcount, rdispl, comm, request)
22177 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22178 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22179 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22180 CLASS(mp_comm_type), INTENT(IN) :: comm
22181 TYPE(mp_request_type), INTENT(OUT) :: request
22182
22183 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_rv'
22184
22185 INTEGER :: handle
22186#if defined(__parallel)
22187 INTEGER :: ierr, scount, rsize
22188#endif
22189
22190 CALL mp_timeset(routinen, handle)
22191
22192#if defined(__parallel)
22193#if !defined(__GNUC__) || __GNUC__ >= 9
22194 cpassert(is_contiguous(msgout))
22195 cpassert(is_contiguous(msgin))
22196 cpassert(is_contiguous(rcount))
22197 cpassert(is_contiguous(rdispl))
22198#endif
22199
22200 scount = SIZE(msgout)
22201 rsize = SIZE(rcount)
22202 CALL mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, &
22203 rdispl, comm, request, ierr)
22204 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
22205#else
22206 mark_used(rcount)
22207 mark_used(rdispl)
22208 mark_used(comm)
22209 msgin = msgout
22210 request = mp_request_null
22211#endif
22212 CALL mp_timestop(handle)
22213 END SUBROUTINE mp_iallgatherv_rv
22214
22215! **************************************************************************************************
22216!> \brief Gathers vector data from all processes and all processes receive the
22217!> same data
22218!> \param[in] msgout Rank-1 data to send
22219!> \param[out] msgin Received data
22220!> \param[in] rcount Size of sent data for every process
22221!> \param[in] rdispl Offset of sent data for every process
22222!> \param[in] comm Message passing environment identifier
22223!> \par Data size
22224!> Processes can send different-sized data
22225!> \par Ranks
22226!> The last rank counts the processes
22227!> \par Offsets
22228!> Offsets are from 0
22229!> \par MPI mapping
22230!> mpi_allgather
22231! **************************************************************************************************
22232 SUBROUTINE mp_iallgatherv_rv2(msgout, msgin, rcount, rdispl, comm, request)
22233 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22234 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22235 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
22236 CLASS(mp_comm_type), INTENT(IN) :: comm
22237 TYPE(mp_request_type), INTENT(OUT) :: request
22238
22239 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_rv2'
22240
22241 INTEGER :: handle
22242#if defined(__parallel)
22243 INTEGER :: ierr, scount, rsize
22244#endif
22245
22246 CALL mp_timeset(routinen, handle)
22247
22248#if defined(__parallel)
22249#if !defined(__GNUC__) || __GNUC__ >= 9
22250 cpassert(is_contiguous(msgout))
22251 cpassert(is_contiguous(msgin))
22252 cpassert(is_contiguous(rcount))
22253 cpassert(is_contiguous(rdispl))
22254#endif
22255
22256 scount = SIZE(msgout)
22257 rsize = SIZE(rcount)
22258 CALL mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, &
22259 rdispl, comm, request, ierr)
22260 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
22261#else
22262 mark_used(rcount)
22263 mark_used(rdispl)
22264 mark_used(comm)
22265 msgin = msgout
22266 request = mp_request_null
22267#endif
22268 CALL mp_timestop(handle)
22269 END SUBROUTINE mp_iallgatherv_rv2
22270
22271! **************************************************************************************************
22272!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
22273!> the issue is with the rank of rcount and rdispl
22274!> \param count ...
22275!> \param array_of_requests ...
22276!> \param array_of_statuses ...
22277!> \param ierr ...
22278!> \author Alfio Lazzaro
22279! **************************************************************************************************
22280#if defined(__parallel)
22281 SUBROUTINE mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
22282 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
22283 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22284 INTEGER, INTENT(IN) :: rsize
22285 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
22286 CLASS(mp_comm_type), INTENT(IN) :: comm
22287 TYPE(mp_request_type), INTENT(OUT) :: request
22288 INTEGER, INTENT(INOUT) :: ierr
22289
22290 CALL mpi_iallgatherv(msgout, scount, mpi_real, msgin, rcount, &
22291 rdispl, mpi_real, comm%handle, request%handle, ierr)
22292
22293 END SUBROUTINE mp_iallgatherv_rv_internal
22294#endif
22295
22296! **************************************************************************************************
22297!> \brief Sums a vector and partitions the result among processes
22298!> \param[in] msgout Data to sum
22299!> \param[out] msgin Received portion of summed data
22300!> \param[in] rcount Partition sizes of the summed data for
22301!> every process
22302!> \param[in] comm Message passing environment identifier
22303! **************************************************************************************************
22304 SUBROUTINE mp_sum_scatter_rv(msgout, msgin, rcount, comm)
22305 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
22306 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22307 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
22308 CLASS(mp_comm_type), INTENT(IN) :: comm
22309
22310 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_rv'
22311
22312 INTEGER :: handle
22313#if defined(__parallel)
22314 INTEGER :: ierr
22315#endif
22316
22317 CALL mp_timeset(routinen, handle)
22318
22319#if defined(__parallel)
22320 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_real, mpi_sum, &
22321 comm%handle, ierr)
22322 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
22323
22324 CALL add_perf(perf_id=3, count=1, &
22325 msg_size=rcount(1)*2*real_4_size)
22326#else
22327 mark_used(rcount)
22328 mark_used(comm)
22329 msgin = msgout(:, 1)
22330#endif
22331 CALL mp_timestop(handle)
22332 END SUBROUTINE mp_sum_scatter_rv
22333
22334! **************************************************************************************************
22335!> \brief Sends and receives vector data
22336!> \param[in] msgin Data to send
22337!> \param[in] dest Process to send data to
22338!> \param[out] msgout Received data
22339!> \param[in] source Process from which to receive
22340!> \param[in] comm Message passing environment identifier
22341!> \param[in] tag Send and recv tag (default: 0)
22342! **************************************************************************************************
22343 SUBROUTINE mp_sendrecv_r (msgin, dest, msgout, source, comm, tag)
22344 REAL(kind=real_4), INTENT(IN) :: msgin
22345 INTEGER, INTENT(IN) :: dest
22346 REAL(kind=real_4), INTENT(OUT) :: msgout
22347 INTEGER, INTENT(IN) :: source
22348 CLASS(mp_comm_type), INTENT(IN) :: comm
22349 INTEGER, INTENT(IN), OPTIONAL :: tag
22350
22351 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_r'
22352
22353 INTEGER :: handle
22354#if defined(__parallel)
22355 INTEGER :: ierr, msglen_in, msglen_out, &
22356 recv_tag, send_tag
22357#endif
22358
22359 CALL mp_timeset(routinen, handle)
22360
22361#if defined(__parallel)
22362 msglen_in = 1
22363 msglen_out = 1
22364 send_tag = 0 ! cannot think of something better here, this might be dangerous
22365 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22366 IF (PRESENT(tag)) THEN
22367 send_tag = tag
22368 recv_tag = tag
22369 END IF
22370 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22371 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22372 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22373 CALL add_perf(perf_id=7, count=1, &
22374 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22375#else
22376 mark_used(dest)
22377 mark_used(source)
22378 mark_used(comm)
22379 mark_used(tag)
22380 msgout = msgin
22381#endif
22382 CALL mp_timestop(handle)
22383 END SUBROUTINE mp_sendrecv_r
22384
22385! **************************************************************************************************
22386!> \brief Sends and receives vector data
22387!> \param[in] msgin Data to send
22388!> \param[in] dest Process to send data to
22389!> \param[out] msgout Received data
22390!> \param[in] source Process from which to receive
22391!> \param[in] comm Message passing environment identifier
22392!> \param[in] tag Send and recv tag (default: 0)
22393! **************************************************************************************************
22394 SUBROUTINE mp_sendrecv_rv(msgin, dest, msgout, source, comm, tag)
22395 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
22396 INTEGER, INTENT(IN) :: dest
22397 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
22398 INTEGER, INTENT(IN) :: source
22399 CLASS(mp_comm_type), INTENT(IN) :: comm
22400 INTEGER, INTENT(IN), OPTIONAL :: tag
22401
22402 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rv'
22403
22404 INTEGER :: handle
22405#if defined(__parallel)
22406 INTEGER :: ierr, msglen_in, msglen_out, &
22407 recv_tag, send_tag
22408#endif
22409
22410 CALL mp_timeset(routinen, handle)
22411
22412#if defined(__parallel)
22413 msglen_in = SIZE(msgin)
22414 msglen_out = SIZE(msgout)
22415 send_tag = 0 ! cannot think of something better here, this might be dangerous
22416 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22417 IF (PRESENT(tag)) THEN
22418 send_tag = tag
22419 recv_tag = tag
22420 END IF
22421 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22422 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22423 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22424 CALL add_perf(perf_id=7, count=1, &
22425 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22426#else
22427 mark_used(dest)
22428 mark_used(source)
22429 mark_used(comm)
22430 mark_used(tag)
22431 msgout = msgin
22432#endif
22433 CALL mp_timestop(handle)
22434 END SUBROUTINE mp_sendrecv_rv
22435
22436! **************************************************************************************************
22437!> \brief Sends and receives matrix data
22438!> \param msgin ...
22439!> \param dest ...
22440!> \param msgout ...
22441!> \param source ...
22442!> \param comm ...
22443!> \param tag ...
22444!> \note see mp_sendrecv_rv
22445! **************************************************************************************************
22446 SUBROUTINE mp_sendrecv_rm2(msgin, dest, msgout, source, comm, tag)
22447 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
22448 INTEGER, INTENT(IN) :: dest
22449 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
22450 INTEGER, INTENT(IN) :: source
22451 CLASS(mp_comm_type), INTENT(IN) :: comm
22452 INTEGER, INTENT(IN), OPTIONAL :: tag
22453
22454 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm2'
22455
22456 INTEGER :: handle
22457#if defined(__parallel)
22458 INTEGER :: ierr, msglen_in, msglen_out, &
22459 recv_tag, send_tag
22460#endif
22461
22462 CALL mp_timeset(routinen, handle)
22463
22464#if defined(__parallel)
22465 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
22466 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
22467 send_tag = 0 ! cannot think of something better here, this might be dangerous
22468 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22469 IF (PRESENT(tag)) THEN
22470 send_tag = tag
22471 recv_tag = tag
22472 END IF
22473 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22474 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22475 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22476 CALL add_perf(perf_id=7, count=1, &
22477 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22478#else
22479 mark_used(dest)
22480 mark_used(source)
22481 mark_used(comm)
22482 mark_used(tag)
22483 msgout = msgin
22484#endif
22485 CALL mp_timestop(handle)
22486 END SUBROUTINE mp_sendrecv_rm2
22487
22488! **************************************************************************************************
22489!> \brief Sends and receives rank-3 data
22490!> \param msgin ...
22491!> \param dest ...
22492!> \param msgout ...
22493!> \param source ...
22494!> \param comm ...
22495!> \note see mp_sendrecv_rv
22496! **************************************************************************************************
22497 SUBROUTINE mp_sendrecv_rm3(msgin, dest, msgout, source, comm, tag)
22498 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
22499 INTEGER, INTENT(IN) :: dest
22500 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
22501 INTEGER, INTENT(IN) :: source
22502 CLASS(mp_comm_type), INTENT(IN) :: comm
22503 INTEGER, INTENT(IN), OPTIONAL :: tag
22504
22505 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm3'
22506
22507 INTEGER :: handle
22508#if defined(__parallel)
22509 INTEGER :: ierr, msglen_in, msglen_out, &
22510 recv_tag, send_tag
22511#endif
22512
22513 CALL mp_timeset(routinen, handle)
22514
22515#if defined(__parallel)
22516 msglen_in = SIZE(msgin)
22517 msglen_out = SIZE(msgout)
22518 send_tag = 0 ! cannot think of something better here, this might be dangerous
22519 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22520 IF (PRESENT(tag)) THEN
22521 send_tag = tag
22522 recv_tag = tag
22523 END IF
22524 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22525 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22526 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22527 CALL add_perf(perf_id=7, count=1, &
22528 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22529#else
22530 mark_used(dest)
22531 mark_used(source)
22532 mark_used(comm)
22533 mark_used(tag)
22534 msgout = msgin
22535#endif
22536 CALL mp_timestop(handle)
22537 END SUBROUTINE mp_sendrecv_rm3
22538
22539! **************************************************************************************************
22540!> \brief Sends and receives rank-4 data
22541!> \param msgin ...
22542!> \param dest ...
22543!> \param msgout ...
22544!> \param source ...
22545!> \param comm ...
22546!> \note see mp_sendrecv_rv
22547! **************************************************************************************************
22548 SUBROUTINE mp_sendrecv_rm4(msgin, dest, msgout, source, comm, tag)
22549 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
22550 INTEGER, INTENT(IN) :: dest
22551 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
22552 INTEGER, INTENT(IN) :: source
22553 CLASS(mp_comm_type), INTENT(IN) :: comm
22554 INTEGER, INTENT(IN), OPTIONAL :: tag
22555
22556 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm4'
22557
22558 INTEGER :: handle
22559#if defined(__parallel)
22560 INTEGER :: ierr, msglen_in, msglen_out, &
22561 recv_tag, send_tag
22562#endif
22563
22564 CALL mp_timeset(routinen, handle)
22565
22566#if defined(__parallel)
22567 msglen_in = SIZE(msgin)
22568 msglen_out = SIZE(msgout)
22569 send_tag = 0 ! cannot think of something better here, this might be dangerous
22570 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22571 IF (PRESENT(tag)) THEN
22572 send_tag = tag
22573 recv_tag = tag
22574 END IF
22575 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22576 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22577 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22578 CALL add_perf(perf_id=7, count=1, &
22579 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22580#else
22581 mark_used(dest)
22582 mark_used(source)
22583 mark_used(comm)
22584 mark_used(tag)
22585 msgout = msgin
22586#endif
22587 CALL mp_timestop(handle)
22588 END SUBROUTINE mp_sendrecv_rm4
22589
22590! **************************************************************************************************
22591!> \brief Non-blocking send and receive of a scalar
22592!> \param[in] msgin Scalar data to send
22593!> \param[in] dest Which process to send to
22594!> \param[out] msgout Receive data into this pointer
22595!> \param[in] source Process to receive from
22596!> \param[in] comm Message passing environment identifier
22597!> \param[out] send_request Request handle for the send
22598!> \param[out] recv_request Request handle for the receive
22599!> \param[in] tag (optional) tag to differentiate requests
22600!> \par Implementation
22601!> Calls mpi_isend and mpi_irecv.
22602!> \par History
22603!> 02.2005 created [Alfio Lazzaro]
22604! **************************************************************************************************
22605 SUBROUTINE mp_isendrecv_r (msgin, dest, msgout, source, comm, send_request, &
22606 recv_request, tag)
22607 REAL(kind=real_4), INTENT(IN) :: msgin
22608 INTEGER, INTENT(IN) :: dest
22609 REAL(kind=real_4), INTENT(INOUT) :: msgout
22610 INTEGER, INTENT(IN) :: source
22611 CLASS(mp_comm_type), INTENT(IN) :: comm
22612 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
22613 INTEGER, INTENT(in), OPTIONAL :: tag
22614
22615 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_r'
22616
22617 INTEGER :: handle
22618#if defined(__parallel)
22619 INTEGER :: ierr, my_tag
22620#endif
22621
22622 CALL mp_timeset(routinen, handle)
22623
22624#if defined(__parallel)
22625 my_tag = 0
22626 IF (PRESENT(tag)) my_tag = tag
22627
22628 CALL mpi_irecv(msgout, 1, mpi_real, source, my_tag, &
22629 comm%handle, recv_request%handle, ierr)
22630 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
22631
22632 CALL mpi_isend(msgin, 1, mpi_real, dest, my_tag, &
22633 comm%handle, send_request%handle, ierr)
22634 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22635
22636 CALL add_perf(perf_id=8, count=1, msg_size=2*real_4_size)
22637#else
22638 mark_used(dest)
22639 mark_used(source)
22640 mark_used(comm)
22641 mark_used(tag)
22642 send_request = mp_request_null
22643 recv_request = mp_request_null
22644 msgout = msgin
22645#endif
22646 CALL mp_timestop(handle)
22647 END SUBROUTINE mp_isendrecv_r
22648
22649! **************************************************************************************************
22650!> \brief Non-blocking send and receive of a vector
22651!> \param[in] msgin Vector data to send
22652!> \param[in] dest Which process to send to
22653!> \param[out] msgout Receive data into this pointer
22654!> \param[in] source Process to receive from
22655!> \param[in] comm Message passing environment identifier
22656!> \param[out] send_request Request handle for the send
22657!> \param[out] recv_request Request handle for the receive
22658!> \param[in] tag (optional) tag to differentiate requests
22659!> \par Implementation
22660!> Calls mpi_isend and mpi_irecv.
22661!> \par History
22662!> 11.2004 created [Joost VandeVondele]
22663!> \note
22664!> arrays can be pointers or assumed shape, but they must be contiguous!
22665! **************************************************************************************************
22666 SUBROUTINE mp_isendrecv_rv(msgin, dest, msgout, source, comm, send_request, &
22667 recv_request, tag)
22668 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
22669 INTEGER, INTENT(IN) :: dest
22670 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
22671 INTEGER, INTENT(IN) :: source
22672 CLASS(mp_comm_type), INTENT(IN) :: comm
22673 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
22674 INTEGER, INTENT(in), OPTIONAL :: tag
22675
22676 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_rv'
22677
22678 INTEGER :: handle
22679#if defined(__parallel)
22680 INTEGER :: ierr, msglen, my_tag
22681 REAL(kind=real_4) :: foo
22682#endif
22683
22684 CALL mp_timeset(routinen, handle)
22685
22686#if defined(__parallel)
22687#if !defined(__GNUC__) || __GNUC__ >= 9
22688 cpassert(is_contiguous(msgout))
22689 cpassert(is_contiguous(msgin))
22690#endif
22691
22692 my_tag = 0
22693 IF (PRESENT(tag)) my_tag = tag
22694
22695 msglen = SIZE(msgout, 1)
22696 IF (msglen > 0) THEN
22697 CALL mpi_irecv(msgout(1), msglen, mpi_real, source, my_tag, &
22698 comm%handle, recv_request%handle, ierr)
22699 ELSE
22700 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
22701 comm%handle, recv_request%handle, ierr)
22702 END IF
22703 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
22704
22705 msglen = SIZE(msgin, 1)
22706 IF (msglen > 0) THEN
22707 CALL mpi_isend(msgin(1), msglen, mpi_real, dest, my_tag, &
22708 comm%handle, send_request%handle, ierr)
22709 ELSE
22710 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22711 comm%handle, send_request%handle, ierr)
22712 END IF
22713 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22714
22715 msglen = (msglen + SIZE(msgout, 1) + 1)/2
22716 CALL add_perf(perf_id=8, count=1, msg_size=msglen*real_4_size)
22717#else
22718 mark_used(dest)
22719 mark_used(source)
22720 mark_used(comm)
22721 mark_used(tag)
22722 send_request = mp_request_null
22723 recv_request = mp_request_null
22724 msgout = msgin
22725#endif
22726 CALL mp_timestop(handle)
22727 END SUBROUTINE mp_isendrecv_rv
22728
22729! **************************************************************************************************
22730!> \brief Non-blocking send of vector data
22731!> \param msgin ...
22732!> \param dest ...
22733!> \param comm ...
22734!> \param request ...
22735!> \param tag ...
22736!> \par History
22737!> 08.2003 created [f&j]
22738!> \note see mp_isendrecv_rv
22739!> \note
22740!> arrays can be pointers or assumed shape, but they must be contiguous!
22741! **************************************************************************************************
22742 SUBROUTINE mp_isend_rv(msgin, dest, comm, request, tag)
22743 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
22744 INTEGER, INTENT(IN) :: dest
22745 CLASS(mp_comm_type), INTENT(IN) :: comm
22746 TYPE(mp_request_type), INTENT(out) :: request
22747 INTEGER, INTENT(in), OPTIONAL :: tag
22748
22749 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rv'
22750
22751 INTEGER :: handle, ierr
22752#if defined(__parallel)
22753 INTEGER :: msglen, my_tag
22754 REAL(kind=real_4) :: foo(1)
22755#endif
22756
22757 CALL mp_timeset(routinen, handle)
22758
22759#if defined(__parallel)
22760#if !defined(__GNUC__) || __GNUC__ >= 9
22761 cpassert(is_contiguous(msgin))
22762#endif
22763 my_tag = 0
22764 IF (PRESENT(tag)) my_tag = tag
22765
22766 msglen = SIZE(msgin)
22767 IF (msglen > 0) THEN
22768 CALL mpi_isend(msgin(1), msglen, mpi_real, dest, my_tag, &
22769 comm%handle, request%handle, ierr)
22770 ELSE
22771 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22772 comm%handle, request%handle, ierr)
22773 END IF
22774 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22775
22776 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22777#else
22778 mark_used(msgin)
22779 mark_used(dest)
22780 mark_used(comm)
22781 mark_used(request)
22782 mark_used(tag)
22783 ierr = 1
22784 request = mp_request_null
22785 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22786#endif
22787 CALL mp_timestop(handle)
22788 END SUBROUTINE mp_isend_rv
22789
22790! **************************************************************************************************
22791!> \brief Non-blocking send of matrix data
22792!> \param msgin ...
22793!> \param dest ...
22794!> \param comm ...
22795!> \param request ...
22796!> \param tag ...
22797!> \par History
22798!> 2009-11-25 [UB] Made type-generic for templates
22799!> \author fawzi
22800!> \note see mp_isendrecv_rv
22801!> \note see mp_isend_rv
22802!> \note
22803!> arrays can be pointers or assumed shape, but they must be contiguous!
22804! **************************************************************************************************
22805 SUBROUTINE mp_isend_rm2(msgin, dest, comm, request, tag)
22806 REAL(kind=real_4), DIMENSION(:, :), INTENT(IN) :: msgin
22807 INTEGER, INTENT(IN) :: dest
22808 CLASS(mp_comm_type), INTENT(IN) :: comm
22809 TYPE(mp_request_type), INTENT(out) :: request
22810 INTEGER, INTENT(in), OPTIONAL :: tag
22811
22812 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm2'
22813
22814 INTEGER :: handle, ierr
22815#if defined(__parallel)
22816 INTEGER :: msglen, my_tag
22817 REAL(kind=real_4) :: foo(1)
22818#endif
22819
22820 CALL mp_timeset(routinen, handle)
22821
22822#if defined(__parallel)
22823#if !defined(__GNUC__) || __GNUC__ >= 9
22824 cpassert(is_contiguous(msgin))
22825#endif
22826
22827 my_tag = 0
22828 IF (PRESENT(tag)) my_tag = tag
22829
22830 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
22831 IF (msglen > 0) THEN
22832 CALL mpi_isend(msgin(1, 1), msglen, mpi_real, dest, my_tag, &
22833 comm%handle, request%handle, ierr)
22834 ELSE
22835 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22836 comm%handle, request%handle, ierr)
22837 END IF
22838 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22839
22840 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22841#else
22842 mark_used(msgin)
22843 mark_used(dest)
22844 mark_used(comm)
22845 mark_used(request)
22846 mark_used(tag)
22847 ierr = 1
22848 request = mp_request_null
22849 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22850#endif
22851 CALL mp_timestop(handle)
22852 END SUBROUTINE mp_isend_rm2
22853
22854! **************************************************************************************************
22855!> \brief Non-blocking send of rank-3 data
22856!> \param msgin ...
22857!> \param dest ...
22858!> \param comm ...
22859!> \param request ...
22860!> \param tag ...
22861!> \par History
22862!> 9.2008 added _rm3 subroutine [Iain Bethune]
22863!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
22864!> 2009-11-25 [UB] Made type-generic for templates
22865!> \author fawzi
22866!> \note see mp_isendrecv_rv
22867!> \note see mp_isend_rv
22868!> \note
22869!> arrays can be pointers or assumed shape, but they must be contiguous!
22870! **************************************************************************************************
22871 SUBROUTINE mp_isend_rm3(msgin, dest, comm, request, tag)
22872 REAL(kind=real_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
22873 INTEGER, INTENT(IN) :: dest
22874 CLASS(mp_comm_type), INTENT(IN) :: comm
22875 TYPE(mp_request_type), INTENT(out) :: request
22876 INTEGER, INTENT(in), OPTIONAL :: tag
22877
22878 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm3'
22879
22880 INTEGER :: handle, ierr
22881#if defined(__parallel)
22882 INTEGER :: msglen, my_tag
22883 REAL(kind=real_4) :: foo(1)
22884#endif
22885
22886 CALL mp_timeset(routinen, handle)
22887
22888#if defined(__parallel)
22889#if !defined(__GNUC__) || __GNUC__ >= 9
22890 cpassert(is_contiguous(msgin))
22891#endif
22892
22893 my_tag = 0
22894 IF (PRESENT(tag)) my_tag = tag
22895
22896 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
22897 IF (msglen > 0) THEN
22898 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_real, dest, my_tag, &
22899 comm%handle, request%handle, ierr)
22900 ELSE
22901 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22902 comm%handle, request%handle, ierr)
22903 END IF
22904 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22905
22906 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22907#else
22908 mark_used(msgin)
22909 mark_used(dest)
22910 mark_used(comm)
22911 mark_used(request)
22912 mark_used(tag)
22913 ierr = 1
22914 request = mp_request_null
22915 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22916#endif
22917 CALL mp_timestop(handle)
22918 END SUBROUTINE mp_isend_rm3
22919
22920! **************************************************************************************************
22921!> \brief Non-blocking send of rank-4 data
22922!> \param msgin the input message
22923!> \param dest the destination processor
22924!> \param comm the communicator object
22925!> \param request the communication request id
22926!> \param tag the message tag
22927!> \par History
22928!> 2.2016 added _rm4 subroutine [Nico Holmberg]
22929!> \author fawzi
22930!> \note see mp_isend_rv
22931!> \note
22932!> arrays can be pointers or assumed shape, but they must be contiguous!
22933! **************************************************************************************************
22934 SUBROUTINE mp_isend_rm4(msgin, dest, comm, request, tag)
22935 REAL(kind=real_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
22936 INTEGER, INTENT(IN) :: dest
22937 CLASS(mp_comm_type), INTENT(IN) :: comm
22938 TYPE(mp_request_type), INTENT(out) :: request
22939 INTEGER, INTENT(in), OPTIONAL :: tag
22940
22941 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm4'
22942
22943 INTEGER :: handle, ierr
22944#if defined(__parallel)
22945 INTEGER :: msglen, my_tag
22946 REAL(kind=real_4) :: foo(1)
22947#endif
22948
22949 CALL mp_timeset(routinen, handle)
22950
22951#if defined(__parallel)
22952#if !defined(__GNUC__) || __GNUC__ >= 9
22953 cpassert(is_contiguous(msgin))
22954#endif
22955
22956 my_tag = 0
22957 IF (PRESENT(tag)) my_tag = tag
22958
22959 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
22960 IF (msglen > 0) THEN
22961 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_real, dest, my_tag, &
22962 comm%handle, request%handle, ierr)
22963 ELSE
22964 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22965 comm%handle, request%handle, ierr)
22966 END IF
22967 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22968
22969 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22970#else
22971 mark_used(msgin)
22972 mark_used(dest)
22973 mark_used(comm)
22974 mark_used(request)
22975 mark_used(tag)
22976 ierr = 1
22977 request = mp_request_null
22978 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22979#endif
22980 CALL mp_timestop(handle)
22981 END SUBROUTINE mp_isend_rm4
22982
22983! **************************************************************************************************
22984!> \brief Non-blocking receive of vector data
22985!> \param msgout ...
22986!> \param source ...
22987!> \param comm ...
22988!> \param request ...
22989!> \param tag ...
22990!> \par History
22991!> 08.2003 created [f&j]
22992!> 2009-11-25 [UB] Made type-generic for templates
22993!> \note see mp_isendrecv_rv
22994!> \note
22995!> arrays can be pointers or assumed shape, but they must be contiguous!
22996! **************************************************************************************************
22997 SUBROUTINE mp_irecv_rv(msgout, source, comm, request, tag)
22998 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
22999 INTEGER, INTENT(IN) :: source
23000 CLASS(mp_comm_type), INTENT(IN) :: comm
23001 TYPE(mp_request_type), INTENT(out) :: request
23002 INTEGER, INTENT(in), OPTIONAL :: tag
23003
23004 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rv'
23005
23006 INTEGER :: handle
23007#if defined(__parallel)
23008 INTEGER :: ierr, msglen, my_tag
23009 REAL(kind=real_4) :: foo(1)
23010#endif
23011
23012 CALL mp_timeset(routinen, handle)
23013
23014#if defined(__parallel)
23015#if !defined(__GNUC__) || __GNUC__ >= 9
23016 cpassert(is_contiguous(msgout))
23017#endif
23018
23019 my_tag = 0
23020 IF (PRESENT(tag)) my_tag = tag
23021
23022 msglen = SIZE(msgout)
23023 IF (msglen > 0) THEN
23024 CALL mpi_irecv(msgout(1), msglen, mpi_real, source, my_tag, &
23025 comm%handle, request%handle, ierr)
23026 ELSE
23027 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23028 comm%handle, request%handle, ierr)
23029 END IF
23030 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
23031
23032 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23033#else
23034 cpabort("mp_irecv called in non parallel case")
23035 mark_used(msgout)
23036 mark_used(source)
23037 mark_used(comm)
23038 mark_used(tag)
23039 request = mp_request_null
23040#endif
23041 CALL mp_timestop(handle)
23042 END SUBROUTINE mp_irecv_rv
23043
23044! **************************************************************************************************
23045!> \brief Non-blocking receive of matrix data
23046!> \param msgout ...
23047!> \param source ...
23048!> \param comm ...
23049!> \param request ...
23050!> \param tag ...
23051!> \par History
23052!> 2009-11-25 [UB] Made type-generic for templates
23053!> \author fawzi
23054!> \note see mp_isendrecv_rv
23055!> \note see mp_irecv_rv
23056!> \note
23057!> arrays can be pointers or assumed shape, but they must be contiguous!
23058! **************************************************************************************************
23059 SUBROUTINE mp_irecv_rm2(msgout, source, comm, request, tag)
23060 REAL(kind=real_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
23061 INTEGER, INTENT(IN) :: source
23062 CLASS(mp_comm_type), INTENT(IN) :: comm
23063 TYPE(mp_request_type), INTENT(out) :: request
23064 INTEGER, INTENT(in), OPTIONAL :: tag
23065
23066 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm2'
23067
23068 INTEGER :: handle
23069#if defined(__parallel)
23070 INTEGER :: ierr, msglen, my_tag
23071 REAL(kind=real_4) :: foo(1)
23072#endif
23073
23074 CALL mp_timeset(routinen, handle)
23075
23076#if defined(__parallel)
23077#if !defined(__GNUC__) || __GNUC__ >= 9
23078 cpassert(is_contiguous(msgout))
23079#endif
23080
23081 my_tag = 0
23082 IF (PRESENT(tag)) my_tag = tag
23083
23084 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
23085 IF (msglen > 0) THEN
23086 CALL mpi_irecv(msgout(1, 1), msglen, mpi_real, source, my_tag, &
23087 comm%handle, request%handle, ierr)
23088 ELSE
23089 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23090 comm%handle, request%handle, ierr)
23091 END IF
23092 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
23093
23094 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23095#else
23096 mark_used(msgout)
23097 mark_used(source)
23098 mark_used(comm)
23099 mark_used(tag)
23100 request = mp_request_null
23101 cpabort("mp_irecv called in non parallel case")
23102#endif
23103 CALL mp_timestop(handle)
23104 END SUBROUTINE mp_irecv_rm2
23105
23106! **************************************************************************************************
23107!> \brief Non-blocking send of rank-3 data
23108!> \param msgout ...
23109!> \param source ...
23110!> \param comm ...
23111!> \param request ...
23112!> \param tag ...
23113!> \par History
23114!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
23115!> 2009-11-25 [UB] Made type-generic for templates
23116!> \author fawzi
23117!> \note see mp_isendrecv_rv
23118!> \note see mp_irecv_rv
23119!> \note
23120!> arrays can be pointers or assumed shape, but they must be contiguous!
23121! **************************************************************************************************
23122 SUBROUTINE mp_irecv_rm3(msgout, source, comm, request, tag)
23123 REAL(kind=real_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
23124 INTEGER, INTENT(IN) :: source
23125 CLASS(mp_comm_type), INTENT(IN) :: comm
23126 TYPE(mp_request_type), INTENT(out) :: request
23127 INTEGER, INTENT(in), OPTIONAL :: tag
23128
23129 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm3'
23130
23131 INTEGER :: handle
23132#if defined(__parallel)
23133 INTEGER :: ierr, msglen, my_tag
23134 REAL(kind=real_4) :: foo(1)
23135#endif
23136
23137 CALL mp_timeset(routinen, handle)
23138
23139#if defined(__parallel)
23140#if !defined(__GNUC__) || __GNUC__ >= 9
23141 cpassert(is_contiguous(msgout))
23142#endif
23143
23144 my_tag = 0
23145 IF (PRESENT(tag)) my_tag = tag
23146
23147 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
23148 IF (msglen > 0) THEN
23149 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_real, source, my_tag, &
23150 comm%handle, request%handle, ierr)
23151 ELSE
23152 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23153 comm%handle, request%handle, ierr)
23154 END IF
23155 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
23156
23157 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23158#else
23159 mark_used(msgout)
23160 mark_used(source)
23161 mark_used(comm)
23162 mark_used(tag)
23163 request = mp_request_null
23164 cpabort("mp_irecv called in non parallel case")
23165#endif
23166 CALL mp_timestop(handle)
23167 END SUBROUTINE mp_irecv_rm3
23168
23169! **************************************************************************************************
23170!> \brief Non-blocking receive of rank-4 data
23171!> \param msgout the output message
23172!> \param source the source processor
23173!> \param comm the communicator object
23174!> \param request the communication request id
23175!> \param tag the message tag
23176!> \par History
23177!> 2.2016 added _rm4 subroutine [Nico Holmberg]
23178!> \author fawzi
23179!> \note see mp_irecv_rv
23180!> \note
23181!> arrays can be pointers or assumed shape, but they must be contiguous!
23182! **************************************************************************************************
23183 SUBROUTINE mp_irecv_rm4(msgout, source, comm, request, tag)
23184 REAL(kind=real_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
23185 INTEGER, INTENT(IN) :: source
23186 CLASS(mp_comm_type), INTENT(IN) :: comm
23187 TYPE(mp_request_type), INTENT(out) :: request
23188 INTEGER, INTENT(in), OPTIONAL :: tag
23189
23190 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm4'
23191
23192 INTEGER :: handle
23193#if defined(__parallel)
23194 INTEGER :: ierr, msglen, my_tag
23195 REAL(kind=real_4) :: foo(1)
23196#endif
23197
23198 CALL mp_timeset(routinen, handle)
23199
23200#if defined(__parallel)
23201#if !defined(__GNUC__) || __GNUC__ >= 9
23202 cpassert(is_contiguous(msgout))
23203#endif
23204
23205 my_tag = 0
23206 IF (PRESENT(tag)) my_tag = tag
23207
23208 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
23209 IF (msglen > 0) THEN
23210 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_real, source, my_tag, &
23211 comm%handle, request%handle, ierr)
23212 ELSE
23213 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23214 comm%handle, request%handle, ierr)
23215 END IF
23216 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
23217
23218 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23219#else
23220 mark_used(msgout)
23221 mark_used(source)
23222 mark_used(comm)
23223 mark_used(tag)
23224 request = mp_request_null
23225 cpabort("mp_irecv called in non parallel case")
23226#endif
23227 CALL mp_timestop(handle)
23228 END SUBROUTINE mp_irecv_rm4
23229
23230! **************************************************************************************************
23231!> \brief Window initialization function for vector data
23232!> \param base ...
23233!> \param comm ...
23234!> \param win ...
23235!> \par History
23236!> 02.2015 created [Alfio Lazzaro]
23237!> \note
23238!> arrays can be pointers or assumed shape, but they must be contiguous!
23239! **************************************************************************************************
23240 SUBROUTINE mp_win_create_rv(base, comm, win)
23241 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
23242 TYPE(mp_comm_type), INTENT(IN) :: comm
23243 CLASS(mp_win_type), INTENT(INOUT) :: win
23244
23245 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_rv'
23246
23247 INTEGER :: handle
23248#if defined(__parallel)
23249 INTEGER :: ierr
23250 INTEGER(kind=mpi_address_kind) :: len
23251 REAL(kind=real_4) :: foo(1)
23252#endif
23253
23254 CALL mp_timeset(routinen, handle)
23255
23256#if defined(__parallel)
23257
23258 len = SIZE(base)*real_4_size
23259 IF (len > 0) THEN
23260 CALL mpi_win_create(base(1), len, real_4_size, mpi_info_null, comm%handle, win%handle, ierr)
23261 ELSE
23262 CALL mpi_win_create(foo, len, real_4_size, mpi_info_null, comm%handle, win%handle, ierr)
23263 END IF
23264 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
23265
23266 CALL add_perf(perf_id=20, count=1)
23267#else
23268 mark_used(base)
23269 mark_used(comm)
23270 win%handle = mp_win_null_handle
23271#endif
23272 CALL mp_timestop(handle)
23273 END SUBROUTINE mp_win_create_rv
23274
23275! **************************************************************************************************
23276!> \brief Single-sided get function for vector data
23277!> \param base ...
23278!> \param comm ...
23279!> \param win ...
23280!> \par History
23281!> 02.2015 created [Alfio Lazzaro]
23282!> \note
23283!> arrays can be pointers or assumed shape, but they must be contiguous!
23284! **************************************************************************************************
23285 SUBROUTINE mp_rget_rv(base, source, win, win_data, myproc, disp, request, &
23286 origin_datatype, target_datatype)
23287 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
23288 INTEGER, INTENT(IN) :: source
23289 CLASS(mp_win_type), INTENT(IN) :: win
23290 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: win_data
23291 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
23292 TYPE(mp_request_type), INTENT(OUT) :: request
23293 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
23294
23295 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_rv'
23296
23297 INTEGER :: handle
23298#if defined(__parallel)
23299 INTEGER :: ierr, len, &
23300 origin_len, target_len
23301 LOGICAL :: do_local_copy
23302 INTEGER(kind=mpi_address_kind) :: disp_aint
23303 mpi_data_type :: handle_origin_datatype, handle_target_datatype
23304#endif
23305
23306 CALL mp_timeset(routinen, handle)
23307
23308#if defined(__parallel)
23309 len = SIZE(base)
23310 disp_aint = 0
23311 IF (PRESENT(disp)) THEN
23312 disp_aint = int(disp, kind=mpi_address_kind)
23313 END IF
23314 handle_origin_datatype = mpi_real
23315 origin_len = len
23316 IF (PRESENT(origin_datatype)) THEN
23317 handle_origin_datatype = origin_datatype%type_handle
23318 origin_len = 1
23319 END IF
23320 handle_target_datatype = mpi_real
23321 target_len = len
23322 IF (PRESENT(target_datatype)) THEN
23323 handle_target_datatype = target_datatype%type_handle
23324 target_len = 1
23325 END IF
23326 IF (len > 0) THEN
23327 do_local_copy = .false.
23328 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
23329 IF (myproc .EQ. source) do_local_copy = .true.
23330 END IF
23331 IF (do_local_copy) THEN
23332 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
23333 base(:) = win_data(disp_aint + 1:disp_aint + len)
23334 !$OMP END PARALLEL WORKSHARE
23335 request = mp_request_null
23336 ierr = 0
23337 ELSE
23338 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
23339 target_len, handle_target_datatype, win%handle, request%handle, ierr)
23340 END IF
23341 ELSE
23342 request = mp_request_null
23343 ierr = 0
23344 END IF
23345 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
23346
23347 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*real_4_size)
23348#else
23349 mark_used(source)
23350 mark_used(win)
23351 mark_used(myproc)
23352 mark_used(origin_datatype)
23353 mark_used(target_datatype)
23354
23355 request = mp_request_null
23356 !
23357 IF (PRESENT(disp)) THEN
23358 base(:) = win_data(disp + 1:disp + SIZE(base))
23359 ELSE
23360 base(:) = win_data(:SIZE(base))
23361 END IF
23362
23363#endif
23364 CALL mp_timestop(handle)
23365 END SUBROUTINE mp_rget_rv
23366
23367! **************************************************************************************************
23368!> \brief ...
23369!> \param count ...
23370!> \param lengths ...
23371!> \param displs ...
23372!> \return ...
23373! ***************************************************************************
23374 FUNCTION mp_type_indexed_make_r (count, lengths, displs) &
23375 result(type_descriptor)
23376 INTEGER, INTENT(IN) :: count
23377 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
23378 TYPE(mp_type_descriptor_type) :: type_descriptor
23379
23380 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_r'
23381
23382 INTEGER :: handle
23383#if defined(__parallel)
23384 INTEGER :: ierr
23385#endif
23386
23387 CALL mp_timeset(routinen, handle)
23388
23389#if defined(__parallel)
23390 CALL mpi_type_indexed(count, lengths, displs, mpi_real, &
23391 type_descriptor%type_handle, ierr)
23392 IF (ierr /= 0) &
23393 cpabort("MPI_Type_Indexed @ "//routinen)
23394 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
23395 IF (ierr /= 0) &
23396 cpabort("MPI_Type_commit @ "//routinen)
23397#else
23398 type_descriptor%type_handle = 1
23399#endif
23400 type_descriptor%length = count
23401 NULLIFY (type_descriptor%subtype)
23402 type_descriptor%vector_descriptor(1:2) = 1
23403 type_descriptor%has_indexing = .true.
23404 type_descriptor%index_descriptor%index => lengths
23405 type_descriptor%index_descriptor%chunks => displs
23406
23407 CALL mp_timestop(handle)
23408
23409 END FUNCTION mp_type_indexed_make_r
23410
23411! **************************************************************************************************
23412!> \brief Allocates special parallel memory
23413!> \param[in] DATA pointer to integer array to allocate
23414!> \param[in] len number of integers to allocate
23415!> \param[out] stat (optional) allocation status result
23416!> \author UB
23417! **************************************************************************************************
23418 SUBROUTINE mp_allocate_r (DATA, len, stat)
23419 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23420 INTEGER, INTENT(IN) :: len
23421 INTEGER, INTENT(OUT), OPTIONAL :: stat
23422
23423 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_r'
23424
23425 INTEGER :: handle, ierr
23426
23427 CALL mp_timeset(routinen, handle)
23428
23429#if defined(__parallel)
23430 NULLIFY (data)
23431 CALL mp_alloc_mem(DATA, len, stat=ierr)
23432 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
23433 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
23434 CALL add_perf(perf_id=15, count=1)
23435#else
23436 ALLOCATE (DATA(len), stat=ierr)
23437 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
23438 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
23439#endif
23440 IF (PRESENT(stat)) stat = ierr
23441 CALL mp_timestop(handle)
23442 END SUBROUTINE mp_allocate_r
23443
23444! **************************************************************************************************
23445!> \brief Deallocates special parallel memory
23446!> \param[in] DATA pointer to special memory to deallocate
23447!> \param stat ...
23448!> \author UB
23449! **************************************************************************************************
23450 SUBROUTINE mp_deallocate_r (DATA, stat)
23451 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23452 INTEGER, INTENT(OUT), OPTIONAL :: stat
23453
23454 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_r'
23455
23456 INTEGER :: handle
23457#if defined(__parallel)
23458 INTEGER :: ierr
23459#endif
23460
23461 CALL mp_timeset(routinen, handle)
23462
23463#if defined(__parallel)
23464 CALL mp_free_mem(DATA, ierr)
23465 IF (PRESENT(stat)) THEN
23466 stat = ierr
23467 ELSE
23468 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
23469 END IF
23470 NULLIFY (data)
23471 CALL add_perf(perf_id=15, count=1)
23472#else
23473 DEALLOCATE (data)
23474 IF (PRESENT(stat)) stat = 0
23475#endif
23476 CALL mp_timestop(handle)
23477 END SUBROUTINE mp_deallocate_r
23478
23479! **************************************************************************************************
23480!> \brief (parallel) Blocking individual file write using explicit offsets
23481!> (serial) Unformatted stream write
23482!> \param[in] fh file handle (file storage unit)
23483!> \param[in] offset file offset (position)
23484!> \param[in] msg data to be written to the file
23485!> \param msglen ...
23486!> \par MPI-I/O mapping mpi_file_write_at
23487!> \par STREAM-I/O mapping WRITE
23488!> \param[in](optional) msglen number of the elements of data
23489! **************************************************************************************************
23490 SUBROUTINE mp_file_write_at_rv(fh, offset, msg, msglen)
23491 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
23492 CLASS(mp_file_type), INTENT(IN) :: fh
23493 INTEGER, INTENT(IN), OPTIONAL :: msglen
23494 INTEGER(kind=file_offset), INTENT(IN) :: offset
23495
23496 INTEGER :: msg_len
23497#if defined(__parallel)
23498 INTEGER :: ierr
23499#endif
23500
23501 msg_len = SIZE(msg)
23502 IF (PRESENT(msglen)) msg_len = msglen
23503#if defined(__parallel)
23504 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23505 IF (ierr .NE. 0) &
23506 cpabort("mpi_file_write_at_rv @ mp_file_write_at_rv")
23507#else
23508 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23509#endif
23510 END SUBROUTINE mp_file_write_at_rv
23511
23512! **************************************************************************************************
23513!> \brief ...
23514!> \param fh ...
23515!> \param offset ...
23516!> \param msg ...
23517! **************************************************************************************************
23518 SUBROUTINE mp_file_write_at_r (fh, offset, msg)
23519 REAL(kind=real_4), INTENT(IN) :: msg
23520 CLASS(mp_file_type), INTENT(IN) :: fh
23521 INTEGER(kind=file_offset), INTENT(IN) :: offset
23522
23523#if defined(__parallel)
23524 INTEGER :: ierr
23525
23526 ierr = 0
23527 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23528 IF (ierr .NE. 0) &
23529 cpabort("mpi_file_write_at_r @ mp_file_write_at_r")
23530#else
23531 WRITE (unit=fh%handle, pos=offset + 1) msg
23532#endif
23533 END SUBROUTINE mp_file_write_at_r
23534
23535! **************************************************************************************************
23536!> \brief (parallel) Blocking collective file write using explicit offsets
23537!> (serial) Unformatted stream write
23538!> \param fh ...
23539!> \param offset ...
23540!> \param msg ...
23541!> \param msglen ...
23542!> \par MPI-I/O mapping mpi_file_write_at_all
23543!> \par STREAM-I/O mapping WRITE
23544! **************************************************************************************************
23545 SUBROUTINE mp_file_write_at_all_rv(fh, offset, msg, msglen)
23546 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
23547 CLASS(mp_file_type), INTENT(IN) :: fh
23548 INTEGER, INTENT(IN), OPTIONAL :: msglen
23549 INTEGER(kind=file_offset), INTENT(IN) :: offset
23550
23551 INTEGER :: msg_len
23552#if defined(__parallel)
23553 INTEGER :: ierr
23554#endif
23555
23556 msg_len = SIZE(msg)
23557 IF (PRESENT(msglen)) msg_len = msglen
23558#if defined(__parallel)
23559 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23560 IF (ierr .NE. 0) &
23561 cpabort("mpi_file_write_at_all_rv @ mp_file_write_at_all_rv")
23562#else
23563 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23564#endif
23565 END SUBROUTINE mp_file_write_at_all_rv
23566
23567! **************************************************************************************************
23568!> \brief ...
23569!> \param fh ...
23570!> \param offset ...
23571!> \param msg ...
23572! **************************************************************************************************
23573 SUBROUTINE mp_file_write_at_all_r (fh, offset, msg)
23574 REAL(kind=real_4), INTENT(IN) :: msg
23575 CLASS(mp_file_type), INTENT(IN) :: fh
23576 INTEGER(kind=file_offset), INTENT(IN) :: offset
23577
23578#if defined(__parallel)
23579 INTEGER :: ierr
23580
23581 ierr = 0
23582 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23583 IF (ierr .NE. 0) &
23584 cpabort("mpi_file_write_at_all_r @ mp_file_write_at_all_r")
23585#else
23586 WRITE (unit=fh%handle, pos=offset + 1) msg
23587#endif
23588 END SUBROUTINE mp_file_write_at_all_r
23589
23590! **************************************************************************************************
23591!> \brief (parallel) Blocking individual file read using explicit offsets
23592!> (serial) Unformatted stream read
23593!> \param[in] fh file handle (file storage unit)
23594!> \param[in] offset file offset (position)
23595!> \param[out] msg data to be read from the file
23596!> \param msglen ...
23597!> \par MPI-I/O mapping mpi_file_read_at
23598!> \par STREAM-I/O mapping READ
23599!> \param[in](optional) msglen number of elements of data
23600! **************************************************************************************************
23601 SUBROUTINE mp_file_read_at_rv(fh, offset, msg, msglen)
23602 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
23603 CLASS(mp_file_type), INTENT(IN) :: fh
23604 INTEGER, INTENT(IN), OPTIONAL :: msglen
23605 INTEGER(kind=file_offset), INTENT(IN) :: offset
23606
23607 INTEGER :: msg_len
23608#if defined(__parallel)
23609 INTEGER :: ierr
23610#endif
23611
23612 msg_len = SIZE(msg)
23613 IF (PRESENT(msglen)) msg_len = msglen
23614#if defined(__parallel)
23615 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23616 IF (ierr .NE. 0) &
23617 cpabort("mpi_file_read_at_rv @ mp_file_read_at_rv")
23618#else
23619 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23620#endif
23621 END SUBROUTINE mp_file_read_at_rv
23622
23623! **************************************************************************************************
23624!> \brief ...
23625!> \param fh ...
23626!> \param offset ...
23627!> \param msg ...
23628! **************************************************************************************************
23629 SUBROUTINE mp_file_read_at_r (fh, offset, msg)
23630 REAL(kind=real_4), INTENT(OUT) :: msg
23631 CLASS(mp_file_type), INTENT(IN) :: fh
23632 INTEGER(kind=file_offset), INTENT(IN) :: offset
23633
23634#if defined(__parallel)
23635 INTEGER :: ierr
23636
23637 ierr = 0
23638 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23639 IF (ierr .NE. 0) &
23640 cpabort("mpi_file_read_at_r @ mp_file_read_at_r")
23641#else
23642 READ (unit=fh%handle, pos=offset + 1) msg
23643#endif
23644 END SUBROUTINE mp_file_read_at_r
23645
23646! **************************************************************************************************
23647!> \brief (parallel) Blocking collective file read using explicit offsets
23648!> (serial) Unformatted stream read
23649!> \param fh ...
23650!> \param offset ...
23651!> \param msg ...
23652!> \param msglen ...
23653!> \par MPI-I/O mapping mpi_file_read_at_all
23654!> \par STREAM-I/O mapping READ
23655! **************************************************************************************************
23656 SUBROUTINE mp_file_read_at_all_rv(fh, offset, msg, msglen)
23657 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
23658 CLASS(mp_file_type), INTENT(IN) :: fh
23659 INTEGER, INTENT(IN), OPTIONAL :: msglen
23660 INTEGER(kind=file_offset), INTENT(IN) :: offset
23661
23662 INTEGER :: msg_len
23663#if defined(__parallel)
23664 INTEGER :: ierr
23665#endif
23666
23667 msg_len = SIZE(msg)
23668 IF (PRESENT(msglen)) msg_len = msglen
23669#if defined(__parallel)
23670 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23671 IF (ierr .NE. 0) &
23672 cpabort("mpi_file_read_at_all_rv @ mp_file_read_at_all_rv")
23673#else
23674 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23675#endif
23676 END SUBROUTINE mp_file_read_at_all_rv
23677
23678! **************************************************************************************************
23679!> \brief ...
23680!> \param fh ...
23681!> \param offset ...
23682!> \param msg ...
23683! **************************************************************************************************
23684 SUBROUTINE mp_file_read_at_all_r (fh, offset, msg)
23685 REAL(kind=real_4), INTENT(OUT) :: msg
23686 CLASS(mp_file_type), INTENT(IN) :: fh
23687 INTEGER(kind=file_offset), INTENT(IN) :: offset
23688
23689#if defined(__parallel)
23690 INTEGER :: ierr
23691
23692 ierr = 0
23693 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23694 IF (ierr .NE. 0) &
23695 cpabort("mpi_file_read_at_all_r @ mp_file_read_at_all_r")
23696#else
23697 READ (unit=fh%handle, pos=offset + 1) msg
23698#endif
23699 END SUBROUTINE mp_file_read_at_all_r
23700
23701! **************************************************************************************************
23702!> \brief ...
23703!> \param ptr ...
23704!> \param vector_descriptor ...
23705!> \param index_descriptor ...
23706!> \return ...
23707! **************************************************************************************************
23708 FUNCTION mp_type_make_r (ptr, &
23709 vector_descriptor, index_descriptor) &
23710 result(type_descriptor)
23711 REAL(kind=real_4), DIMENSION(:), TARGET, asynchronous :: ptr
23712 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
23713 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
23714 TYPE(mp_type_descriptor_type) :: type_descriptor
23715
23716 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_r'
23717
23718#if defined(__parallel)
23719 INTEGER :: ierr
23720#endif
23721
23722 NULLIFY (type_descriptor%subtype)
23723 type_descriptor%length = SIZE(ptr)
23724#if defined(__parallel)
23725 type_descriptor%type_handle = mpi_real
23726 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
23727 IF (ierr /= 0) &
23728 cpabort("MPI_Get_address @ "//routinen)
23729#else
23730 type_descriptor%type_handle = 1
23731#endif
23732 type_descriptor%vector_descriptor(1:2) = 1
23733 type_descriptor%has_indexing = .false.
23734 type_descriptor%data_r => ptr
23735 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
23736 cpabort(routinen//": Vectors and indices NYI")
23737 END IF
23738 END FUNCTION mp_type_make_r
23739
23740! **************************************************************************************************
23741!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
23742!> as the Fortran version returns an integer, which we take to be a C_PTR
23743!> \param DATA data array to allocate
23744!> \param[in] len length (in data elements) of data array allocation
23745!> \param[out] stat (optional) allocation status result
23746! **************************************************************************************************
23747 SUBROUTINE mp_alloc_mem_r (DATA, len, stat)
23748 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23749 INTEGER, INTENT(IN) :: len
23750 INTEGER, INTENT(OUT), OPTIONAL :: stat
23751
23752#if defined(__parallel)
23753 INTEGER :: size, ierr, length, &
23754 mp_res
23755 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
23756 TYPE(c_ptr) :: mp_baseptr
23757 mpi_info_type :: mp_info
23758
23759 length = max(len, 1)
23760 CALL mpi_type_size(mpi_real, size, ierr)
23761 mp_size = int(length, kind=mpi_address_kind)*size
23762 IF (mp_size .GT. mp_max_memory_size) THEN
23763 cpabort("MPI cannot allocate more than 2 GiByte")
23764 END IF
23765 mp_info = mpi_info_null
23766 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
23767 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
23768 IF (PRESENT(stat)) stat = mp_res
23769#else
23770 INTEGER :: length, mystat
23771 length = max(len, 1)
23772 IF (PRESENT(stat)) THEN
23773 ALLOCATE (DATA(length), stat=mystat)
23774 stat = mystat ! show to convention checker that stat is used
23775 ELSE
23776 ALLOCATE (DATA(length))
23777 END IF
23778#endif
23779 END SUBROUTINE mp_alloc_mem_r
23780
23781! **************************************************************************************************
23782!> \brief Deallocates am array, ... this is hackish
23783!> as the Fortran version takes an integer, which we hope to get by reference
23784!> \param DATA data array to allocate
23785!> \param[out] stat (optional) allocation status result
23786! **************************************************************************************************
23787 SUBROUTINE mp_free_mem_r (DATA, stat)
23788 REAL(kind=real_4), DIMENSION(:), &
23789 POINTER, asynchronous :: DATA
23790 INTEGER, INTENT(OUT), OPTIONAL :: stat
23791
23792#if defined(__parallel)
23793 INTEGER :: mp_res
23794 CALL mpi_free_mem(DATA, mp_res)
23795 IF (PRESENT(stat)) stat = mp_res
23796#else
23797 DEALLOCATE (data)
23798 IF (PRESENT(stat)) stat = 0
23799#endif
23800 END SUBROUTINE mp_free_mem_r
23801! **************************************************************************************************
23802!> \brief Shift around the data in msg
23803!> \param[in,out] msg Rank-2 data to shift
23804!> \param[in] comm message passing environment identifier
23805!> \param[in] displ_in displacements (?)
23806!> \par Example
23807!> msg will be moved from rank to rank+displ_in (in a circular way)
23808!> \par Limitations
23809!> * displ_in will be 1 by default (others not tested)
23810!> * the message array needs to be the same size on all processes
23811! **************************************************************************************************
23812 SUBROUTINE mp_shift_zm(msg, comm, displ_in)
23813
23814 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
23815 CLASS(mp_comm_type), INTENT(IN) :: comm
23816 INTEGER, INTENT(IN), OPTIONAL :: displ_in
23817
23818 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_zm'
23819
23820 INTEGER :: handle, ierror
23821#if defined(__parallel)
23822 INTEGER :: displ, left, &
23823 msglen, myrank, nprocs, &
23824 right, tag
23825#endif
23826
23827 ierror = 0
23828 CALL mp_timeset(routinen, handle)
23829
23830#if defined(__parallel)
23831 CALL mpi_comm_rank(comm%handle, myrank, ierror)
23832 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
23833 CALL mpi_comm_size(comm%handle, nprocs, ierror)
23834 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
23835 IF (PRESENT(displ_in)) THEN
23836 displ = displ_in
23837 ELSE
23838 displ = 1
23839 END IF
23840 right = modulo(myrank + displ, nprocs)
23841 left = modulo(myrank - displ, nprocs)
23842 tag = 17
23843 msglen = SIZE(msg)
23844 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_complex, right, tag, left, tag, &
23845 comm%handle, mpi_status_ignore, ierror)
23846 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
23847 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_8_size))
23848#else
23849 mark_used(msg)
23850 mark_used(comm)
23851 mark_used(displ_in)
23852#endif
23853 CALL mp_timestop(handle)
23854
23855 END SUBROUTINE mp_shift_zm
23856
23857! **************************************************************************************************
23858!> \brief Shift around the data in msg
23859!> \param[in,out] msg Data to shift
23860!> \param[in] comm message passing environment identifier
23861!> \param[in] displ_in displacements (?)
23862!> \par Example
23863!> msg will be moved from rank to rank+displ_in (in a circular way)
23864!> \par Limitations
23865!> * displ_in will be 1 by default (others not tested)
23866!> * the message array needs to be the same size on all processes
23867! **************************************************************************************************
23868 SUBROUTINE mp_shift_z (msg, comm, displ_in)
23869
23870 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
23871 CLASS(mp_comm_type), INTENT(IN) :: comm
23872 INTEGER, INTENT(IN), OPTIONAL :: displ_in
23873
23874 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_z'
23875
23876 INTEGER :: handle, ierror
23877#if defined(__parallel)
23878 INTEGER :: displ, left, &
23879 msglen, myrank, nprocs, &
23880 right, tag
23881#endif
23882
23883 ierror = 0
23884 CALL mp_timeset(routinen, handle)
23885
23886#if defined(__parallel)
23887 CALL mpi_comm_rank(comm%handle, myrank, ierror)
23888 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
23889 CALL mpi_comm_size(comm%handle, nprocs, ierror)
23890 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
23891 IF (PRESENT(displ_in)) THEN
23892 displ = displ_in
23893 ELSE
23894 displ = 1
23895 END IF
23896 right = modulo(myrank + displ, nprocs)
23897 left = modulo(myrank - displ, nprocs)
23898 tag = 19
23899 msglen = SIZE(msg)
23900 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_complex, right, tag, left, &
23901 tag, comm%handle, mpi_status_ignore, ierror)
23902 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
23903 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_8_size))
23904#else
23905 mark_used(msg)
23906 mark_used(comm)
23907 mark_used(displ_in)
23908#endif
23909 CALL mp_timestop(handle)
23910
23911 END SUBROUTINE mp_shift_z
23912
23913! **************************************************************************************************
23914!> \brief All-to-all data exchange, rank-1 data of different sizes
23915!> \param[in] sb Data to send
23916!> \param[in] scount Data counts for data sent to other processes
23917!> \param[in] sdispl Respective data offsets for data sent to process
23918!> \param[in,out] rb Buffer into which to receive data
23919!> \param[in] rcount Data counts for data received from other
23920!> processes
23921!> \param[in] rdispl Respective data offsets for data received from
23922!> other processes
23923!> \param[in] comm Message passing environment identifier
23924!> \par MPI mapping
23925!> mpi_alltoallv
23926!> \par Array sizes
23927!> The scount, rcount, and the sdispl and rdispl arrays have a
23928!> size equal to the number of processes.
23929!> \par Offsets
23930!> Values in sdispl and rdispl start with 0.
23931! **************************************************************************************************
23932 SUBROUTINE mp_alltoall_z11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
23933
23934 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
23935 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
23936 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
23937 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
23938 CLASS(mp_comm_type), INTENT(IN) :: comm
23939
23940 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z11v'
23941
23942 INTEGER :: handle
23943#if defined(__parallel)
23944 INTEGER :: ierr, msglen
23945#else
23946 INTEGER :: i
23947#endif
23948
23949 CALL mp_timeset(routinen, handle)
23950
23951#if defined(__parallel)
23952 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_complex, &
23953 rb, rcount, rdispl, mpi_double_complex, comm%handle, ierr)
23954 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
23955 msglen = sum(scount) + sum(rcount)
23956 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
23957#else
23958 mark_used(comm)
23959 mark_used(scount)
23960 mark_used(sdispl)
23961 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
23962 DO i = 1, rcount(1)
23963 rb(rdispl(1) + i) = sb(sdispl(1) + i)
23964 END DO
23965#endif
23966 CALL mp_timestop(handle)
23967
23968 END SUBROUTINE mp_alltoall_z11v
23969
23970! **************************************************************************************************
23971!> \brief All-to-all data exchange, rank-2 data of different sizes
23972!> \param sb ...
23973!> \param scount ...
23974!> \param sdispl ...
23975!> \param rb ...
23976!> \param rcount ...
23977!> \param rdispl ...
23978!> \param comm ...
23979!> \par MPI mapping
23980!> mpi_alltoallv
23981!> \note see mp_alltoall_z11v
23982! **************************************************************************************************
23983 SUBROUTINE mp_alltoall_z22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
23984
23985 COMPLEX(kind=real_8), DIMENSION(:, :), &
23986 INTENT(IN), CONTIGUOUS :: sb
23987 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
23988 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, &
23989 INTENT(INOUT) :: rb
23990 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
23991 CLASS(mp_comm_type), INTENT(IN) :: comm
23992
23993 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z22v'
23994
23995 INTEGER :: handle
23996#if defined(__parallel)
23997 INTEGER :: ierr, msglen
23998#endif
23999
24000 CALL mp_timeset(routinen, handle)
24001
24002#if defined(__parallel)
24003 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_complex, &
24004 rb, rcount, rdispl, mpi_double_complex, comm%handle, ierr)
24005 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
24006 msglen = sum(scount) + sum(rcount)
24007 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*(2*real_8_size))
24008#else
24009 mark_used(comm)
24010 mark_used(scount)
24011 mark_used(sdispl)
24012 mark_used(rcount)
24013 mark_used(rdispl)
24014 rb = sb
24015#endif
24016 CALL mp_timestop(handle)
24017
24018 END SUBROUTINE mp_alltoall_z22v
24019
24020! **************************************************************************************************
24021!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
24022!> \param[in] sb array with data to send
24023!> \param[out] rb array into which data is received
24024!> \param[in] count number of elements to send/receive (product of the
24025!> extents of the first two dimensions)
24026!> \param[in] comm Message passing environment identifier
24027!> \par Index meaning
24028!> \par The first two indices specify the data while the last index counts
24029!> the processes
24030!> \par Sizes of ranks
24031!> All processes have the same data size.
24032!> \par MPI mapping
24033!> mpi_alltoall
24034! **************************************************************************************************
24035 SUBROUTINE mp_alltoall_z (sb, rb, count, comm)
24036
24037 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
24038 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
24039 INTEGER, INTENT(IN) :: count
24040 CLASS(mp_comm_type), INTENT(IN) :: comm
24041
24042 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z'
24043
24044 INTEGER :: handle
24045#if defined(__parallel)
24046 INTEGER :: ierr, msglen, np
24047#endif
24048
24049 CALL mp_timeset(routinen, handle)
24050
24051#if defined(__parallel)
24052 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24053 rb, count, mpi_double_complex, comm%handle, ierr)
24054 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24055 CALL mpi_comm_size(comm%handle, np, ierr)
24056 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24057 msglen = 2*count*np
24058 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24059#else
24060 mark_used(count)
24061 mark_used(comm)
24062 rb = sb
24063#endif
24064 CALL mp_timestop(handle)
24065
24066 END SUBROUTINE mp_alltoall_z
24067
24068! **************************************************************************************************
24069!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
24070!> \param sb ...
24071!> \param rb ...
24072!> \param count ...
24073!> \param commp ...
24074!> \note see mp_alltoall_z
24075! **************************************************************************************************
24076 SUBROUTINE mp_alltoall_z22(sb, rb, count, comm)
24077
24078 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
24079 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
24080 INTEGER, INTENT(IN) :: count
24081 CLASS(mp_comm_type), INTENT(IN) :: comm
24082
24083 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z22'
24084
24085 INTEGER :: handle
24086#if defined(__parallel)
24087 INTEGER :: ierr, msglen, np
24088#endif
24089
24090 CALL mp_timeset(routinen, handle)
24091
24092#if defined(__parallel)
24093 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24094 rb, count, mpi_double_complex, comm%handle, ierr)
24095 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24096 CALL mpi_comm_size(comm%handle, np, ierr)
24097 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24098 msglen = 2*SIZE(sb)*np
24099 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24100#else
24101 mark_used(count)
24102 mark_used(comm)
24103 rb = sb
24104#endif
24105 CALL mp_timestop(handle)
24106
24107 END SUBROUTINE mp_alltoall_z22
24108
24109! **************************************************************************************************
24110!> \brief All-to-all data exchange, rank-3 data with equal sizes
24111!> \param sb ...
24112!> \param rb ...
24113!> \param count ...
24114!> \param comm ...
24115!> \note see mp_alltoall_z
24116! **************************************************************************************************
24117 SUBROUTINE mp_alltoall_z33(sb, rb, count, comm)
24118
24119 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
24120 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
24121 INTEGER, INTENT(IN) :: count
24122 CLASS(mp_comm_type), INTENT(IN) :: comm
24123
24124 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z33'
24125
24126 INTEGER :: handle
24127#if defined(__parallel)
24128 INTEGER :: ierr, msglen, np
24129#endif
24130
24131 CALL mp_timeset(routinen, handle)
24132
24133#if defined(__parallel)
24134 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24135 rb, count, mpi_double_complex, comm%handle, ierr)
24136 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24137 CALL mpi_comm_size(comm%handle, np, ierr)
24138 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24139 msglen = 2*count*np
24140 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24141#else
24142 mark_used(count)
24143 mark_used(comm)
24144 rb = sb
24145#endif
24146 CALL mp_timestop(handle)
24147
24148 END SUBROUTINE mp_alltoall_z33
24149
24150! **************************************************************************************************
24151!> \brief All-to-all data exchange, rank 4 data, equal sizes
24152!> \param sb ...
24153!> \param rb ...
24154!> \param count ...
24155!> \param comm ...
24156!> \note see mp_alltoall_z
24157! **************************************************************************************************
24158 SUBROUTINE mp_alltoall_z44(sb, rb, count, comm)
24159
24160 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24161 INTENT(IN) :: sb
24162 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24163 INTENT(OUT) :: rb
24164 INTEGER, INTENT(IN) :: count
24165 CLASS(mp_comm_type), INTENT(IN) :: comm
24166
24167 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z44'
24168
24169 INTEGER :: handle
24170#if defined(__parallel)
24171 INTEGER :: ierr, msglen, np
24172#endif
24173
24174 CALL mp_timeset(routinen, handle)
24175
24176#if defined(__parallel)
24177 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24178 rb, count, mpi_double_complex, comm%handle, ierr)
24179 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24180 CALL mpi_comm_size(comm%handle, np, ierr)
24181 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24182 msglen = 2*count*np
24183 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24184#else
24185 mark_used(count)
24186 mark_used(comm)
24187 rb = sb
24188#endif
24189 CALL mp_timestop(handle)
24190
24191 END SUBROUTINE mp_alltoall_z44
24192
24193! **************************************************************************************************
24194!> \brief All-to-all data exchange, rank 5 data, equal sizes
24195!> \param sb ...
24196!> \param rb ...
24197!> \param count ...
24198!> \param comm ...
24199!> \note see mp_alltoall_z
24200! **************************************************************************************************
24201 SUBROUTINE mp_alltoall_z55(sb, rb, count, comm)
24202
24203 COMPLEX(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
24204 INTENT(IN) :: sb
24205 COMPLEX(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
24206 INTENT(OUT) :: rb
24207 INTEGER, INTENT(IN) :: count
24208 CLASS(mp_comm_type), INTENT(IN) :: comm
24209
24210 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z55'
24211
24212 INTEGER :: handle
24213#if defined(__parallel)
24214 INTEGER :: ierr, msglen, np
24215#endif
24216
24217 CALL mp_timeset(routinen, handle)
24218
24219#if defined(__parallel)
24220 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24221 rb, count, mpi_double_complex, comm%handle, ierr)
24222 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24223 CALL mpi_comm_size(comm%handle, np, ierr)
24224 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24225 msglen = 2*count*np
24226 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24227#else
24228 mark_used(count)
24229 mark_used(comm)
24230 rb = sb
24231#endif
24232 CALL mp_timestop(handle)
24233
24234 END SUBROUTINE mp_alltoall_z55
24235
24236! **************************************************************************************************
24237!> \brief All-to-all data exchange, rank-4 data to rank-5 data
24238!> \param sb ...
24239!> \param rb ...
24240!> \param count ...
24241!> \param comm ...
24242!> \note see mp_alltoall_z
24243!> \note User must ensure size consistency.
24244! **************************************************************************************************
24245 SUBROUTINE mp_alltoall_z45(sb, rb, count, comm)
24246
24247 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24248 INTENT(IN) :: sb
24249 COMPLEX(kind=real_8), &
24250 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
24251 INTEGER, INTENT(IN) :: count
24252 CLASS(mp_comm_type), INTENT(IN) :: comm
24253
24254 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z45'
24255
24256 INTEGER :: handle
24257#if defined(__parallel)
24258 INTEGER :: ierr, msglen, np
24259#endif
24260
24261 CALL mp_timeset(routinen, handle)
24262
24263#if defined(__parallel)
24264 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24265 rb, count, mpi_double_complex, comm%handle, ierr)
24266 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24267 CALL mpi_comm_size(comm%handle, np, ierr)
24268 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24269 msglen = 2*count*np
24270 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24271#else
24272 mark_used(count)
24273 mark_used(comm)
24274 rb = reshape(sb, shape(rb))
24275#endif
24276 CALL mp_timestop(handle)
24277
24278 END SUBROUTINE mp_alltoall_z45
24279
24280! **************************************************************************************************
24281!> \brief All-to-all data exchange, rank-3 data to rank-4 data
24282!> \param sb ...
24283!> \param rb ...
24284!> \param count ...
24285!> \param comm ...
24286!> \note see mp_alltoall_z
24287!> \note User must ensure size consistency.
24288! **************************************************************************************************
24289 SUBROUTINE mp_alltoall_z34(sb, rb, count, comm)
24290
24291 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, &
24292 INTENT(IN) :: sb
24293 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24294 INTENT(OUT) :: rb
24295 INTEGER, INTENT(IN) :: count
24296 CLASS(mp_comm_type), INTENT(IN) :: comm
24297
24298 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z34'
24299
24300 INTEGER :: handle
24301#if defined(__parallel)
24302 INTEGER :: ierr, msglen, np
24303#endif
24304
24305 CALL mp_timeset(routinen, handle)
24306
24307#if defined(__parallel)
24308 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24309 rb, count, mpi_double_complex, comm%handle, ierr)
24310 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24311 CALL mpi_comm_size(comm%handle, np, ierr)
24312 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24313 msglen = 2*count*np
24314 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24315#else
24316 mark_used(count)
24317 mark_used(comm)
24318 rb = reshape(sb, shape(rb))
24319#endif
24320 CALL mp_timestop(handle)
24321
24322 END SUBROUTINE mp_alltoall_z34
24323
24324! **************************************************************************************************
24325!> \brief All-to-all data exchange, rank-5 data to rank-4 data
24326!> \param sb ...
24327!> \param rb ...
24328!> \param count ...
24329!> \param comm ...
24330!> \note see mp_alltoall_z
24331!> \note User must ensure size consistency.
24332! **************************************************************************************************
24333 SUBROUTINE mp_alltoall_z54(sb, rb, count, comm)
24334
24335 COMPLEX(kind=real_8), &
24336 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
24337 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24338 INTENT(OUT) :: rb
24339 INTEGER, INTENT(IN) :: count
24340 CLASS(mp_comm_type), INTENT(IN) :: comm
24341
24342 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z54'
24343
24344 INTEGER :: handle
24345#if defined(__parallel)
24346 INTEGER :: ierr, msglen, np
24347#endif
24348
24349 CALL mp_timeset(routinen, handle)
24350
24351#if defined(__parallel)
24352 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24353 rb, count, mpi_double_complex, comm%handle, ierr)
24354 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24355 CALL mpi_comm_size(comm%handle, np, ierr)
24356 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24357 msglen = 2*count*np
24358 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24359#else
24360 mark_used(count)
24361 mark_used(comm)
24362 rb = reshape(sb, shape(rb))
24363#endif
24364 CALL mp_timestop(handle)
24365
24366 END SUBROUTINE mp_alltoall_z54
24367
24368! **************************************************************************************************
24369!> \brief Send one datum to another process
24370!> \param[in] msg Scalar to send
24371!> \param[in] dest Destination process
24372!> \param[in] tag Transfer identifier
24373!> \param[in] comm Message passing environment identifier
24374!> \par MPI mapping
24375!> mpi_send
24376! **************************************************************************************************
24377 SUBROUTINE mp_send_z (msg, dest, tag, comm)
24378 COMPLEX(kind=real_8), INTENT(IN) :: msg
24379 INTEGER, INTENT(IN) :: dest, tag
24380 CLASS(mp_comm_type), INTENT(IN) :: comm
24381
24382 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_z'
24383
24384 INTEGER :: handle
24385#if defined(__parallel)
24386 INTEGER :: ierr, msglen
24387#endif
24388
24389 CALL mp_timeset(routinen, handle)
24390
24391#if defined(__parallel)
24392 msglen = 1
24393 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24394 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24395 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24396#else
24397 mark_used(msg)
24398 mark_used(dest)
24399 mark_used(tag)
24400 mark_used(comm)
24401 ! only defined in parallel
24402 cpabort("not in parallel mode")
24403#endif
24404 CALL mp_timestop(handle)
24405 END SUBROUTINE mp_send_z
24406
24407! **************************************************************************************************
24408!> \brief Send rank-1 data to another process
24409!> \param[in] msg Rank-1 data to send
24410!> \param dest ...
24411!> \param tag ...
24412!> \param comm ...
24413!> \note see mp_send_z
24414! **************************************************************************************************
24415 SUBROUTINE mp_send_zv(msg, dest, tag, comm)
24416 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
24417 INTEGER, INTENT(IN) :: dest, tag
24418 CLASS(mp_comm_type), INTENT(IN) :: comm
24419
24420 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_zv'
24421
24422 INTEGER :: handle
24423#if defined(__parallel)
24424 INTEGER :: ierr, msglen
24425#endif
24426
24427 CALL mp_timeset(routinen, handle)
24428
24429#if defined(__parallel)
24430 msglen = SIZE(msg)
24431 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24432 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24433 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24434#else
24435 mark_used(msg)
24436 mark_used(dest)
24437 mark_used(tag)
24438 mark_used(comm)
24439 ! only defined in parallel
24440 cpabort("not in parallel mode")
24441#endif
24442 CALL mp_timestop(handle)
24443 END SUBROUTINE mp_send_zv
24444
24445! **************************************************************************************************
24446!> \brief Send rank-2 data to another process
24447!> \param[in] msg Rank-2 data to send
24448!> \param dest ...
24449!> \param tag ...
24450!> \param comm ...
24451!> \note see mp_send_z
24452! **************************************************************************************************
24453 SUBROUTINE mp_send_zm2(msg, dest, tag, comm)
24454 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
24455 INTEGER, INTENT(IN) :: dest, tag
24456 CLASS(mp_comm_type), INTENT(IN) :: comm
24457
24458 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_zm2'
24459
24460 INTEGER :: handle
24461#if defined(__parallel)
24462 INTEGER :: ierr, msglen
24463#endif
24464
24465 CALL mp_timeset(routinen, handle)
24466
24467#if defined(__parallel)
24468 msglen = SIZE(msg)
24469 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24470 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24471 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24472#else
24473 mark_used(msg)
24474 mark_used(dest)
24475 mark_used(tag)
24476 mark_used(comm)
24477 ! only defined in parallel
24478 cpabort("not in parallel mode")
24479#endif
24480 CALL mp_timestop(handle)
24481 END SUBROUTINE mp_send_zm2
24482
24483! **************************************************************************************************
24484!> \brief Send rank-3 data to another process
24485!> \param[in] msg Rank-3 data to send
24486!> \param dest ...
24487!> \param tag ...
24488!> \param comm ...
24489!> \note see mp_send_z
24490! **************************************************************************************************
24491 SUBROUTINE mp_send_zm3(msg, dest, tag, comm)
24492 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
24493 INTEGER, INTENT(IN) :: dest, tag
24494 CLASS(mp_comm_type), INTENT(IN) :: comm
24495
24496 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
24497
24498 INTEGER :: handle
24499#if defined(__parallel)
24500 INTEGER :: ierr, msglen
24501#endif
24502
24503 CALL mp_timeset(routinen, handle)
24504
24505#if defined(__parallel)
24506 msglen = SIZE(msg)
24507 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24508 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24509 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24510#else
24511 mark_used(msg)
24512 mark_used(dest)
24513 mark_used(tag)
24514 mark_used(comm)
24515 ! only defined in parallel
24516 cpabort("not in parallel mode")
24517#endif
24518 CALL mp_timestop(handle)
24519 END SUBROUTINE mp_send_zm3
24520
24521! **************************************************************************************************
24522!> \brief Receive one datum from another process
24523!> \param[in,out] msg Place received data into this variable
24524!> \param[in,out] source Process to receive from
24525!> \param[in,out] tag Transfer identifier
24526!> \param[in] comm Message passing environment identifier
24527!> \par MPI mapping
24528!> mpi_send
24529! **************************************************************************************************
24530 SUBROUTINE mp_recv_z (msg, source, tag, comm)
24531 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24532 INTEGER, INTENT(INOUT) :: source, tag
24533 CLASS(mp_comm_type), INTENT(IN) :: comm
24534
24535 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_z'
24536
24537 INTEGER :: handle
24538#if defined(__parallel)
24539 INTEGER :: ierr, msglen
24540 mpi_status_type :: status
24541#endif
24542
24543 CALL mp_timeset(routinen, handle)
24544
24545#if defined(__parallel)
24546 msglen = 1
24547 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24548 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24549 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24550 ELSE
24551 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24552 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24553 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24554 source = status mpi_status_extract(mpi_source)
24555 tag = status mpi_status_extract(mpi_tag)
24556 END IF
24557#else
24558 mark_used(msg)
24559 mark_used(source)
24560 mark_used(tag)
24561 mark_used(comm)
24562 ! only defined in parallel
24563 cpabort("not in parallel mode")
24564#endif
24565 CALL mp_timestop(handle)
24566 END SUBROUTINE mp_recv_z
24567
24568! **************************************************************************************************
24569!> \brief Receive rank-1 data from another process
24570!> \param[in,out] msg Place received data into this rank-1 array
24571!> \param source ...
24572!> \param tag ...
24573!> \param comm ...
24574!> \note see mp_recv_z
24575! **************************************************************************************************
24576 SUBROUTINE mp_recv_zv(msg, source, tag, comm)
24577 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24578 INTEGER, INTENT(INOUT) :: source, tag
24579 CLASS(mp_comm_type), INTENT(IN) :: comm
24580
24581 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zv'
24582
24583 INTEGER :: handle
24584#if defined(__parallel)
24585 INTEGER :: ierr, msglen
24586 mpi_status_type :: status
24587#endif
24588
24589 CALL mp_timeset(routinen, handle)
24590
24591#if defined(__parallel)
24592 msglen = SIZE(msg)
24593 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24594 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24595 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24596 ELSE
24597 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24598 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24599 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24600 source = status mpi_status_extract(mpi_source)
24601 tag = status mpi_status_extract(mpi_tag)
24602 END IF
24603#else
24604 mark_used(msg)
24605 mark_used(source)
24606 mark_used(tag)
24607 mark_used(comm)
24608 ! only defined in parallel
24609 cpabort("not in parallel mode")
24610#endif
24611 CALL mp_timestop(handle)
24612 END SUBROUTINE mp_recv_zv
24613
24614! **************************************************************************************************
24615!> \brief Receive rank-2 data from another process
24616!> \param[in,out] msg Place received data into this rank-2 array
24617!> \param source ...
24618!> \param tag ...
24619!> \param comm ...
24620!> \note see mp_recv_z
24621! **************************************************************************************************
24622 SUBROUTINE mp_recv_zm2(msg, source, tag, comm)
24623 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24624 INTEGER, INTENT(INOUT) :: source, tag
24625 CLASS(mp_comm_type), INTENT(IN) :: comm
24626
24627 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zm2'
24628
24629 INTEGER :: handle
24630#if defined(__parallel)
24631 INTEGER :: ierr, msglen
24632 mpi_status_type :: status
24633#endif
24634
24635 CALL mp_timeset(routinen, handle)
24636
24637#if defined(__parallel)
24638 msglen = SIZE(msg)
24639 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24640 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24641 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24642 ELSE
24643 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24644 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24645 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24646 source = status mpi_status_extract(mpi_source)
24647 tag = status mpi_status_extract(mpi_tag)
24648 END IF
24649#else
24650 mark_used(msg)
24651 mark_used(source)
24652 mark_used(tag)
24653 mark_used(comm)
24654 ! only defined in parallel
24655 cpabort("not in parallel mode")
24656#endif
24657 CALL mp_timestop(handle)
24658 END SUBROUTINE mp_recv_zm2
24659
24660! **************************************************************************************************
24661!> \brief Receive rank-3 data from another process
24662!> \param[in,out] msg Place received data into this rank-3 array
24663!> \param source ...
24664!> \param tag ...
24665!> \param comm ...
24666!> \note see mp_recv_z
24667! **************************************************************************************************
24668 SUBROUTINE mp_recv_zm3(msg, source, tag, comm)
24669 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
24670 INTEGER, INTENT(INOUT) :: source, tag
24671 CLASS(mp_comm_type), INTENT(IN) :: comm
24672
24673 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zm3'
24674
24675 INTEGER :: handle
24676#if defined(__parallel)
24677 INTEGER :: ierr, msglen
24678 mpi_status_type :: status
24679#endif
24680
24681 CALL mp_timeset(routinen, handle)
24682
24683#if defined(__parallel)
24684 msglen = SIZE(msg)
24685 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24686 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24687 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24688 ELSE
24689 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24690 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24691 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24692 source = status mpi_status_extract(mpi_source)
24693 tag = status mpi_status_extract(mpi_tag)
24694 END IF
24695#else
24696 mark_used(msg)
24697 mark_used(source)
24698 mark_used(tag)
24699 mark_used(comm)
24700 ! only defined in parallel
24701 cpabort("not in parallel mode")
24702#endif
24703 CALL mp_timestop(handle)
24704 END SUBROUTINE mp_recv_zm3
24705
24706! **************************************************************************************************
24707!> \brief Broadcasts a datum to all processes.
24708!> \param[in] msg Datum to broadcast
24709!> \param[in] source Processes which broadcasts
24710!> \param[in] comm Message passing environment identifier
24711!> \par MPI mapping
24712!> mpi_bcast
24713! **************************************************************************************************
24714 SUBROUTINE mp_bcast_z (msg, source, comm)
24715 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24716 INTEGER, INTENT(IN) :: source
24717 CLASS(mp_comm_type), INTENT(IN) :: comm
24718
24719 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z'
24720
24721 INTEGER :: handle
24722#if defined(__parallel)
24723 INTEGER :: ierr, msglen
24724#endif
24725
24726 CALL mp_timeset(routinen, handle)
24727
24728#if defined(__parallel)
24729 msglen = 1
24730 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24731 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24732 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24733#else
24734 mark_used(msg)
24735 mark_used(source)
24736 mark_used(comm)
24737#endif
24738 CALL mp_timestop(handle)
24739 END SUBROUTINE mp_bcast_z
24740
24741! **************************************************************************************************
24742!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
24743!> \param[in] msg Datum to broadcast
24744!> \param[in] comm Message passing environment identifier
24745!> \par MPI mapping
24746!> mpi_bcast
24747! **************************************************************************************************
24748 SUBROUTINE mp_bcast_z_src(msg, comm)
24749 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24750 CLASS(mp_comm_type), INTENT(IN) :: comm
24751
24752 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z_src'
24753
24754 INTEGER :: handle
24755#if defined(__parallel)
24756 INTEGER :: ierr, msglen
24757#endif
24758
24759 CALL mp_timeset(routinen, handle)
24760
24761#if defined(__parallel)
24762 msglen = 1
24763 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24764 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24765 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24766#else
24767 mark_used(msg)
24768 mark_used(comm)
24769#endif
24770 CALL mp_timestop(handle)
24771 END SUBROUTINE mp_bcast_z_src
24772
24773! **************************************************************************************************
24774!> \brief Broadcasts a datum to all processes.
24775!> \param[in] msg Datum to broadcast
24776!> \param[in] source Processes which broadcasts
24777!> \param[in] comm Message passing environment identifier
24778!> \par MPI mapping
24779!> mpi_bcast
24780! **************************************************************************************************
24781 SUBROUTINE mp_ibcast_z (msg, source, comm, request)
24782 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24783 INTEGER, INTENT(IN) :: source
24784 CLASS(mp_comm_type), INTENT(IN) :: comm
24785 TYPE(mp_request_type), INTENT(OUT) :: request
24786
24787 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_z'
24788
24789 INTEGER :: handle
24790#if defined(__parallel)
24791 INTEGER :: ierr, msglen
24792#endif
24793
24794 CALL mp_timeset(routinen, handle)
24795
24796#if defined(__parallel)
24797 msglen = 1
24798 CALL mpi_ibcast(msg, msglen, mpi_double_complex, source, comm%handle, request%handle, ierr)
24799 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
24800 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_8_size))
24801#else
24802 mark_used(msg)
24803 mark_used(source)
24804 mark_used(comm)
24805 request = mp_request_null
24806#endif
24807 CALL mp_timestop(handle)
24808 END SUBROUTINE mp_ibcast_z
24809
24810! **************************************************************************************************
24811!> \brief Broadcasts rank-1 data to all processes
24812!> \param[in] msg Data to broadcast
24813!> \param source ...
24814!> \param comm ...
24815!> \note see mp_bcast_z1
24816! **************************************************************************************************
24817 SUBROUTINE mp_bcast_zv(msg, source, comm)
24818 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24819 INTEGER, INTENT(IN) :: source
24820 CLASS(mp_comm_type), INTENT(IN) :: comm
24821
24822 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zv'
24823
24824 INTEGER :: handle
24825#if defined(__parallel)
24826 INTEGER :: ierr, msglen
24827#endif
24828
24829 CALL mp_timeset(routinen, handle)
24830
24831#if defined(__parallel)
24832 msglen = SIZE(msg)
24833 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24834 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24835 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24836#else
24837 mark_used(msg)
24838 mark_used(source)
24839 mark_used(comm)
24840#endif
24841 CALL mp_timestop(handle)
24842 END SUBROUTINE mp_bcast_zv
24843
24844! **************************************************************************************************
24845!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
24846!> \param[in] msg Data to broadcast
24847!> \param comm ...
24848!> \note see mp_bcast_z1
24849! **************************************************************************************************
24850 SUBROUTINE mp_bcast_zv_src(msg, comm)
24851 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24852 CLASS(mp_comm_type), INTENT(IN) :: comm
24853
24854 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zv_src'
24855
24856 INTEGER :: handle
24857#if defined(__parallel)
24858 INTEGER :: ierr, msglen
24859#endif
24860
24861 CALL mp_timeset(routinen, handle)
24862
24863#if defined(__parallel)
24864 msglen = SIZE(msg)
24865 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24866 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24867 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24868#else
24869 mark_used(msg)
24870 mark_used(comm)
24871#endif
24872 CALL mp_timestop(handle)
24873 END SUBROUTINE mp_bcast_zv_src
24874
24875! **************************************************************************************************
24876!> \brief Broadcasts rank-1 data to all processes
24877!> \param[in] msg Data to broadcast
24878!> \param source ...
24879!> \param comm ...
24880!> \note see mp_bcast_z1
24881! **************************************************************************************************
24882 SUBROUTINE mp_ibcast_zv(msg, source, comm, request)
24883 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
24884 INTEGER, INTENT(IN) :: source
24885 CLASS(mp_comm_type), INTENT(IN) :: comm
24886 TYPE(mp_request_type) :: request
24887
24888 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_zv'
24889
24890 INTEGER :: handle
24891#if defined(__parallel)
24892 INTEGER :: ierr, msglen
24893#endif
24894
24895 CALL mp_timeset(routinen, handle)
24896
24897#if defined(__parallel)
24898#if !defined(__GNUC__) || __GNUC__ >= 9
24899 cpassert(is_contiguous(msg))
24900#endif
24901 msglen = SIZE(msg)
24902 CALL mpi_ibcast(msg, msglen, mpi_double_complex, source, comm%handle, request%handle, ierr)
24903 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
24904 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_8_size))
24905#else
24906 mark_used(msg)
24907 mark_used(source)
24908 mark_used(comm)
24909 request = mp_request_null
24910#endif
24911 CALL mp_timestop(handle)
24912 END SUBROUTINE mp_ibcast_zv
24913
24914! **************************************************************************************************
24915!> \brief Broadcasts rank-2 data to all processes
24916!> \param[in] msg Data to broadcast
24917!> \param source ...
24918!> \param comm ...
24919!> \note see mp_bcast_z1
24920! **************************************************************************************************
24921 SUBROUTINE mp_bcast_zm(msg, source, comm)
24922 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24923 INTEGER, INTENT(IN) :: source
24924 CLASS(mp_comm_type), INTENT(IN) :: comm
24925
24926 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zm'
24927
24928 INTEGER :: handle
24929#if defined(__parallel)
24930 INTEGER :: ierr, msglen
24931#endif
24932
24933 CALL mp_timeset(routinen, handle)
24934
24935#if defined(__parallel)
24936 msglen = SIZE(msg)
24937 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24938 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24939 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24940#else
24941 mark_used(msg)
24942 mark_used(source)
24943 mark_used(comm)
24944#endif
24945 CALL mp_timestop(handle)
24946 END SUBROUTINE mp_bcast_zm
24947
24948! **************************************************************************************************
24949!> \brief Broadcasts rank-2 data to all processes
24950!> \param[in] msg Data to broadcast
24951!> \param source ...
24952!> \param comm ...
24953!> \note see mp_bcast_z1
24954! **************************************************************************************************
24955 SUBROUTINE mp_bcast_zm_src(msg, comm)
24956 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24957 CLASS(mp_comm_type), INTENT(IN) :: comm
24958
24959 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zm_src'
24960
24961 INTEGER :: handle
24962#if defined(__parallel)
24963 INTEGER :: ierr, msglen
24964#endif
24965
24966 CALL mp_timeset(routinen, handle)
24967
24968#if defined(__parallel)
24969 msglen = SIZE(msg)
24970 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24971 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24972 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24973#else
24974 mark_used(msg)
24975 mark_used(comm)
24976#endif
24977 CALL mp_timestop(handle)
24978 END SUBROUTINE mp_bcast_zm_src
24979
24980! **************************************************************************************************
24981!> \brief Broadcasts rank-3 data to all processes
24982!> \param[in] msg Data to broadcast
24983!> \param source ...
24984!> \param comm ...
24985!> \note see mp_bcast_z1
24986! **************************************************************************************************
24987 SUBROUTINE mp_bcast_z3(msg, source, comm)
24988 COMPLEX(kind=real_8), CONTIGUOUS :: msg(:, :, :)
24989 INTEGER, INTENT(IN) :: source
24990 CLASS(mp_comm_type), INTENT(IN) :: comm
24991
24992 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z3'
24993
24994 INTEGER :: handle
24995#if defined(__parallel)
24996 INTEGER :: ierr, msglen
24997#endif
24998
24999 CALL mp_timeset(routinen, handle)
25000
25001#if defined(__parallel)
25002 msglen = SIZE(msg)
25003 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
25004 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25005 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25006#else
25007 mark_used(msg)
25008 mark_used(source)
25009 mark_used(comm)
25010#endif
25011 CALL mp_timestop(handle)
25012 END SUBROUTINE mp_bcast_z3
25013
25014! **************************************************************************************************
25015!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
25016!> \param[in] msg Data to broadcast
25017!> \param source ...
25018!> \param comm ...
25019!> \note see mp_bcast_z1
25020! **************************************************************************************************
25021 SUBROUTINE mp_bcast_z3_src(msg, comm)
25022 COMPLEX(kind=real_8), CONTIGUOUS :: msg(:, :, :)
25023 CLASS(mp_comm_type), INTENT(IN) :: comm
25024
25025 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z3_src'
25026
25027 INTEGER :: handle
25028#if defined(__parallel)
25029 INTEGER :: ierr, msglen
25030#endif
25031
25032 CALL mp_timeset(routinen, handle)
25033
25034#if defined(__parallel)
25035 msglen = SIZE(msg)
25036 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25037 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25038 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25039#else
25040 mark_used(msg)
25041 mark_used(comm)
25042#endif
25043 CALL mp_timestop(handle)
25044 END SUBROUTINE mp_bcast_z3_src
25045
25046! **************************************************************************************************
25047!> \brief Sums a datum from all processes with result left on all processes.
25048!> \param[in,out] msg Datum to sum (input) and result (output)
25049!> \param[in] comm Message passing environment identifier
25050!> \par MPI mapping
25051!> mpi_allreduce
25052! **************************************************************************************************
25053 SUBROUTINE mp_sum_z (msg, comm)
25054 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25055 CLASS(mp_comm_type), INTENT(IN) :: comm
25056
25057 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_z'
25058
25059 INTEGER :: handle
25060#if defined(__parallel)
25061 INTEGER :: ierr, msglen
25062#endif
25063
25064 CALL mp_timeset(routinen, handle)
25065
25066#if defined(__parallel)
25067 msglen = 1
25068 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25069 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25070 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25071#else
25072 mark_used(msg)
25073 mark_used(comm)
25074#endif
25075 CALL mp_timestop(handle)
25076 END SUBROUTINE mp_sum_z
25077
25078! **************************************************************************************************
25079!> \brief Element-wise sum of a rank-1 array on all processes.
25080!> \param[in,out] msg Vector to sum and result
25081!> \param comm ...
25082!> \note see mp_sum_z
25083! **************************************************************************************************
25084 SUBROUTINE mp_sum_zv(msg, comm)
25085 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25086 CLASS(mp_comm_type), INTENT(IN) :: comm
25087
25088 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zv'
25089
25090 INTEGER :: handle
25091#if defined(__parallel)
25092 INTEGER :: ierr, msglen
25093#endif
25094
25095 CALL mp_timeset(routinen, handle)
25096
25097#if defined(__parallel)
25098 msglen = SIZE(msg)
25099 IF (msglen > 0) THEN
25100 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25101 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25102 END IF
25103 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25104#else
25105 mark_used(msg)
25106 mark_used(comm)
25107#endif
25108 CALL mp_timestop(handle)
25109 END SUBROUTINE mp_sum_zv
25110
25111! **************************************************************************************************
25112!> \brief Element-wise sum of a rank-1 array on all processes.
25113!> \param[in,out] msg Vector to sum and result
25114!> \param comm ...
25115!> \note see mp_sum_z
25116! **************************************************************************************************
25117 SUBROUTINE mp_isum_zv(msg, comm, request)
25118 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25119 CLASS(mp_comm_type), INTENT(IN) :: comm
25120 TYPE(mp_request_type), INTENT(OUT) :: request
25121
25122 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_zv'
25123
25124 INTEGER :: handle
25125#if defined(__parallel)
25126 INTEGER :: ierr, msglen
25127#endif
25128
25129 CALL mp_timeset(routinen, handle)
25130
25131#if defined(__parallel)
25132#if !defined(__GNUC__) || __GNUC__ >= 9
25133 cpassert(is_contiguous(msg))
25134#endif
25135 msglen = SIZE(msg)
25136 IF (msglen > 0) THEN
25137 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, request%handle, ierr)
25138 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
25139 ELSE
25140 request = mp_request_null
25141 END IF
25142 CALL add_perf(perf_id=23, count=1, msg_size=msglen*(2*real_8_size))
25143#else
25144 mark_used(msg)
25145 mark_used(comm)
25146 request = mp_request_null
25147#endif
25148 CALL mp_timestop(handle)
25149 END SUBROUTINE mp_isum_zv
25150
25151! **************************************************************************************************
25152!> \brief Element-wise sum of a rank-2 array on all processes.
25153!> \param[in] msg Matrix to sum and result
25154!> \param comm ...
25155!> \note see mp_sum_z
25156! **************************************************************************************************
25157 SUBROUTINE mp_sum_zm(msg, comm)
25158 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25159 CLASS(mp_comm_type), INTENT(IN) :: comm
25160
25161 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm'
25162
25163 INTEGER :: handle
25164#if defined(__parallel)
25165 INTEGER, PARAMETER :: max_msg = 2**25
25166 INTEGER :: ierr, m1, msglen, step, msglensum
25167#endif
25168
25169 CALL mp_timeset(routinen, handle)
25170
25171#if defined(__parallel)
25172 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
25173 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
25174 msglensum = 0
25175 DO m1 = lbound(msg, 2), ubound(msg, 2), step
25176 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
25177 msglensum = msglensum + msglen
25178 IF (msglen > 0) THEN
25179 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25180 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25181 END IF
25182 END DO
25183 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_8_size))
25184#else
25185 mark_used(msg)
25186 mark_used(comm)
25187#endif
25188 CALL mp_timestop(handle)
25189 END SUBROUTINE mp_sum_zm
25190
25191! **************************************************************************************************
25192!> \brief Element-wise sum of a rank-3 array on all processes.
25193!> \param[in] msg Array to sum and result
25194!> \param comm ...
25195!> \note see mp_sum_z
25196! **************************************************************************************************
25197 SUBROUTINE mp_sum_zm3(msg, comm)
25198 COMPLEX(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
25199 CLASS(mp_comm_type), INTENT(IN) :: comm
25200
25201 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm3'
25202
25203 INTEGER :: handle
25204#if defined(__parallel)
25205 INTEGER :: ierr, msglen
25206#endif
25207
25208 CALL mp_timeset(routinen, handle)
25209
25210#if defined(__parallel)
25211 msglen = SIZE(msg)
25212 IF (msglen > 0) THEN
25213 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25214 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25215 END IF
25216 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25217#else
25218 mark_used(msg)
25219 mark_used(comm)
25220#endif
25221 CALL mp_timestop(handle)
25222 END SUBROUTINE mp_sum_zm3
25223
25224! **************************************************************************************************
25225!> \brief Element-wise sum of a rank-4 array on all processes.
25226!> \param[in] msg Array to sum and result
25227!> \param comm ...
25228!> \note see mp_sum_z
25229! **************************************************************************************************
25230 SUBROUTINE mp_sum_zm4(msg, comm)
25231 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
25232 CLASS(mp_comm_type), INTENT(IN) :: comm
25233
25234 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm4'
25235
25236 INTEGER :: handle
25237#if defined(__parallel)
25238 INTEGER :: ierr, msglen
25239#endif
25240
25241 CALL mp_timeset(routinen, handle)
25242
25243#if defined(__parallel)
25244 msglen = SIZE(msg)
25245 IF (msglen > 0) THEN
25246 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25247 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25248 END IF
25249 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25250#else
25251 mark_used(msg)
25252 mark_used(comm)
25253#endif
25254 CALL mp_timestop(handle)
25255 END SUBROUTINE mp_sum_zm4
25256
25257! **************************************************************************************************
25258!> \brief Element-wise sum of data from all processes with result left only on
25259!> one.
25260!> \param[in,out] msg Vector to sum (input) and (only on process root)
25261!> result (output)
25262!> \param root ...
25263!> \param[in] comm Message passing environment identifier
25264!> \par MPI mapping
25265!> mpi_reduce
25266! **************************************************************************************************
25267 SUBROUTINE mp_sum_root_zv(msg, root, comm)
25268 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25269 INTEGER, INTENT(IN) :: root
25270 CLASS(mp_comm_type), INTENT(IN) :: comm
25271
25272 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_zv'
25273
25274 INTEGER :: handle
25275#if defined(__parallel)
25276 INTEGER :: ierr, m1, msglen, taskid
25277 COMPLEX(kind=real_8), ALLOCATABLE :: res(:)
25278#endif
25279
25280 CALL mp_timeset(routinen, handle)
25281
25282#if defined(__parallel)
25283 msglen = SIZE(msg)
25284 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25285 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25286 IF (msglen > 0) THEN
25287 m1 = SIZE(msg, 1)
25288 ALLOCATE (res(m1))
25289 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_sum, &
25290 root, comm%handle, ierr)
25291 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25292 IF (taskid == root) THEN
25293 msg = res
25294 END IF
25295 DEALLOCATE (res)
25296 END IF
25297 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25298#else
25299 mark_used(msg)
25300 mark_used(root)
25301 mark_used(comm)
25302#endif
25303 CALL mp_timestop(handle)
25304 END SUBROUTINE mp_sum_root_zv
25305
25306! **************************************************************************************************
25307!> \brief Element-wise sum of data from all processes with result left only on
25308!> one.
25309!> \param[in,out] msg Matrix to sum (input) and (only on process root)
25310!> result (output)
25311!> \param root ...
25312!> \param comm ...
25313!> \note see mp_sum_root_zv
25314! **************************************************************************************************
25315 SUBROUTINE mp_sum_root_zm(msg, root, comm)
25316 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25317 INTEGER, INTENT(IN) :: root
25318 CLASS(mp_comm_type), INTENT(IN) :: comm
25319
25320 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
25321
25322 INTEGER :: handle
25323#if defined(__parallel)
25324 INTEGER :: ierr, m1, m2, msglen, taskid
25325 COMPLEX(kind=real_8), ALLOCATABLE :: res(:, :)
25326#endif
25327
25328 CALL mp_timeset(routinen, handle)
25329
25330#if defined(__parallel)
25331 msglen = SIZE(msg)
25332 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25333 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25334 IF (msglen > 0) THEN
25335 m1 = SIZE(msg, 1)
25336 m2 = SIZE(msg, 2)
25337 ALLOCATE (res(m1, m2))
25338 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_sum, root, comm%handle, ierr)
25339 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25340 IF (taskid == root) THEN
25341 msg = res
25342 END IF
25343 DEALLOCATE (res)
25344 END IF
25345 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25346#else
25347 mark_used(root)
25348 mark_used(msg)
25349 mark_used(comm)
25350#endif
25351 CALL mp_timestop(handle)
25352 END SUBROUTINE mp_sum_root_zm
25353
25354! **************************************************************************************************
25355!> \brief Partial sum of data from all processes with result on each process.
25356!> \param[in] msg Matrix to sum (input)
25357!> \param[out] res Matrix containing result (output)
25358!> \param[in] comm Message passing environment identifier
25359! **************************************************************************************************
25360 SUBROUTINE mp_sum_partial_zm(msg, res, comm)
25361 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
25362 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
25363 CLASS(mp_comm_type), INTENT(IN) :: comm
25364
25365 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_zm'
25366
25367 INTEGER :: handle
25368#if defined(__parallel)
25369 INTEGER :: ierr, msglen, taskid
25370#endif
25371
25372 CALL mp_timeset(routinen, handle)
25373
25374#if defined(__parallel)
25375 msglen = SIZE(msg)
25376 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25377 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25378 IF (msglen > 0) THEN
25379 CALL mpi_scan(msg, res, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25380 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
25381 END IF
25382 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25383 ! perf_id is same as for other summation routines
25384#else
25385 res = msg
25386 mark_used(comm)
25387#endif
25388 CALL mp_timestop(handle)
25389 END SUBROUTINE mp_sum_partial_zm
25390
25391! **************************************************************************************************
25392!> \brief Finds the maximum of a datum with the result left on all processes.
25393!> \param[in,out] msg Find maximum among these data (input) and
25394!> maximum (output)
25395!> \param[in] comm Message passing environment identifier
25396!> \par MPI mapping
25397!> mpi_allreduce
25398! **************************************************************************************************
25399 SUBROUTINE mp_max_z (msg, comm)
25400 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25401 CLASS(mp_comm_type), INTENT(IN) :: comm
25402
25403 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_z'
25404
25405 INTEGER :: handle
25406#if defined(__parallel)
25407 INTEGER :: ierr, msglen
25408#endif
25409
25410 CALL mp_timeset(routinen, handle)
25411
25412#if defined(__parallel)
25413 msglen = 1
25414 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25415 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25416 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25417#else
25418 mark_used(msg)
25419 mark_used(comm)
25420#endif
25421 CALL mp_timestop(handle)
25422 END SUBROUTINE mp_max_z
25423
25424! **************************************************************************************************
25425!> \brief Finds the maximum of a datum with the result left on all processes.
25426!> \param[in,out] msg Find maximum among these data (input) and
25427!> maximum (output)
25428!> \param[in] comm Message passing environment identifier
25429!> \par MPI mapping
25430!> mpi_allreduce
25431! **************************************************************************************************
25432 SUBROUTINE mp_max_root_z (msg, root, comm)
25433 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25434 INTEGER, INTENT(IN) :: root
25435 CLASS(mp_comm_type), INTENT(IN) :: comm
25436
25437 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_z'
25438
25439 INTEGER :: handle
25440#if defined(__parallel)
25441 INTEGER :: ierr, msglen
25442 COMPLEX(kind=real_8) :: res
25443#endif
25444
25445 CALL mp_timeset(routinen, handle)
25446
25447#if defined(__parallel)
25448 msglen = 1
25449 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_max, root, comm%handle, ierr)
25450 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25451 IF (root == comm%mepos) msg = res
25452 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25453#else
25454 mark_used(msg)
25455 mark_used(comm)
25456 mark_used(root)
25457#endif
25458 CALL mp_timestop(handle)
25459 END SUBROUTINE mp_max_root_z
25460
25461! **************************************************************************************************
25462!> \brief Finds the element-wise maximum of a vector with the result left on
25463!> all processes.
25464!> \param[in,out] msg Find maximum among these data (input) and
25465!> maximum (output)
25466!> \param comm ...
25467!> \note see mp_max_z
25468! **************************************************************************************************
25469 SUBROUTINE mp_max_zv(msg, comm)
25470 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25471 CLASS(mp_comm_type), INTENT(IN) :: comm
25472
25473 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_zv'
25474
25475 INTEGER :: handle
25476#if defined(__parallel)
25477 INTEGER :: ierr, msglen
25478#endif
25479
25480 CALL mp_timeset(routinen, handle)
25481
25482#if defined(__parallel)
25483 msglen = SIZE(msg)
25484 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25485 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25486 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25487#else
25488 mark_used(msg)
25489 mark_used(comm)
25490#endif
25491 CALL mp_timestop(handle)
25492 END SUBROUTINE mp_max_zv
25493
25494! **************************************************************************************************
25495!> \brief Finds the element-wise maximum of a vector with the result left on
25496!> all processes.
25497!> \param[in,out] msg Find maximum among these data (input) and
25498!> maximum (output)
25499!> \param comm ...
25500!> \note see mp_max_z
25501! **************************************************************************************************
25502 SUBROUTINE mp_max_root_zm(msg, root, comm)
25503 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25504 INTEGER :: root
25505 CLASS(mp_comm_type), INTENT(IN) :: comm
25506
25507 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_zm'
25508
25509 INTEGER :: handle
25510#if defined(__parallel)
25511 INTEGER :: ierr, msglen
25512 COMPLEX(kind=real_8) :: res(size(msg, 1), size(msg, 2))
25513#endif
25514
25515 CALL mp_timeset(routinen, handle)
25516
25517#if defined(__parallel)
25518 msglen = SIZE(msg)
25519 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_max, root, comm%handle, ierr)
25520 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25521 IF (root == comm%mepos) msg = res
25522 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25523#else
25524 mark_used(msg)
25525 mark_used(comm)
25526 mark_used(root)
25527#endif
25528 CALL mp_timestop(handle)
25529 END SUBROUTINE mp_max_root_zm
25530
25531! **************************************************************************************************
25532!> \brief Finds the minimum of a datum with the result left on all processes.
25533!> \param[in,out] msg Find minimum among these data (input) and
25534!> maximum (output)
25535!> \param[in] comm Message passing environment identifier
25536!> \par MPI mapping
25537!> mpi_allreduce
25538! **************************************************************************************************
25539 SUBROUTINE mp_min_z (msg, comm)
25540 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25541 CLASS(mp_comm_type), INTENT(IN) :: comm
25542
25543 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_z'
25544
25545 INTEGER :: handle
25546#if defined(__parallel)
25547 INTEGER :: ierr, msglen
25548#endif
25549
25550 CALL mp_timeset(routinen, handle)
25551
25552#if defined(__parallel)
25553 msglen = 1
25554 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
25555 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25556 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25557#else
25558 mark_used(msg)
25559 mark_used(comm)
25560#endif
25561 CALL mp_timestop(handle)
25562 END SUBROUTINE mp_min_z
25563
25564! **************************************************************************************************
25565!> \brief Finds the element-wise minimum of vector with the result left on
25566!> all processes.
25567!> \param[in,out] msg Find minimum among these data (input) and
25568!> maximum (output)
25569!> \param comm ...
25570!> \par MPI mapping
25571!> mpi_allreduce
25572!> \note see mp_min_z
25573! **************************************************************************************************
25574 SUBROUTINE mp_min_zv(msg, comm)
25575 COMPLEX(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
25576 CLASS(mp_comm_type), INTENT(IN) :: comm
25577
25578 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_zv'
25579
25580 INTEGER :: handle
25581#if defined(__parallel)
25582 INTEGER :: ierr, msglen
25583#endif
25584
25585 CALL mp_timeset(routinen, handle)
25586
25587#if defined(__parallel)
25588 msglen = SIZE(msg)
25589 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
25590 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25591 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25592#else
25593 mark_used(msg)
25594 mark_used(comm)
25595#endif
25596 CALL mp_timestop(handle)
25597 END SUBROUTINE mp_min_zv
25598
25599! **************************************************************************************************
25600!> \brief Multiplies a set of numbers scattered across a number of processes,
25601!> then replicates the result.
25602!> \param[in,out] msg a number to multiply (input) and result (output)
25603!> \param[in] comm message passing environment identifier
25604!> \par MPI mapping
25605!> mpi_allreduce
25606! **************************************************************************************************
25607 SUBROUTINE mp_prod_z (msg, comm)
25608 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25609 CLASS(mp_comm_type), INTENT(IN) :: comm
25610
25611 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_z'
25612
25613 INTEGER :: handle
25614#if defined(__parallel)
25615 INTEGER :: ierr, msglen
25616#endif
25617
25618 CALL mp_timeset(routinen, handle)
25619
25620#if defined(__parallel)
25621 msglen = 1
25622 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_prod, comm%handle, ierr)
25623 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25624 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25625#else
25626 mark_used(msg)
25627 mark_used(comm)
25628#endif
25629 CALL mp_timestop(handle)
25630 END SUBROUTINE mp_prod_z
25631
25632! **************************************************************************************************
25633!> \brief Scatters data from one processes to all others
25634!> \param[in] msg_scatter Data to scatter (for root process)
25635!> \param[out] msg Received data
25636!> \param[in] root Process which scatters data
25637!> \param[in] comm Message passing environment identifier
25638!> \par MPI mapping
25639!> mpi_scatter
25640! **************************************************************************************************
25641 SUBROUTINE mp_scatter_zv(msg_scatter, msg, root, comm)
25642 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
25643 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
25644 INTEGER, INTENT(IN) :: root
25645 CLASS(mp_comm_type), INTENT(IN) :: comm
25646
25647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_zv'
25648
25649 INTEGER :: handle
25650#if defined(__parallel)
25651 INTEGER :: ierr, msglen
25652#endif
25653
25654 CALL mp_timeset(routinen, handle)
25655
25656#if defined(__parallel)
25657 msglen = SIZE(msg)
25658 CALL mpi_scatter(msg_scatter, msglen, mpi_double_complex, msg, &
25659 msglen, mpi_double_complex, root, comm%handle, ierr)
25660 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
25661 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25662#else
25663 mark_used(root)
25664 mark_used(comm)
25665 msg = msg_scatter
25666#endif
25667 CALL mp_timestop(handle)
25668 END SUBROUTINE mp_scatter_zv
25669
25670! **************************************************************************************************
25671!> \brief Scatters data from one processes to all others
25672!> \param[in] msg_scatter Data to scatter (for root process)
25673!> \param[in] root Process which scatters data
25674!> \param[in] comm Message passing environment identifier
25675!> \par MPI mapping
25676!> mpi_scatter
25677! **************************************************************************************************
25678 SUBROUTINE mp_iscatter_z (msg_scatter, msg, root, comm, request)
25679 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:)
25680 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25681 INTEGER, INTENT(IN) :: root
25682 CLASS(mp_comm_type), INTENT(IN) :: comm
25683 TYPE(mp_request_type), INTENT(OUT) :: request
25684
25685 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_z'
25686
25687 INTEGER :: handle
25688#if defined(__parallel)
25689 INTEGER :: ierr, msglen
25690#endif
25691
25692 CALL mp_timeset(routinen, handle)
25693
25694#if defined(__parallel)
25695#if !defined(__GNUC__) || __GNUC__ >= 9
25696 cpassert(is_contiguous(msg_scatter))
25697#endif
25698 msglen = 1
25699 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_complex, msg, &
25700 msglen, mpi_double_complex, root, comm%handle, request%handle, ierr)
25701 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
25702 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25703#else
25704 mark_used(root)
25705 mark_used(comm)
25706 msg = msg_scatter(1)
25707 request = mp_request_null
25708#endif
25709 CALL mp_timestop(handle)
25710 END SUBROUTINE mp_iscatter_z
25711
25712! **************************************************************************************************
25713!> \brief Scatters data from one processes to all others
25714!> \param[in] msg_scatter Data to scatter (for root process)
25715!> \param[in] root Process which scatters data
25716!> \param[in] comm Message passing environment identifier
25717!> \par MPI mapping
25718!> mpi_scatter
25719! **************************************************************************************************
25720 SUBROUTINE mp_iscatter_zv2(msg_scatter, msg, root, comm, request)
25721 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:, :)
25722 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25723 INTEGER, INTENT(IN) :: root
25724 CLASS(mp_comm_type), INTENT(IN) :: comm
25725 TYPE(mp_request_type), INTENT(OUT) :: request
25726
25727 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_zv2'
25728
25729 INTEGER :: handle
25730#if defined(__parallel)
25731 INTEGER :: ierr, msglen
25732#endif
25733
25734 CALL mp_timeset(routinen, handle)
25735
25736#if defined(__parallel)
25737#if !defined(__GNUC__) || __GNUC__ >= 9
25738 cpassert(is_contiguous(msg_scatter))
25739#endif
25740 msglen = SIZE(msg)
25741 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_complex, msg, &
25742 msglen, mpi_double_complex, root, comm%handle, request%handle, ierr)
25743 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
25744 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25745#else
25746 mark_used(root)
25747 mark_used(comm)
25748 msg(:) = msg_scatter(:, 1)
25749 request = mp_request_null
25750#endif
25751 CALL mp_timestop(handle)
25752 END SUBROUTINE mp_iscatter_zv2
25753
25754! **************************************************************************************************
25755!> \brief Scatters data from one processes to all others
25756!> \param[in] msg_scatter Data to scatter (for root process)
25757!> \param[in] root Process which scatters data
25758!> \param[in] comm Message passing environment identifier
25759!> \par MPI mapping
25760!> mpi_scatter
25761! **************************************************************************************************
25762 SUBROUTINE mp_iscatterv_zv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
25763 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:)
25764 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
25765 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25766 INTEGER, INTENT(IN) :: recvcount, root
25767 CLASS(mp_comm_type), INTENT(IN) :: comm
25768 TYPE(mp_request_type), INTENT(OUT) :: request
25769
25770 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_zv'
25771
25772 INTEGER :: handle
25773#if defined(__parallel)
25774 INTEGER :: ierr
25775#endif
25776
25777 CALL mp_timeset(routinen, handle)
25778
25779#if defined(__parallel)
25780#if !defined(__GNUC__) || __GNUC__ >= 9
25781 cpassert(is_contiguous(msg_scatter))
25782 cpassert(is_contiguous(msg))
25783 cpassert(is_contiguous(sendcounts))
25784 cpassert(is_contiguous(displs))
25785#endif
25786 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_double_complex, msg, &
25787 recvcount, mpi_double_complex, root, comm%handle, request%handle, ierr)
25788 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
25789 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25790#else
25791 mark_used(sendcounts)
25792 mark_used(displs)
25793 mark_used(recvcount)
25794 mark_used(root)
25795 mark_used(comm)
25796 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
25797 request = mp_request_null
25798#endif
25799 CALL mp_timestop(handle)
25800 END SUBROUTINE mp_iscatterv_zv
25801
25802! **************************************************************************************************
25803!> \brief Gathers a datum from all processes to one
25804!> \param[in] msg Datum to send to root
25805!> \param[out] msg_gather Received data (on root)
25806!> \param[in] root Process which gathers the data
25807!> \param[in] comm Message passing environment identifier
25808!> \par MPI mapping
25809!> mpi_gather
25810! **************************************************************************************************
25811 SUBROUTINE mp_gather_z (msg, msg_gather, root, comm)
25812 COMPLEX(kind=real_8), INTENT(IN) :: msg
25813 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25814 INTEGER, INTENT(IN) :: root
25815 CLASS(mp_comm_type), INTENT(IN) :: comm
25816
25817 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_z'
25818
25819 INTEGER :: handle
25820#if defined(__parallel)
25821 INTEGER :: ierr, msglen
25822#endif
25823
25824 CALL mp_timeset(routinen, handle)
25825
25826#if defined(__parallel)
25827 msglen = 1
25828 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25829 msglen, mpi_double_complex, root, comm%handle, ierr)
25830 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25831 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25832#else
25833 mark_used(root)
25834 mark_used(comm)
25835 msg_gather(1) = msg
25836#endif
25837 CALL mp_timestop(handle)
25838 END SUBROUTINE mp_gather_z
25839
25840! **************************************************************************************************
25841!> \brief Gathers a datum from all processes to one, uses the source process of comm
25842!> \param[in] msg Datum to send to root
25843!> \param[out] msg_gather Received data (on root)
25844!> \param[in] comm Message passing environment identifier
25845!> \par MPI mapping
25846!> mpi_gather
25847! **************************************************************************************************
25848 SUBROUTINE mp_gather_z_src(msg, msg_gather, comm)
25849 COMPLEX(kind=real_8), INTENT(IN) :: msg
25850 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25851 CLASS(mp_comm_type), INTENT(IN) :: comm
25852
25853 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_z_src'
25854
25855 INTEGER :: handle
25856#if defined(__parallel)
25857 INTEGER :: ierr, msglen
25858#endif
25859
25860 CALL mp_timeset(routinen, handle)
25861
25862#if defined(__parallel)
25863 msglen = 1
25864 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25865 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25866 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25867 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25868#else
25869 mark_used(comm)
25870 msg_gather(1) = msg
25871#endif
25872 CALL mp_timestop(handle)
25873 END SUBROUTINE mp_gather_z_src
25874
25875! **************************************************************************************************
25876!> \brief Gathers data from all processes to one
25877!> \param[in] msg Datum to send to root
25878!> \param msg_gather ...
25879!> \param root ...
25880!> \param comm ...
25881!> \par Data length
25882!> All data (msg) is equal-sized
25883!> \par MPI mapping
25884!> mpi_gather
25885!> \note see mp_gather_z
25886! **************************************************************************************************
25887 SUBROUTINE mp_gather_zv(msg, msg_gather, root, comm)
25888 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
25889 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25890 INTEGER, INTENT(IN) :: root
25891 CLASS(mp_comm_type), INTENT(IN) :: comm
25892
25893 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zv'
25894
25895 INTEGER :: handle
25896#if defined(__parallel)
25897 INTEGER :: ierr, msglen
25898#endif
25899
25900 CALL mp_timeset(routinen, handle)
25901
25902#if defined(__parallel)
25903 msglen = SIZE(msg)
25904 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25905 msglen, mpi_double_complex, root, comm%handle, ierr)
25906 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25907 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25908#else
25909 mark_used(root)
25910 mark_used(comm)
25911 msg_gather = msg
25912#endif
25913 CALL mp_timestop(handle)
25914 END SUBROUTINE mp_gather_zv
25915
25916! **************************************************************************************************
25917!> \brief Gathers data from all processes to one. Gathers from comm%source
25918!> \param[in] msg Datum to send to root
25919!> \param msg_gather ...
25920!> \param comm ...
25921!> \par Data length
25922!> All data (msg) is equal-sized
25923!> \par MPI mapping
25924!> mpi_gather
25925!> \note see mp_gather_z
25926! **************************************************************************************************
25927 SUBROUTINE mp_gather_zv_src(msg, msg_gather, comm)
25928 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
25929 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25930 CLASS(mp_comm_type), INTENT(IN) :: comm
25931
25932 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zv_src'
25933
25934 INTEGER :: handle
25935#if defined(__parallel)
25936 INTEGER :: ierr, msglen
25937#endif
25938
25939 CALL mp_timeset(routinen, handle)
25940
25941#if defined(__parallel)
25942 msglen = SIZE(msg)
25943 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25944 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25945 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25946 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25947#else
25948 mark_used(comm)
25949 msg_gather = msg
25950#endif
25951 CALL mp_timestop(handle)
25952 END SUBROUTINE mp_gather_zv_src
25953
25954! **************************************************************************************************
25955!> \brief Gathers data from all processes to one
25956!> \param[in] msg Datum to send to root
25957!> \param msg_gather ...
25958!> \param root ...
25959!> \param comm ...
25960!> \par Data length
25961!> All data (msg) is equal-sized
25962!> \par MPI mapping
25963!> mpi_gather
25964!> \note see mp_gather_z
25965! **************************************************************************************************
25966 SUBROUTINE mp_gather_zm(msg, msg_gather, root, comm)
25967 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
25968 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
25969 INTEGER, INTENT(IN) :: root
25970 CLASS(mp_comm_type), INTENT(IN) :: comm
25971
25972 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zm'
25973
25974 INTEGER :: handle
25975#if defined(__parallel)
25976 INTEGER :: ierr, msglen
25977#endif
25978
25979 CALL mp_timeset(routinen, handle)
25980
25981#if defined(__parallel)
25982 msglen = SIZE(msg)
25983 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25984 msglen, mpi_double_complex, root, comm%handle, ierr)
25985 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25986 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25987#else
25988 mark_used(root)
25989 mark_used(comm)
25990 msg_gather = msg
25991#endif
25992 CALL mp_timestop(handle)
25993 END SUBROUTINE mp_gather_zm
25994
25995! **************************************************************************************************
25996!> \brief Gathers data from all processes to one. Gathers from comm%source
25997!> \param[in] msg Datum to send to root
25998!> \param msg_gather ...
25999!> \param comm ...
26000!> \par Data length
26001!> All data (msg) is equal-sized
26002!> \par MPI mapping
26003!> mpi_gather
26004!> \note see mp_gather_z
26005! **************************************************************************************************
26006 SUBROUTINE mp_gather_zm_src(msg, msg_gather, comm)
26007 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
26008 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
26009 CLASS(mp_comm_type), INTENT(IN) :: comm
26010
26011 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zm_src'
26012
26013 INTEGER :: handle
26014#if defined(__parallel)
26015 INTEGER :: ierr, msglen
26016#endif
26017
26018 CALL mp_timeset(routinen, handle)
26019
26020#if defined(__parallel)
26021 msglen = SIZE(msg)
26022 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26023 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
26024 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26025 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26026#else
26027 mark_used(comm)
26028 msg_gather = msg
26029#endif
26030 CALL mp_timestop(handle)
26031 END SUBROUTINE mp_gather_zm_src
26032
26033! **************************************************************************************************
26034!> \brief Gathers data from all processes to one.
26035!> \param[in] sendbuf Data to send to root
26036!> \param[out] recvbuf Received data (on root)
26037!> \param[in] recvcounts Sizes of data received from processes
26038!> \param[in] displs Offsets of data received from processes
26039!> \param[in] root Process which gathers the data
26040!> \param[in] comm Message passing environment identifier
26041!> \par Data length
26042!> Data can have different lengths
26043!> \par Offsets
26044!> Offsets start at 0
26045!> \par MPI mapping
26046!> mpi_gather
26047! **************************************************************************************************
26048 SUBROUTINE mp_gatherv_zv(sendbuf, recvbuf, recvcounts, displs, root, comm)
26049
26050 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
26051 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
26052 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26053 INTEGER, INTENT(IN) :: root
26054 CLASS(mp_comm_type), INTENT(IN) :: comm
26055
26056 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zv'
26057
26058 INTEGER :: handle
26059#if defined(__parallel)
26060 INTEGER :: ierr, sendcount
26061#endif
26062
26063 CALL mp_timeset(routinen, handle)
26064
26065#if defined(__parallel)
26066 sendcount = SIZE(sendbuf)
26067 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26068 recvbuf, recvcounts, displs, mpi_double_complex, &
26069 root, comm%handle, ierr)
26070 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26071 CALL add_perf(perf_id=4, &
26072 count=1, &
26073 msg_size=sendcount*(2*real_8_size))
26074#else
26075 mark_used(recvcounts)
26076 mark_used(root)
26077 mark_used(comm)
26078 recvbuf(1 + displs(1):) = sendbuf
26079#endif
26080 CALL mp_timestop(handle)
26081 END SUBROUTINE mp_gatherv_zv
26082
26083! **************************************************************************************************
26084!> \brief Gathers data from all processes to one. Gathers from comm%source
26085!> \param[in] sendbuf Data to send to root
26086!> \param[out] recvbuf Received data (on root)
26087!> \param[in] recvcounts Sizes of data received from processes
26088!> \param[in] displs Offsets of data received from processes
26089!> \param[in] comm Message passing environment identifier
26090!> \par Data length
26091!> Data can have different lengths
26092!> \par Offsets
26093!> Offsets start at 0
26094!> \par MPI mapping
26095!> mpi_gather
26096! **************************************************************************************************
26097 SUBROUTINE mp_gatherv_zv_src(sendbuf, recvbuf, recvcounts, displs, comm)
26098
26099 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
26100 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
26101 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26102 CLASS(mp_comm_type), INTENT(IN) :: comm
26103
26104 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zv_src'
26105
26106 INTEGER :: handle
26107#if defined(__parallel)
26108 INTEGER :: ierr, sendcount
26109#endif
26110
26111 CALL mp_timeset(routinen, handle)
26112
26113#if defined(__parallel)
26114 sendcount = SIZE(sendbuf)
26115 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26116 recvbuf, recvcounts, displs, mpi_double_complex, &
26117 comm%source, comm%handle, ierr)
26118 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26119 CALL add_perf(perf_id=4, &
26120 count=1, &
26121 msg_size=sendcount*(2*real_8_size))
26122#else
26123 mark_used(recvcounts)
26124 mark_used(comm)
26125 recvbuf(1 + displs(1):) = sendbuf
26126#endif
26127 CALL mp_timestop(handle)
26128 END SUBROUTINE mp_gatherv_zv_src
26129
26130! **************************************************************************************************
26131!> \brief Gathers data from all processes to one.
26132!> \param[in] sendbuf Data to send to root
26133!> \param[out] recvbuf Received data (on root)
26134!> \param[in] recvcounts Sizes of data received from processes
26135!> \param[in] displs Offsets of data received from processes
26136!> \param[in] root Process which gathers the data
26137!> \param[in] comm Message passing environment identifier
26138!> \par Data length
26139!> Data can have different lengths
26140!> \par Offsets
26141!> Offsets start at 0
26142!> \par MPI mapping
26143!> mpi_gather
26144! **************************************************************************************************
26145 SUBROUTINE mp_gatherv_zm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
26146
26147 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
26148 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
26149 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26150 INTEGER, INTENT(IN) :: root
26151 CLASS(mp_comm_type), INTENT(IN) :: comm
26152
26153 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zm2'
26154
26155 INTEGER :: handle
26156#if defined(__parallel)
26157 INTEGER :: ierr, sendcount
26158#endif
26159
26160 CALL mp_timeset(routinen, handle)
26161
26162#if defined(__parallel)
26163 sendcount = SIZE(sendbuf)
26164 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26165 recvbuf, recvcounts, displs, mpi_double_complex, &
26166 root, comm%handle, ierr)
26167 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26168 CALL add_perf(perf_id=4, &
26169 count=1, &
26170 msg_size=sendcount*(2*real_8_size))
26171#else
26172 mark_used(recvcounts)
26173 mark_used(root)
26174 mark_used(comm)
26175 recvbuf(:, 1 + displs(1):) = sendbuf
26176#endif
26177 CALL mp_timestop(handle)
26178 END SUBROUTINE mp_gatherv_zm2
26179
26180! **************************************************************************************************
26181!> \brief Gathers data from all processes to one.
26182!> \param[in] sendbuf Data to send to root
26183!> \param[out] recvbuf Received data (on root)
26184!> \param[in] recvcounts Sizes of data received from processes
26185!> \param[in] displs Offsets of data received from processes
26186!> \param[in] comm Message passing environment identifier
26187!> \par Data length
26188!> Data can have different lengths
26189!> \par Offsets
26190!> Offsets start at 0
26191!> \par MPI mapping
26192!> mpi_gather
26193! **************************************************************************************************
26194 SUBROUTINE mp_gatherv_zm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
26195
26196 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
26197 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
26198 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26199 CLASS(mp_comm_type), INTENT(IN) :: comm
26200
26201 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zm2_src'
26202
26203 INTEGER :: handle
26204#if defined(__parallel)
26205 INTEGER :: ierr, sendcount
26206#endif
26207
26208 CALL mp_timeset(routinen, handle)
26209
26210#if defined(__parallel)
26211 sendcount = SIZE(sendbuf)
26212 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26213 recvbuf, recvcounts, displs, mpi_double_complex, &
26214 comm%source, comm%handle, ierr)
26215 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26216 CALL add_perf(perf_id=4, &
26217 count=1, &
26218 msg_size=sendcount*(2*real_8_size))
26219#else
26220 mark_used(recvcounts)
26221 mark_used(comm)
26222 recvbuf(:, 1 + displs(1):) = sendbuf
26223#endif
26224 CALL mp_timestop(handle)
26225 END SUBROUTINE mp_gatherv_zm2_src
26226
26227! **************************************************************************************************
26228!> \brief Gathers data from all processes to one.
26229!> \param[in] sendbuf Data to send to root
26230!> \param[out] recvbuf Received data (on root)
26231!> \param[in] recvcounts Sizes of data received from processes
26232!> \param[in] displs Offsets of data received from processes
26233!> \param[in] root Process which gathers the data
26234!> \param[in] comm Message passing environment identifier
26235!> \par Data length
26236!> Data can have different lengths
26237!> \par Offsets
26238!> Offsets start at 0
26239!> \par MPI mapping
26240!> mpi_gather
26241! **************************************************************************************************
26242 SUBROUTINE mp_igatherv_zv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
26243 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: sendbuf
26244 COMPLEX(kind=real_8), DIMENSION(:), INTENT(OUT) :: recvbuf
26245 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26246 INTEGER, INTENT(IN) :: sendcount, root
26247 CLASS(mp_comm_type), INTENT(IN) :: comm
26248 TYPE(mp_request_type), INTENT(OUT) :: request
26249
26250 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_zv'
26251
26252 INTEGER :: handle
26253#if defined(__parallel)
26254 INTEGER :: ierr
26255#endif
26256
26257 CALL mp_timeset(routinen, handle)
26258
26259#if defined(__parallel)
26260#if !defined(__GNUC__) || __GNUC__ >= 9
26261 cpassert(is_contiguous(sendbuf))
26262 cpassert(is_contiguous(recvbuf))
26263 cpassert(is_contiguous(recvcounts))
26264 cpassert(is_contiguous(displs))
26265#endif
26266 CALL mpi_igatherv(sendbuf, sendcount, mpi_double_complex, &
26267 recvbuf, recvcounts, displs, mpi_double_complex, &
26268 root, comm%handle, request%handle, ierr)
26269 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26270 CALL add_perf(perf_id=24, &
26271 count=1, &
26272 msg_size=sendcount*(2*real_8_size))
26273#else
26274 mark_used(sendcount)
26275 mark_used(recvcounts)
26276 mark_used(root)
26277 mark_used(comm)
26278 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
26279 request = mp_request_null
26280#endif
26281 CALL mp_timestop(handle)
26282 END SUBROUTINE mp_igatherv_zv
26283
26284! **************************************************************************************************
26285!> \brief Gathers a datum from all processes and all processes receive the
26286!> same data
26287!> \param[in] msgout Datum to send
26288!> \param[out] msgin Received data
26289!> \param[in] comm Message passing environment identifier
26290!> \par Data size
26291!> All processes send equal-sized data
26292!> \par MPI mapping
26293!> mpi_allgather
26294! **************************************************************************************************
26295 SUBROUTINE mp_allgather_z (msgout, msgin, comm)
26296 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26297 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
26298 CLASS(mp_comm_type), INTENT(IN) :: comm
26299
26300 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z'
26301
26302 INTEGER :: handle
26303#if defined(__parallel)
26304 INTEGER :: ierr, rcount, scount
26305#endif
26306
26307 CALL mp_timeset(routinen, handle)
26308
26309#if defined(__parallel)
26310 scount = 1
26311 rcount = 1
26312 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26313 msgin, rcount, mpi_double_complex, &
26314 comm%handle, ierr)
26315 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26316#else
26317 mark_used(comm)
26318 msgin = msgout
26319#endif
26320 CALL mp_timestop(handle)
26321 END SUBROUTINE mp_allgather_z
26322
26323! **************************************************************************************************
26324!> \brief Gathers a datum from all processes and all processes receive the
26325!> same data
26326!> \param[in] msgout Datum to send
26327!> \param[out] msgin Received data
26328!> \param[in] comm Message passing environment identifier
26329!> \par Data size
26330!> All processes send equal-sized data
26331!> \par MPI mapping
26332!> mpi_allgather
26333! **************************************************************************************************
26334 SUBROUTINE mp_allgather_z2(msgout, msgin, comm)
26335 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26336 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26337 CLASS(mp_comm_type), INTENT(IN) :: comm
26338
26339 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z2'
26340
26341 INTEGER :: handle
26342#if defined(__parallel)
26343 INTEGER :: ierr, rcount, scount
26344#endif
26345
26346 CALL mp_timeset(routinen, handle)
26347
26348#if defined(__parallel)
26349 scount = 1
26350 rcount = 1
26351 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26352 msgin, rcount, mpi_double_complex, &
26353 comm%handle, ierr)
26354 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26355#else
26356 mark_used(comm)
26357 msgin = msgout
26358#endif
26359 CALL mp_timestop(handle)
26360 END SUBROUTINE mp_allgather_z2
26361
26362! **************************************************************************************************
26363!> \brief Gathers a datum from all processes and all processes receive the
26364!> same data
26365!> \param[in] msgout Datum to send
26366!> \param[out] msgin Received data
26367!> \param[in] comm Message passing environment identifier
26368!> \par Data size
26369!> All processes send equal-sized data
26370!> \par MPI mapping
26371!> mpi_allgather
26372! **************************************************************************************************
26373 SUBROUTINE mp_iallgather_z (msgout, msgin, comm, request)
26374 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26375 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26376 CLASS(mp_comm_type), INTENT(IN) :: comm
26377 TYPE(mp_request_type), INTENT(OUT) :: request
26378
26379 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z'
26380
26381 INTEGER :: handle
26382#if defined(__parallel)
26383 INTEGER :: ierr, rcount, scount
26384#endif
26385
26386 CALL mp_timeset(routinen, handle)
26387
26388#if defined(__parallel)
26389#if !defined(__GNUC__) || __GNUC__ >= 9
26390 cpassert(is_contiguous(msgin))
26391#endif
26392 scount = 1
26393 rcount = 1
26394 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26395 msgin, rcount, mpi_double_complex, &
26396 comm%handle, request%handle, ierr)
26397 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26398#else
26399 mark_used(comm)
26400 msgin = msgout
26401 request = mp_request_null
26402#endif
26403 CALL mp_timestop(handle)
26404 END SUBROUTINE mp_iallgather_z
26405
26406! **************************************************************************************************
26407!> \brief Gathers vector data from all processes and all processes receive the
26408!> same data
26409!> \param[in] msgout Rank-1 data to send
26410!> \param[out] msgin Received data
26411!> \param[in] comm Message passing environment identifier
26412!> \par Data size
26413!> All processes send equal-sized data
26414!> \par Ranks
26415!> The last rank counts the processes
26416!> \par MPI mapping
26417!> mpi_allgather
26418! **************************************************************************************************
26419 SUBROUTINE mp_allgather_z12(msgout, msgin, comm)
26420 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:)
26421 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26422 CLASS(mp_comm_type), INTENT(IN) :: comm
26423
26424 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z12'
26425
26426 INTEGER :: handle
26427#if defined(__parallel)
26428 INTEGER :: ierr, rcount, scount
26429#endif
26430
26431 CALL mp_timeset(routinen, handle)
26432
26433#if defined(__parallel)
26434 scount = SIZE(msgout(:))
26435 rcount = scount
26436 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26437 msgin, rcount, mpi_double_complex, &
26438 comm%handle, ierr)
26439 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26440#else
26441 mark_used(comm)
26442 msgin(:, 1) = msgout(:)
26443#endif
26444 CALL mp_timestop(handle)
26445 END SUBROUTINE mp_allgather_z12
26446
26447! **************************************************************************************************
26448!> \brief Gathers matrix data from all processes and all processes receive the
26449!> same data
26450!> \param[in] msgout Rank-2 data to send
26451!> \param msgin ...
26452!> \param comm ...
26453!> \note see mp_allgather_z12
26454! **************************************************************************************************
26455 SUBROUTINE mp_allgather_z23(msgout, msgin, comm)
26456 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
26457 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
26458 CLASS(mp_comm_type), INTENT(IN) :: comm
26459
26460 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z23'
26461
26462 INTEGER :: handle
26463#if defined(__parallel)
26464 INTEGER :: ierr, rcount, scount
26465#endif
26466
26467 CALL mp_timeset(routinen, handle)
26468
26469#if defined(__parallel)
26470 scount = SIZE(msgout(:, :))
26471 rcount = scount
26472 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26473 msgin, rcount, mpi_double_complex, &
26474 comm%handle, ierr)
26475 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26476#else
26477 mark_used(comm)
26478 msgin(:, :, 1) = msgout(:, :)
26479#endif
26480 CALL mp_timestop(handle)
26481 END SUBROUTINE mp_allgather_z23
26482
26483! **************************************************************************************************
26484!> \brief Gathers rank-3 data from all processes and all processes receive the
26485!> same data
26486!> \param[in] msgout Rank-3 data to send
26487!> \param msgin ...
26488!> \param comm ...
26489!> \note see mp_allgather_z12
26490! **************************************************************************************************
26491 SUBROUTINE mp_allgather_z34(msgout, msgin, comm)
26492 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
26493 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
26494 CLASS(mp_comm_type), INTENT(IN) :: comm
26495
26496 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z34'
26497
26498 INTEGER :: handle
26499#if defined(__parallel)
26500 INTEGER :: ierr, rcount, scount
26501#endif
26502
26503 CALL mp_timeset(routinen, handle)
26504
26505#if defined(__parallel)
26506 scount = SIZE(msgout(:, :, :))
26507 rcount = scount
26508 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26509 msgin, rcount, mpi_double_complex, &
26510 comm%handle, ierr)
26511 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26512#else
26513 mark_used(comm)
26514 msgin(:, :, :, 1) = msgout(:, :, :)
26515#endif
26516 CALL mp_timestop(handle)
26517 END SUBROUTINE mp_allgather_z34
26518
26519! **************************************************************************************************
26520!> \brief Gathers rank-2 data from all processes and all processes receive the
26521!> same data
26522!> \param[in] msgout Rank-2 data to send
26523!> \param msgin ...
26524!> \param comm ...
26525!> \note see mp_allgather_z12
26526! **************************************************************************************************
26527 SUBROUTINE mp_allgather_z22(msgout, msgin, comm)
26528 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
26529 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26530 CLASS(mp_comm_type), INTENT(IN) :: comm
26531
26532 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z22'
26533
26534 INTEGER :: handle
26535#if defined(__parallel)
26536 INTEGER :: ierr, rcount, scount
26537#endif
26538
26539 CALL mp_timeset(routinen, handle)
26540
26541#if defined(__parallel)
26542 scount = SIZE(msgout(:, :))
26543 rcount = scount
26544 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26545 msgin, rcount, mpi_double_complex, &
26546 comm%handle, ierr)
26547 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26548#else
26549 mark_used(comm)
26550 msgin(:, :) = msgout(:, :)
26551#endif
26552 CALL mp_timestop(handle)
26553 END SUBROUTINE mp_allgather_z22
26554
26555! **************************************************************************************************
26556!> \brief Gathers rank-1 data from all processes and all processes receive the
26557!> same data
26558!> \param[in] msgout Rank-1 data to send
26559!> \param msgin ...
26560!> \param comm ...
26561!> \param request ...
26562!> \note see mp_allgather_z11
26563! **************************************************************************************************
26564 SUBROUTINE mp_iallgather_z11(msgout, msgin, comm, request)
26565 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26566 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26567 CLASS(mp_comm_type), INTENT(IN) :: comm
26568 TYPE(mp_request_type), INTENT(OUT) :: request
26569
26570 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z11'
26571
26572 INTEGER :: handle
26573#if defined(__parallel)
26574 INTEGER :: ierr, rcount, scount
26575#endif
26576
26577 CALL mp_timeset(routinen, handle)
26578
26579#if defined(__parallel)
26580#if !defined(__GNUC__) || __GNUC__ >= 9
26581 cpassert(is_contiguous(msgout))
26582 cpassert(is_contiguous(msgin))
26583#endif
26584 scount = SIZE(msgout(:))
26585 rcount = scount
26586 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26587 msgin, rcount, mpi_double_complex, &
26588 comm%handle, request%handle, ierr)
26589 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26590#else
26591 mark_used(comm)
26592 msgin = msgout
26593 request = mp_request_null
26594#endif
26595 CALL mp_timestop(handle)
26596 END SUBROUTINE mp_iallgather_z11
26597
26598! **************************************************************************************************
26599!> \brief Gathers rank-2 data from all processes and all processes receive the
26600!> same data
26601!> \param[in] msgout Rank-2 data to send
26602!> \param msgin ...
26603!> \param comm ...
26604!> \param request ...
26605!> \note see mp_allgather_z12
26606! **************************************************************************************************
26607 SUBROUTINE mp_iallgather_z13(msgout, msgin, comm, request)
26608 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26609 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
26610 CLASS(mp_comm_type), INTENT(IN) :: comm
26611 TYPE(mp_request_type), INTENT(OUT) :: request
26612
26613 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z13'
26614
26615 INTEGER :: handle
26616#if defined(__parallel)
26617 INTEGER :: ierr, rcount, scount
26618#endif
26619
26620 CALL mp_timeset(routinen, handle)
26621
26622#if defined(__parallel)
26623#if !defined(__GNUC__) || __GNUC__ >= 9
26624 cpassert(is_contiguous(msgout))
26625 cpassert(is_contiguous(msgin))
26626#endif
26627
26628 scount = SIZE(msgout(:))
26629 rcount = scount
26630 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26631 msgin, rcount, mpi_double_complex, &
26632 comm%handle, request%handle, ierr)
26633 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26634#else
26635 mark_used(comm)
26636 msgin(:, 1, 1) = msgout(:)
26637 request = mp_request_null
26638#endif
26639 CALL mp_timestop(handle)
26640 END SUBROUTINE mp_iallgather_z13
26641
26642! **************************************************************************************************
26643!> \brief Gathers rank-2 data from all processes and all processes receive the
26644!> same data
26645!> \param[in] msgout Rank-2 data to send
26646!> \param msgin ...
26647!> \param comm ...
26648!> \param request ...
26649!> \note see mp_allgather_z12
26650! **************************************************************************************************
26651 SUBROUTINE mp_iallgather_z22(msgout, msgin, comm, request)
26652 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :)
26653 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :)
26654 CLASS(mp_comm_type), INTENT(IN) :: comm
26655 TYPE(mp_request_type), INTENT(OUT) :: request
26656
26657 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z22'
26658
26659 INTEGER :: handle
26660#if defined(__parallel)
26661 INTEGER :: ierr, rcount, scount
26662#endif
26663
26664 CALL mp_timeset(routinen, handle)
26665
26666#if defined(__parallel)
26667#if !defined(__GNUC__) || __GNUC__ >= 9
26668 cpassert(is_contiguous(msgout))
26669 cpassert(is_contiguous(msgin))
26670#endif
26671
26672 scount = SIZE(msgout(:, :))
26673 rcount = scount
26674 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26675 msgin, rcount, mpi_double_complex, &
26676 comm%handle, request%handle, ierr)
26677 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26678#else
26679 mark_used(comm)
26680 msgin(:, :) = msgout(:, :)
26681 request = mp_request_null
26682#endif
26683 CALL mp_timestop(handle)
26684 END SUBROUTINE mp_iallgather_z22
26685
26686! **************************************************************************************************
26687!> \brief Gathers rank-2 data from all processes and all processes receive the
26688!> same data
26689!> \param[in] msgout Rank-2 data to send
26690!> \param msgin ...
26691!> \param comm ...
26692!> \param request ...
26693!> \note see mp_allgather_z12
26694! **************************************************************************************************
26695 SUBROUTINE mp_iallgather_z24(msgout, msgin, comm, request)
26696 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :)
26697 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :, :)
26698 CLASS(mp_comm_type), INTENT(IN) :: comm
26699 TYPE(mp_request_type), INTENT(OUT) :: request
26700
26701 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z24'
26702
26703 INTEGER :: handle
26704#if defined(__parallel)
26705 INTEGER :: ierr, rcount, scount
26706#endif
26707
26708 CALL mp_timeset(routinen, handle)
26709
26710#if defined(__parallel)
26711#if !defined(__GNUC__) || __GNUC__ >= 9
26712 cpassert(is_contiguous(msgout))
26713 cpassert(is_contiguous(msgin))
26714#endif
26715
26716 scount = SIZE(msgout(:, :))
26717 rcount = scount
26718 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26719 msgin, rcount, mpi_double_complex, &
26720 comm%handle, request%handle, ierr)
26721 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26722#else
26723 mark_used(comm)
26724 msgin(:, :, 1, 1) = msgout(:, :)
26725 request = mp_request_null
26726#endif
26727 CALL mp_timestop(handle)
26728 END SUBROUTINE mp_iallgather_z24
26729
26730! **************************************************************************************************
26731!> \brief Gathers rank-3 data from all processes and all processes receive the
26732!> same data
26733!> \param[in] msgout Rank-3 data to send
26734!> \param msgin ...
26735!> \param comm ...
26736!> \param request ...
26737!> \note see mp_allgather_z12
26738! **************************************************************************************************
26739 SUBROUTINE mp_iallgather_z33(msgout, msgin, comm, request)
26740 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :, :)
26741 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
26742 CLASS(mp_comm_type), INTENT(IN) :: comm
26743 TYPE(mp_request_type), INTENT(OUT) :: request
26744
26745 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z33'
26746
26747 INTEGER :: handle
26748#if defined(__parallel)
26749 INTEGER :: ierr, rcount, scount
26750#endif
26751
26752 CALL mp_timeset(routinen, handle)
26753
26754#if defined(__parallel)
26755#if !defined(__GNUC__) || __GNUC__ >= 9
26756 cpassert(is_contiguous(msgout))
26757 cpassert(is_contiguous(msgin))
26758#endif
26759
26760 scount = SIZE(msgout(:, :, :))
26761 rcount = scount
26762 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26763 msgin, rcount, mpi_double_complex, &
26764 comm%handle, request%handle, ierr)
26765 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26766#else
26767 mark_used(comm)
26768 msgin(:, :, :) = msgout(:, :, :)
26769 request = mp_request_null
26770#endif
26771 CALL mp_timestop(handle)
26772 END SUBROUTINE mp_iallgather_z33
26773
26774! **************************************************************************************************
26775!> \brief Gathers vector data from all processes and all processes receive the
26776!> same data
26777!> \param[in] msgout Rank-1 data to send
26778!> \param[out] msgin Received data
26779!> \param[in] rcount Size of sent data for every process
26780!> \param[in] rdispl Offset of sent data for every process
26781!> \param[in] comm Message passing environment identifier
26782!> \par Data size
26783!> Processes can send different-sized data
26784!> \par Ranks
26785!> The last rank counts the processes
26786!> \par Offsets
26787!> Offsets are from 0
26788!> \par MPI mapping
26789!> mpi_allgather
26790! **************************************************************************************************
26791 SUBROUTINE mp_allgatherv_zv(msgout, msgin, rcount, rdispl, comm)
26792 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
26793 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
26794 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26795 CLASS(mp_comm_type), INTENT(IN) :: comm
26796
26797 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_zv'
26798
26799 INTEGER :: handle
26800#if defined(__parallel)
26801 INTEGER :: ierr, scount
26802#endif
26803
26804 CALL mp_timeset(routinen, handle)
26805
26806#if defined(__parallel)
26807 scount = SIZE(msgout)
26808 CALL mpi_allgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
26809 rdispl, mpi_double_complex, comm%handle, ierr)
26810 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
26811#else
26812 mark_used(rcount)
26813 mark_used(rdispl)
26814 mark_used(comm)
26815 msgin = msgout
26816#endif
26817 CALL mp_timestop(handle)
26818 END SUBROUTINE mp_allgatherv_zv
26819
26820! **************************************************************************************************
26821!> \brief Gathers vector data from all processes and all processes receive the
26822!> same data
26823!> \param[in] msgout Rank-1 data to send
26824!> \param[out] msgin Received data
26825!> \param[in] rcount Size of sent data for every process
26826!> \param[in] rdispl Offset of sent data for every process
26827!> \param[in] comm Message passing environment identifier
26828!> \par Data size
26829!> Processes can send different-sized data
26830!> \par Ranks
26831!> The last rank counts the processes
26832!> \par Offsets
26833!> Offsets are from 0
26834!> \par MPI mapping
26835!> mpi_allgather
26836! **************************************************************************************************
26837 SUBROUTINE mp_allgatherv_zm2(msgout, msgin, rcount, rdispl, comm)
26838 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
26839 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
26840 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26841 CLASS(mp_comm_type), INTENT(IN) :: comm
26842
26843 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_zv'
26844
26845 INTEGER :: handle
26846#if defined(__parallel)
26847 INTEGER :: ierr, scount
26848#endif
26849
26850 CALL mp_timeset(routinen, handle)
26851
26852#if defined(__parallel)
26853 scount = SIZE(msgout)
26854 CALL mpi_allgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
26855 rdispl, mpi_double_complex, comm%handle, ierr)
26856 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
26857#else
26858 mark_used(rcount)
26859 mark_used(rdispl)
26860 mark_used(comm)
26861 msgin = msgout
26862#endif
26863 CALL mp_timestop(handle)
26864 END SUBROUTINE mp_allgatherv_zm2
26865
26866! **************************************************************************************************
26867!> \brief Gathers vector data from all processes and all processes receive the
26868!> same data
26869!> \param[in] msgout Rank-1 data to send
26870!> \param[out] msgin Received data
26871!> \param[in] rcount Size of sent data for every process
26872!> \param[in] rdispl Offset of sent data for every process
26873!> \param[in] comm Message passing environment identifier
26874!> \par Data size
26875!> Processes can send different-sized data
26876!> \par Ranks
26877!> The last rank counts the processes
26878!> \par Offsets
26879!> Offsets are from 0
26880!> \par MPI mapping
26881!> mpi_allgather
26882! **************************************************************************************************
26883 SUBROUTINE mp_iallgatherv_zv(msgout, msgin, rcount, rdispl, comm, request)
26884 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26885 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26886 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26887 CLASS(mp_comm_type), INTENT(IN) :: comm
26888 TYPE(mp_request_type), INTENT(OUT) :: request
26889
26890 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_zv'
26891
26892 INTEGER :: handle
26893#if defined(__parallel)
26894 INTEGER :: ierr, scount, rsize
26895#endif
26896
26897 CALL mp_timeset(routinen, handle)
26898
26899#if defined(__parallel)
26900#if !defined(__GNUC__) || __GNUC__ >= 9
26901 cpassert(is_contiguous(msgout))
26902 cpassert(is_contiguous(msgin))
26903 cpassert(is_contiguous(rcount))
26904 cpassert(is_contiguous(rdispl))
26905#endif
26906
26907 scount = SIZE(msgout)
26908 rsize = SIZE(rcount)
26909 CALL mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, &
26910 rdispl, comm, request, ierr)
26911 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
26912#else
26913 mark_used(rcount)
26914 mark_used(rdispl)
26915 mark_used(comm)
26916 msgin = msgout
26917 request = mp_request_null
26918#endif
26919 CALL mp_timestop(handle)
26920 END SUBROUTINE mp_iallgatherv_zv
26921
26922! **************************************************************************************************
26923!> \brief Gathers vector data from all processes and all processes receive the
26924!> same data
26925!> \param[in] msgout Rank-1 data to send
26926!> \param[out] msgin Received data
26927!> \param[in] rcount Size of sent data for every process
26928!> \param[in] rdispl Offset of sent data for every process
26929!> \param[in] comm Message passing environment identifier
26930!> \par Data size
26931!> Processes can send different-sized data
26932!> \par Ranks
26933!> The last rank counts the processes
26934!> \par Offsets
26935!> Offsets are from 0
26936!> \par MPI mapping
26937!> mpi_allgather
26938! **************************************************************************************************
26939 SUBROUTINE mp_iallgatherv_zv2(msgout, msgin, rcount, rdispl, comm, request)
26940 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26941 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26942 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
26943 CLASS(mp_comm_type), INTENT(IN) :: comm
26944 TYPE(mp_request_type), INTENT(OUT) :: request
26945
26946 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_zv2'
26947
26948 INTEGER :: handle
26949#if defined(__parallel)
26950 INTEGER :: ierr, scount, rsize
26951#endif
26952
26953 CALL mp_timeset(routinen, handle)
26954
26955#if defined(__parallel)
26956#if !defined(__GNUC__) || __GNUC__ >= 9
26957 cpassert(is_contiguous(msgout))
26958 cpassert(is_contiguous(msgin))
26959 cpassert(is_contiguous(rcount))
26960 cpassert(is_contiguous(rdispl))
26961#endif
26962
26963 scount = SIZE(msgout)
26964 rsize = SIZE(rcount)
26965 CALL mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, &
26966 rdispl, comm, request, ierr)
26967 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
26968#else
26969 mark_used(rcount)
26970 mark_used(rdispl)
26971 mark_used(comm)
26972 msgin = msgout
26973 request = mp_request_null
26974#endif
26975 CALL mp_timestop(handle)
26976 END SUBROUTINE mp_iallgatherv_zv2
26977
26978! **************************************************************************************************
26979!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
26980!> the issue is with the rank of rcount and rdispl
26981!> \param count ...
26982!> \param array_of_requests ...
26983!> \param array_of_statuses ...
26984!> \param ierr ...
26985!> \author Alfio Lazzaro
26986! **************************************************************************************************
26987#if defined(__parallel)
26988 SUBROUTINE mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
26989 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
26990 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
26991 INTEGER, INTENT(IN) :: rsize
26992 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
26993 CLASS(mp_comm_type), INTENT(IN) :: comm
26994 TYPE(mp_request_type), INTENT(OUT) :: request
26995 INTEGER, INTENT(INOUT) :: ierr
26996
26997 CALL mpi_iallgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
26998 rdispl, mpi_double_complex, comm%handle, request%handle, ierr)
26999
27000 END SUBROUTINE mp_iallgatherv_zv_internal
27001#endif
27002
27003! **************************************************************************************************
27004!> \brief Sums a vector and partitions the result among processes
27005!> \param[in] msgout Data to sum
27006!> \param[out] msgin Received portion of summed data
27007!> \param[in] rcount Partition sizes of the summed data for
27008!> every process
27009!> \param[in] comm Message passing environment identifier
27010! **************************************************************************************************
27011 SUBROUTINE mp_sum_scatter_zv(msgout, msgin, rcount, comm)
27012 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
27013 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
27014 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
27015 CLASS(mp_comm_type), INTENT(IN) :: comm
27016
27017 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_zv'
27018
27019 INTEGER :: handle
27020#if defined(__parallel)
27021 INTEGER :: ierr
27022#endif
27023
27024 CALL mp_timeset(routinen, handle)
27025
27026#if defined(__parallel)
27027 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_double_complex, mpi_sum, &
27028 comm%handle, ierr)
27029 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
27030
27031 CALL add_perf(perf_id=3, count=1, &
27032 msg_size=rcount(1)*2*(2*real_8_size))
27033#else
27034 mark_used(rcount)
27035 mark_used(comm)
27036 msgin = msgout(:, 1)
27037#endif
27038 CALL mp_timestop(handle)
27039 END SUBROUTINE mp_sum_scatter_zv
27040
27041! **************************************************************************************************
27042!> \brief Sends and receives vector data
27043!> \param[in] msgin Data to send
27044!> \param[in] dest Process to send data to
27045!> \param[out] msgout Received data
27046!> \param[in] source Process from which to receive
27047!> \param[in] comm Message passing environment identifier
27048!> \param[in] tag Send and recv tag (default: 0)
27049! **************************************************************************************************
27050 SUBROUTINE mp_sendrecv_z (msgin, dest, msgout, source, comm, tag)
27051 COMPLEX(kind=real_8), INTENT(IN) :: msgin
27052 INTEGER, INTENT(IN) :: dest
27053 COMPLEX(kind=real_8), INTENT(OUT) :: msgout
27054 INTEGER, INTENT(IN) :: source
27055 CLASS(mp_comm_type), INTENT(IN) :: comm
27056 INTEGER, INTENT(IN), OPTIONAL :: tag
27057
27058 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_z'
27059
27060 INTEGER :: handle
27061#if defined(__parallel)
27062 INTEGER :: ierr, msglen_in, msglen_out, &
27063 recv_tag, send_tag
27064#endif
27065
27066 CALL mp_timeset(routinen, handle)
27067
27068#if defined(__parallel)
27069 msglen_in = 1
27070 msglen_out = 1
27071 send_tag = 0 ! cannot think of something better here, this might be dangerous
27072 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27073 IF (PRESENT(tag)) THEN
27074 send_tag = tag
27075 recv_tag = tag
27076 END IF
27077 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27078 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27079 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27080 CALL add_perf(perf_id=7, count=1, &
27081 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27082#else
27083 mark_used(dest)
27084 mark_used(source)
27085 mark_used(comm)
27086 mark_used(tag)
27087 msgout = msgin
27088#endif
27089 CALL mp_timestop(handle)
27090 END SUBROUTINE mp_sendrecv_z
27091
27092! **************************************************************************************************
27093!> \brief Sends and receives vector data
27094!> \param[in] msgin Data to send
27095!> \param[in] dest Process to send data to
27096!> \param[out] msgout Received data
27097!> \param[in] source Process from which to receive
27098!> \param[in] comm Message passing environment identifier
27099!> \param[in] tag Send and recv tag (default: 0)
27100! **************************************************************************************************
27101 SUBROUTINE mp_sendrecv_zv(msgin, dest, msgout, source, comm, tag)
27102 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
27103 INTEGER, INTENT(IN) :: dest
27104 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
27105 INTEGER, INTENT(IN) :: source
27106 CLASS(mp_comm_type), INTENT(IN) :: comm
27107 INTEGER, INTENT(IN), OPTIONAL :: tag
27108
27109 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zv'
27110
27111 INTEGER :: handle
27112#if defined(__parallel)
27113 INTEGER :: ierr, msglen_in, msglen_out, &
27114 recv_tag, send_tag
27115#endif
27116
27117 CALL mp_timeset(routinen, handle)
27118
27119#if defined(__parallel)
27120 msglen_in = SIZE(msgin)
27121 msglen_out = SIZE(msgout)
27122 send_tag = 0 ! cannot think of something better here, this might be dangerous
27123 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27124 IF (PRESENT(tag)) THEN
27125 send_tag = tag
27126 recv_tag = tag
27127 END IF
27128 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27129 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27130 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27131 CALL add_perf(perf_id=7, count=1, &
27132 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27133#else
27134 mark_used(dest)
27135 mark_used(source)
27136 mark_used(comm)
27137 mark_used(tag)
27138 msgout = msgin
27139#endif
27140 CALL mp_timestop(handle)
27141 END SUBROUTINE mp_sendrecv_zv
27142
27143! **************************************************************************************************
27144!> \brief Sends and receives matrix data
27145!> \param msgin ...
27146!> \param dest ...
27147!> \param msgout ...
27148!> \param source ...
27149!> \param comm ...
27150!> \param tag ...
27151!> \note see mp_sendrecv_zv
27152! **************************************************************************************************
27153 SUBROUTINE mp_sendrecv_zm2(msgin, dest, msgout, source, comm, tag)
27154 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
27155 INTEGER, INTENT(IN) :: dest
27156 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
27157 INTEGER, INTENT(IN) :: source
27158 CLASS(mp_comm_type), INTENT(IN) :: comm
27159 INTEGER, INTENT(IN), OPTIONAL :: tag
27160
27161 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm2'
27162
27163 INTEGER :: handle
27164#if defined(__parallel)
27165 INTEGER :: ierr, msglen_in, msglen_out, &
27166 recv_tag, send_tag
27167#endif
27168
27169 CALL mp_timeset(routinen, handle)
27170
27171#if defined(__parallel)
27172 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
27173 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
27174 send_tag = 0 ! cannot think of something better here, this might be dangerous
27175 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27176 IF (PRESENT(tag)) THEN
27177 send_tag = tag
27178 recv_tag = tag
27179 END IF
27180 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27181 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27182 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27183 CALL add_perf(perf_id=7, count=1, &
27184 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27185#else
27186 mark_used(dest)
27187 mark_used(source)
27188 mark_used(comm)
27189 mark_used(tag)
27190 msgout = msgin
27191#endif
27192 CALL mp_timestop(handle)
27193 END SUBROUTINE mp_sendrecv_zm2
27194
27195! **************************************************************************************************
27196!> \brief Sends and receives rank-3 data
27197!> \param msgin ...
27198!> \param dest ...
27199!> \param msgout ...
27200!> \param source ...
27201!> \param comm ...
27202!> \note see mp_sendrecv_zv
27203! **************************************************************************************************
27204 SUBROUTINE mp_sendrecv_zm3(msgin, dest, msgout, source, comm, tag)
27205 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
27206 INTEGER, INTENT(IN) :: dest
27207 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
27208 INTEGER, INTENT(IN) :: source
27209 CLASS(mp_comm_type), INTENT(IN) :: comm
27210 INTEGER, INTENT(IN), OPTIONAL :: tag
27211
27212 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm3'
27213
27214 INTEGER :: handle
27215#if defined(__parallel)
27216 INTEGER :: ierr, msglen_in, msglen_out, &
27217 recv_tag, send_tag
27218#endif
27219
27220 CALL mp_timeset(routinen, handle)
27221
27222#if defined(__parallel)
27223 msglen_in = SIZE(msgin)
27224 msglen_out = SIZE(msgout)
27225 send_tag = 0 ! cannot think of something better here, this might be dangerous
27226 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27227 IF (PRESENT(tag)) THEN
27228 send_tag = tag
27229 recv_tag = tag
27230 END IF
27231 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27232 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27233 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27234 CALL add_perf(perf_id=7, count=1, &
27235 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27236#else
27237 mark_used(dest)
27238 mark_used(source)
27239 mark_used(comm)
27240 mark_used(tag)
27241 msgout = msgin
27242#endif
27243 CALL mp_timestop(handle)
27244 END SUBROUTINE mp_sendrecv_zm3
27245
27246! **************************************************************************************************
27247!> \brief Sends and receives rank-4 data
27248!> \param msgin ...
27249!> \param dest ...
27250!> \param msgout ...
27251!> \param source ...
27252!> \param comm ...
27253!> \note see mp_sendrecv_zv
27254! **************************************************************************************************
27255 SUBROUTINE mp_sendrecv_zm4(msgin, dest, msgout, source, comm, tag)
27256 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
27257 INTEGER, INTENT(IN) :: dest
27258 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
27259 INTEGER, INTENT(IN) :: source
27260 CLASS(mp_comm_type), INTENT(IN) :: comm
27261 INTEGER, INTENT(IN), OPTIONAL :: tag
27262
27263 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm4'
27264
27265 INTEGER :: handle
27266#if defined(__parallel)
27267 INTEGER :: ierr, msglen_in, msglen_out, &
27268 recv_tag, send_tag
27269#endif
27270
27271 CALL mp_timeset(routinen, handle)
27272
27273#if defined(__parallel)
27274 msglen_in = SIZE(msgin)
27275 msglen_out = SIZE(msgout)
27276 send_tag = 0 ! cannot think of something better here, this might be dangerous
27277 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27278 IF (PRESENT(tag)) THEN
27279 send_tag = tag
27280 recv_tag = tag
27281 END IF
27282 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27283 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27284 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27285 CALL add_perf(perf_id=7, count=1, &
27286 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27287#else
27288 mark_used(dest)
27289 mark_used(source)
27290 mark_used(comm)
27291 mark_used(tag)
27292 msgout = msgin
27293#endif
27294 CALL mp_timestop(handle)
27295 END SUBROUTINE mp_sendrecv_zm4
27296
27297! **************************************************************************************************
27298!> \brief Non-blocking send and receive of a scalar
27299!> \param[in] msgin Scalar data to send
27300!> \param[in] dest Which process to send to
27301!> \param[out] msgout Receive data into this pointer
27302!> \param[in] source Process to receive from
27303!> \param[in] comm Message passing environment identifier
27304!> \param[out] send_request Request handle for the send
27305!> \param[out] recv_request Request handle for the receive
27306!> \param[in] tag (optional) tag to differentiate requests
27307!> \par Implementation
27308!> Calls mpi_isend and mpi_irecv.
27309!> \par History
27310!> 02.2005 created [Alfio Lazzaro]
27311! **************************************************************************************************
27312 SUBROUTINE mp_isendrecv_z (msgin, dest, msgout, source, comm, send_request, &
27313 recv_request, tag)
27314 COMPLEX(kind=real_8), INTENT(IN) :: msgin
27315 INTEGER, INTENT(IN) :: dest
27316 COMPLEX(kind=real_8), INTENT(INOUT) :: msgout
27317 INTEGER, INTENT(IN) :: source
27318 CLASS(mp_comm_type), INTENT(IN) :: comm
27319 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
27320 INTEGER, INTENT(in), OPTIONAL :: tag
27321
27322 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_z'
27323
27324 INTEGER :: handle
27325#if defined(__parallel)
27326 INTEGER :: ierr, my_tag
27327#endif
27328
27329 CALL mp_timeset(routinen, handle)
27330
27331#if defined(__parallel)
27332 my_tag = 0
27333 IF (PRESENT(tag)) my_tag = tag
27334
27335 CALL mpi_irecv(msgout, 1, mpi_double_complex, source, my_tag, &
27336 comm%handle, recv_request%handle, ierr)
27337 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27338
27339 CALL mpi_isend(msgin, 1, mpi_double_complex, dest, my_tag, &
27340 comm%handle, send_request%handle, ierr)
27341 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27342
27343 CALL add_perf(perf_id=8, count=1, msg_size=2*(2*real_8_size))
27344#else
27345 mark_used(dest)
27346 mark_used(source)
27347 mark_used(comm)
27348 mark_used(tag)
27349 send_request = mp_request_null
27350 recv_request = mp_request_null
27351 msgout = msgin
27352#endif
27353 CALL mp_timestop(handle)
27354 END SUBROUTINE mp_isendrecv_z
27355
27356! **************************************************************************************************
27357!> \brief Non-blocking send and receive of a vector
27358!> \param[in] msgin Vector data to send
27359!> \param[in] dest Which process to send to
27360!> \param[out] msgout Receive data into this pointer
27361!> \param[in] source Process to receive from
27362!> \param[in] comm Message passing environment identifier
27363!> \param[out] send_request Request handle for the send
27364!> \param[out] recv_request Request handle for the receive
27365!> \param[in] tag (optional) tag to differentiate requests
27366!> \par Implementation
27367!> Calls mpi_isend and mpi_irecv.
27368!> \par History
27369!> 11.2004 created [Joost VandeVondele]
27370!> \note
27371!> arrays can be pointers or assumed shape, but they must be contiguous!
27372! **************************************************************************************************
27373 SUBROUTINE mp_isendrecv_zv(msgin, dest, msgout, source, comm, send_request, &
27374 recv_request, tag)
27375 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
27376 INTEGER, INTENT(IN) :: dest
27377 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
27378 INTEGER, INTENT(IN) :: source
27379 CLASS(mp_comm_type), INTENT(IN) :: comm
27380 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
27381 INTEGER, INTENT(in), OPTIONAL :: tag
27382
27383 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_zv'
27384
27385 INTEGER :: handle
27386#if defined(__parallel)
27387 INTEGER :: ierr, msglen, my_tag
27388 COMPLEX(kind=real_8) :: foo
27389#endif
27390
27391 CALL mp_timeset(routinen, handle)
27392
27393#if defined(__parallel)
27394#if !defined(__GNUC__) || __GNUC__ >= 9
27395 cpassert(is_contiguous(msgout))
27396 cpassert(is_contiguous(msgin))
27397#endif
27398
27399 my_tag = 0
27400 IF (PRESENT(tag)) my_tag = tag
27401
27402 msglen = SIZE(msgout, 1)
27403 IF (msglen > 0) THEN
27404 CALL mpi_irecv(msgout(1), msglen, mpi_double_complex, source, my_tag, &
27405 comm%handle, recv_request%handle, ierr)
27406 ELSE
27407 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27408 comm%handle, recv_request%handle, ierr)
27409 END IF
27410 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27411
27412 msglen = SIZE(msgin, 1)
27413 IF (msglen > 0) THEN
27414 CALL mpi_isend(msgin(1), msglen, mpi_double_complex, dest, my_tag, &
27415 comm%handle, send_request%handle, ierr)
27416 ELSE
27417 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27418 comm%handle, send_request%handle, ierr)
27419 END IF
27420 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27421
27422 msglen = (msglen + SIZE(msgout, 1) + 1)/2
27423 CALL add_perf(perf_id=8, count=1, msg_size=msglen*(2*real_8_size))
27424#else
27425 mark_used(dest)
27426 mark_used(source)
27427 mark_used(comm)
27428 mark_used(tag)
27429 send_request = mp_request_null
27430 recv_request = mp_request_null
27431 msgout = msgin
27432#endif
27433 CALL mp_timestop(handle)
27434 END SUBROUTINE mp_isendrecv_zv
27435
27436! **************************************************************************************************
27437!> \brief Non-blocking send of vector data
27438!> \param msgin ...
27439!> \param dest ...
27440!> \param comm ...
27441!> \param request ...
27442!> \param tag ...
27443!> \par History
27444!> 08.2003 created [f&j]
27445!> \note see mp_isendrecv_zv
27446!> \note
27447!> arrays can be pointers or assumed shape, but they must be contiguous!
27448! **************************************************************************************************
27449 SUBROUTINE mp_isend_zv(msgin, dest, comm, request, tag)
27450 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
27451 INTEGER, INTENT(IN) :: dest
27452 CLASS(mp_comm_type), INTENT(IN) :: comm
27453 TYPE(mp_request_type), INTENT(out) :: request
27454 INTEGER, INTENT(in), OPTIONAL :: tag
27455
27456 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zv'
27457
27458 INTEGER :: handle, ierr
27459#if defined(__parallel)
27460 INTEGER :: msglen, my_tag
27461 COMPLEX(kind=real_8) :: foo(1)
27462#endif
27463
27464 CALL mp_timeset(routinen, handle)
27465
27466#if defined(__parallel)
27467#if !defined(__GNUC__) || __GNUC__ >= 9
27468 cpassert(is_contiguous(msgin))
27469#endif
27470 my_tag = 0
27471 IF (PRESENT(tag)) my_tag = tag
27472
27473 msglen = SIZE(msgin)
27474 IF (msglen > 0) THEN
27475 CALL mpi_isend(msgin(1), msglen, mpi_double_complex, dest, my_tag, &
27476 comm%handle, request%handle, ierr)
27477 ELSE
27478 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27479 comm%handle, request%handle, ierr)
27480 END IF
27481 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27482
27483 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27484#else
27485 mark_used(msgin)
27486 mark_used(dest)
27487 mark_used(comm)
27488 mark_used(request)
27489 mark_used(tag)
27490 ierr = 1
27491 request = mp_request_null
27492 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27493#endif
27494 CALL mp_timestop(handle)
27495 END SUBROUTINE mp_isend_zv
27496
27497! **************************************************************************************************
27498!> \brief Non-blocking send of matrix data
27499!> \param msgin ...
27500!> \param dest ...
27501!> \param comm ...
27502!> \param request ...
27503!> \param tag ...
27504!> \par History
27505!> 2009-11-25 [UB] Made type-generic for templates
27506!> \author fawzi
27507!> \note see mp_isendrecv_zv
27508!> \note see mp_isend_zv
27509!> \note
27510!> arrays can be pointers or assumed shape, but they must be contiguous!
27511! **************************************************************************************************
27512 SUBROUTINE mp_isend_zm2(msgin, dest, comm, request, tag)
27513 COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(IN) :: msgin
27514 INTEGER, INTENT(IN) :: dest
27515 CLASS(mp_comm_type), INTENT(IN) :: comm
27516 TYPE(mp_request_type), INTENT(out) :: request
27517 INTEGER, INTENT(in), OPTIONAL :: tag
27518
27519 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm2'
27520
27521 INTEGER :: handle, ierr
27522#if defined(__parallel)
27523 INTEGER :: msglen, my_tag
27524 COMPLEX(kind=real_8) :: foo(1)
27525#endif
27526
27527 CALL mp_timeset(routinen, handle)
27528
27529#if defined(__parallel)
27530#if !defined(__GNUC__) || __GNUC__ >= 9
27531 cpassert(is_contiguous(msgin))
27532#endif
27533
27534 my_tag = 0
27535 IF (PRESENT(tag)) my_tag = tag
27536
27537 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
27538 IF (msglen > 0) THEN
27539 CALL mpi_isend(msgin(1, 1), msglen, mpi_double_complex, dest, my_tag, &
27540 comm%handle, request%handle, ierr)
27541 ELSE
27542 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27543 comm%handle, request%handle, ierr)
27544 END IF
27545 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27546
27547 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27548#else
27549 mark_used(msgin)
27550 mark_used(dest)
27551 mark_used(comm)
27552 mark_used(request)
27553 mark_used(tag)
27554 ierr = 1
27555 request = mp_request_null
27556 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27557#endif
27558 CALL mp_timestop(handle)
27559 END SUBROUTINE mp_isend_zm2
27560
27561! **************************************************************************************************
27562!> \brief Non-blocking send of rank-3 data
27563!> \param msgin ...
27564!> \param dest ...
27565!> \param comm ...
27566!> \param request ...
27567!> \param tag ...
27568!> \par History
27569!> 9.2008 added _rm3 subroutine [Iain Bethune]
27570!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
27571!> 2009-11-25 [UB] Made type-generic for templates
27572!> \author fawzi
27573!> \note see mp_isendrecv_zv
27574!> \note see mp_isend_zv
27575!> \note
27576!> arrays can be pointers or assumed shape, but they must be contiguous!
27577! **************************************************************************************************
27578 SUBROUTINE mp_isend_zm3(msgin, dest, comm, request, tag)
27579 COMPLEX(kind=real_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
27580 INTEGER, INTENT(IN) :: dest
27581 CLASS(mp_comm_type), INTENT(IN) :: comm
27582 TYPE(mp_request_type), INTENT(out) :: request
27583 INTEGER, INTENT(in), OPTIONAL :: tag
27584
27585 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm3'
27586
27587 INTEGER :: handle, ierr
27588#if defined(__parallel)
27589 INTEGER :: msglen, my_tag
27590 COMPLEX(kind=real_8) :: foo(1)
27591#endif
27592
27593 CALL mp_timeset(routinen, handle)
27594
27595#if defined(__parallel)
27596#if !defined(__GNUC__) || __GNUC__ >= 9
27597 cpassert(is_contiguous(msgin))
27598#endif
27599
27600 my_tag = 0
27601 IF (PRESENT(tag)) my_tag = tag
27602
27603 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
27604 IF (msglen > 0) THEN
27605 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_double_complex, dest, my_tag, &
27606 comm%handle, request%handle, ierr)
27607 ELSE
27608 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27609 comm%handle, request%handle, ierr)
27610 END IF
27611 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27612
27613 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27614#else
27615 mark_used(msgin)
27616 mark_used(dest)
27617 mark_used(comm)
27618 mark_used(request)
27619 mark_used(tag)
27620 ierr = 1
27621 request = mp_request_null
27622 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27623#endif
27624 CALL mp_timestop(handle)
27625 END SUBROUTINE mp_isend_zm3
27626
27627! **************************************************************************************************
27628!> \brief Non-blocking send of rank-4 data
27629!> \param msgin the input message
27630!> \param dest the destination processor
27631!> \param comm the communicator object
27632!> \param request the communication request id
27633!> \param tag the message tag
27634!> \par History
27635!> 2.2016 added _zm4 subroutine [Nico Holmberg]
27636!> \author fawzi
27637!> \note see mp_isend_zv
27638!> \note
27639!> arrays can be pointers or assumed shape, but they must be contiguous!
27640! **************************************************************************************************
27641 SUBROUTINE mp_isend_zm4(msgin, dest, comm, request, tag)
27642 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
27643 INTEGER, INTENT(IN) :: dest
27644 CLASS(mp_comm_type), INTENT(IN) :: comm
27645 TYPE(mp_request_type), INTENT(out) :: request
27646 INTEGER, INTENT(in), OPTIONAL :: tag
27647
27648 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm4'
27649
27650 INTEGER :: handle, ierr
27651#if defined(__parallel)
27652 INTEGER :: msglen, my_tag
27653 COMPLEX(kind=real_8) :: foo(1)
27654#endif
27655
27656 CALL mp_timeset(routinen, handle)
27657
27658#if defined(__parallel)
27659#if !defined(__GNUC__) || __GNUC__ >= 9
27660 cpassert(is_contiguous(msgin))
27661#endif
27662
27663 my_tag = 0
27664 IF (PRESENT(tag)) my_tag = tag
27665
27666 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
27667 IF (msglen > 0) THEN
27668 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_double_complex, dest, my_tag, &
27669 comm%handle, request%handle, ierr)
27670 ELSE
27671 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27672 comm%handle, request%handle, ierr)
27673 END IF
27674 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27675
27676 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27677#else
27678 mark_used(msgin)
27679 mark_used(dest)
27680 mark_used(comm)
27681 mark_used(request)
27682 mark_used(tag)
27683 ierr = 1
27684 request = mp_request_null
27685 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27686#endif
27687 CALL mp_timestop(handle)
27688 END SUBROUTINE mp_isend_zm4
27689
27690! **************************************************************************************************
27691!> \brief Non-blocking receive of vector data
27692!> \param msgout ...
27693!> \param source ...
27694!> \param comm ...
27695!> \param request ...
27696!> \param tag ...
27697!> \par History
27698!> 08.2003 created [f&j]
27699!> 2009-11-25 [UB] Made type-generic for templates
27700!> \note see mp_isendrecv_zv
27701!> \note
27702!> arrays can be pointers or assumed shape, but they must be contiguous!
27703! **************************************************************************************************
27704 SUBROUTINE mp_irecv_zv(msgout, source, comm, request, tag)
27705 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
27706 INTEGER, INTENT(IN) :: source
27707 CLASS(mp_comm_type), INTENT(IN) :: comm
27708 TYPE(mp_request_type), INTENT(out) :: request
27709 INTEGER, INTENT(in), OPTIONAL :: tag
27710
27711 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zv'
27712
27713 INTEGER :: handle
27714#if defined(__parallel)
27715 INTEGER :: ierr, msglen, my_tag
27716 COMPLEX(kind=real_8) :: foo(1)
27717#endif
27718
27719 CALL mp_timeset(routinen, handle)
27720
27721#if defined(__parallel)
27722#if !defined(__GNUC__) || __GNUC__ >= 9
27723 cpassert(is_contiguous(msgout))
27724#endif
27725
27726 my_tag = 0
27727 IF (PRESENT(tag)) my_tag = tag
27728
27729 msglen = SIZE(msgout)
27730 IF (msglen > 0) THEN
27731 CALL mpi_irecv(msgout(1), msglen, mpi_double_complex, source, my_tag, &
27732 comm%handle, request%handle, ierr)
27733 ELSE
27734 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27735 comm%handle, request%handle, ierr)
27736 END IF
27737 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27738
27739 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27740#else
27741 cpabort("mp_irecv called in non parallel case")
27742 mark_used(msgout)
27743 mark_used(source)
27744 mark_used(comm)
27745 mark_used(tag)
27746 request = mp_request_null
27747#endif
27748 CALL mp_timestop(handle)
27749 END SUBROUTINE mp_irecv_zv
27750
27751! **************************************************************************************************
27752!> \brief Non-blocking receive of matrix data
27753!> \param msgout ...
27754!> \param source ...
27755!> \param comm ...
27756!> \param request ...
27757!> \param tag ...
27758!> \par History
27759!> 2009-11-25 [UB] Made type-generic for templates
27760!> \author fawzi
27761!> \note see mp_isendrecv_zv
27762!> \note see mp_irecv_zv
27763!> \note
27764!> arrays can be pointers or assumed shape, but they must be contiguous!
27765! **************************************************************************************************
27766 SUBROUTINE mp_irecv_zm2(msgout, source, comm, request, tag)
27767 COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
27768 INTEGER, INTENT(IN) :: source
27769 CLASS(mp_comm_type), INTENT(IN) :: comm
27770 TYPE(mp_request_type), INTENT(out) :: request
27771 INTEGER, INTENT(in), OPTIONAL :: tag
27772
27773 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm2'
27774
27775 INTEGER :: handle
27776#if defined(__parallel)
27777 INTEGER :: ierr, msglen, my_tag
27778 COMPLEX(kind=real_8) :: foo(1)
27779#endif
27780
27781 CALL mp_timeset(routinen, handle)
27782
27783#if defined(__parallel)
27784#if !defined(__GNUC__) || __GNUC__ >= 9
27785 cpassert(is_contiguous(msgout))
27786#endif
27787
27788 my_tag = 0
27789 IF (PRESENT(tag)) my_tag = tag
27790
27791 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
27792 IF (msglen > 0) THEN
27793 CALL mpi_irecv(msgout(1, 1), msglen, mpi_double_complex, source, my_tag, &
27794 comm%handle, request%handle, ierr)
27795 ELSE
27796 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27797 comm%handle, request%handle, ierr)
27798 END IF
27799 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27800
27801 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27802#else
27803 mark_used(msgout)
27804 mark_used(source)
27805 mark_used(comm)
27806 mark_used(tag)
27807 request = mp_request_null
27808 cpabort("mp_irecv called in non parallel case")
27809#endif
27810 CALL mp_timestop(handle)
27811 END SUBROUTINE mp_irecv_zm2
27812
27813! **************************************************************************************************
27814!> \brief Non-blocking send of rank-3 data
27815!> \param msgout ...
27816!> \param source ...
27817!> \param comm ...
27818!> \param request ...
27819!> \param tag ...
27820!> \par History
27821!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
27822!> 2009-11-25 [UB] Made type-generic for templates
27823!> \author fawzi
27824!> \note see mp_isendrecv_zv
27825!> \note see mp_irecv_zv
27826!> \note
27827!> arrays can be pointers or assumed shape, but they must be contiguous!
27828! **************************************************************************************************
27829 SUBROUTINE mp_irecv_zm3(msgout, source, comm, request, tag)
27830 COMPLEX(kind=real_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
27831 INTEGER, INTENT(IN) :: source
27832 CLASS(mp_comm_type), INTENT(IN) :: comm
27833 TYPE(mp_request_type), INTENT(out) :: request
27834 INTEGER, INTENT(in), OPTIONAL :: tag
27835
27836 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm3'
27837
27838 INTEGER :: handle
27839#if defined(__parallel)
27840 INTEGER :: ierr, msglen, my_tag
27841 COMPLEX(kind=real_8) :: foo(1)
27842#endif
27843
27844 CALL mp_timeset(routinen, handle)
27845
27846#if defined(__parallel)
27847#if !defined(__GNUC__) || __GNUC__ >= 9
27848 cpassert(is_contiguous(msgout))
27849#endif
27850
27851 my_tag = 0
27852 IF (PRESENT(tag)) my_tag = tag
27853
27854 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
27855 IF (msglen > 0) THEN
27856 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_double_complex, source, my_tag, &
27857 comm%handle, request%handle, ierr)
27858 ELSE
27859 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27860 comm%handle, request%handle, ierr)
27861 END IF
27862 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
27863
27864 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27865#else
27866 mark_used(msgout)
27867 mark_used(source)
27868 mark_used(comm)
27869 mark_used(tag)
27870 request = mp_request_null
27871 cpabort("mp_irecv called in non parallel case")
27872#endif
27873 CALL mp_timestop(handle)
27874 END SUBROUTINE mp_irecv_zm3
27875
27876! **************************************************************************************************
27877!> \brief Non-blocking receive of rank-4 data
27878!> \param msgout the output message
27879!> \param source the source processor
27880!> \param comm the communicator object
27881!> \param request the communication request id
27882!> \param tag the message tag
27883!> \par History
27884!> 2.2016 added _zm4 subroutine [Nico Holmberg]
27885!> \author fawzi
27886!> \note see mp_irecv_zv
27887!> \note
27888!> arrays can be pointers or assumed shape, but they must be contiguous!
27889! **************************************************************************************************
27890 SUBROUTINE mp_irecv_zm4(msgout, source, comm, request, tag)
27891 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
27892 INTEGER, INTENT(IN) :: source
27893 CLASS(mp_comm_type), INTENT(IN) :: comm
27894 TYPE(mp_request_type), INTENT(out) :: request
27895 INTEGER, INTENT(in), OPTIONAL :: tag
27896
27897 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm4'
27898
27899 INTEGER :: handle
27900#if defined(__parallel)
27901 INTEGER :: ierr, msglen, my_tag
27902 COMPLEX(kind=real_8) :: foo(1)
27903#endif
27904
27905 CALL mp_timeset(routinen, handle)
27906
27907#if defined(__parallel)
27908#if !defined(__GNUC__) || __GNUC__ >= 9
27909 cpassert(is_contiguous(msgout))
27910#endif
27911
27912 my_tag = 0
27913 IF (PRESENT(tag)) my_tag = tag
27914
27915 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
27916 IF (msglen > 0) THEN
27917 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_double_complex, source, my_tag, &
27918 comm%handle, request%handle, ierr)
27919 ELSE
27920 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27921 comm%handle, request%handle, ierr)
27922 END IF
27923 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
27924
27925 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27926#else
27927 mark_used(msgout)
27928 mark_used(source)
27929 mark_used(comm)
27930 mark_used(tag)
27931 request = mp_request_null
27932 cpabort("mp_irecv called in non parallel case")
27933#endif
27934 CALL mp_timestop(handle)
27935 END SUBROUTINE mp_irecv_zm4
27936
27937! **************************************************************************************************
27938!> \brief Window initialization function for vector data
27939!> \param base ...
27940!> \param comm ...
27941!> \param win ...
27942!> \par History
27943!> 02.2015 created [Alfio Lazzaro]
27944!> \note
27945!> arrays can be pointers or assumed shape, but they must be contiguous!
27946! **************************************************************************************************
27947 SUBROUTINE mp_win_create_zv(base, comm, win)
27948 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
27949 TYPE(mp_comm_type), INTENT(IN) :: comm
27950 CLASS(mp_win_type), INTENT(INOUT) :: win
27951
27952 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_zv'
27953
27954 INTEGER :: handle
27955#if defined(__parallel)
27956 INTEGER :: ierr
27957 INTEGER(kind=mpi_address_kind) :: len
27958 COMPLEX(kind=real_8) :: foo(1)
27959#endif
27960
27961 CALL mp_timeset(routinen, handle)
27962
27963#if defined(__parallel)
27964
27965 len = SIZE(base)*(2*real_8_size)
27966 IF (len > 0) THEN
27967 CALL mpi_win_create(base(1), len, (2*real_8_size), mpi_info_null, comm%handle, win%handle, ierr)
27968 ELSE
27969 CALL mpi_win_create(foo, len, (2*real_8_size), mpi_info_null, comm%handle, win%handle, ierr)
27970 END IF
27971 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
27972
27973 CALL add_perf(perf_id=20, count=1)
27974#else
27975 mark_used(base)
27976 mark_used(comm)
27977 win%handle = mp_win_null_handle
27978#endif
27979 CALL mp_timestop(handle)
27980 END SUBROUTINE mp_win_create_zv
27981
27982! **************************************************************************************************
27983!> \brief Single-sided get function for vector data
27984!> \param base ...
27985!> \param comm ...
27986!> \param win ...
27987!> \par History
27988!> 02.2015 created [Alfio Lazzaro]
27989!> \note
27990!> arrays can be pointers or assumed shape, but they must be contiguous!
27991! **************************************************************************************************
27992 SUBROUTINE mp_rget_zv(base, source, win, win_data, myproc, disp, request, &
27993 origin_datatype, target_datatype)
27994 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
27995 INTEGER, INTENT(IN) :: source
27996 CLASS(mp_win_type), INTENT(IN) :: win
27997 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: win_data
27998 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
27999 TYPE(mp_request_type), INTENT(OUT) :: request
28000 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
28001
28002 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_zv'
28003
28004 INTEGER :: handle
28005#if defined(__parallel)
28006 INTEGER :: ierr, len, &
28007 origin_len, target_len
28008 LOGICAL :: do_local_copy
28009 INTEGER(kind=mpi_address_kind) :: disp_aint
28010 mpi_data_type :: handle_origin_datatype, handle_target_datatype
28011#endif
28012
28013 CALL mp_timeset(routinen, handle)
28014
28015#if defined(__parallel)
28016 len = SIZE(base)
28017 disp_aint = 0
28018 IF (PRESENT(disp)) THEN
28019 disp_aint = int(disp, kind=mpi_address_kind)
28020 END IF
28021 handle_origin_datatype = mpi_double_complex
28022 origin_len = len
28023 IF (PRESENT(origin_datatype)) THEN
28024 handle_origin_datatype = origin_datatype%type_handle
28025 origin_len = 1
28026 END IF
28027 handle_target_datatype = mpi_double_complex
28028 target_len = len
28029 IF (PRESENT(target_datatype)) THEN
28030 handle_target_datatype = target_datatype%type_handle
28031 target_len = 1
28032 END IF
28033 IF (len > 0) THEN
28034 do_local_copy = .false.
28035 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
28036 IF (myproc .EQ. source) do_local_copy = .true.
28037 END IF
28038 IF (do_local_copy) THEN
28039 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
28040 base(:) = win_data(disp_aint + 1:disp_aint + len)
28041 !$OMP END PARALLEL WORKSHARE
28042 request = mp_request_null
28043 ierr = 0
28044 ELSE
28045 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
28046 target_len, handle_target_datatype, win%handle, request%handle, ierr)
28047 END IF
28048 ELSE
28049 request = mp_request_null
28050 ierr = 0
28051 END IF
28052 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
28053
28054 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*(2*real_8_size))
28055#else
28056 mark_used(source)
28057 mark_used(win)
28058 mark_used(myproc)
28059 mark_used(origin_datatype)
28060 mark_used(target_datatype)
28061
28062 request = mp_request_null
28063 !
28064 IF (PRESENT(disp)) THEN
28065 base(:) = win_data(disp + 1:disp + SIZE(base))
28066 ELSE
28067 base(:) = win_data(:SIZE(base))
28068 END IF
28069
28070#endif
28071 CALL mp_timestop(handle)
28072 END SUBROUTINE mp_rget_zv
28073
28074! **************************************************************************************************
28075!> \brief ...
28076!> \param count ...
28077!> \param lengths ...
28078!> \param displs ...
28079!> \return ...
28080! ***************************************************************************
28081 FUNCTION mp_type_indexed_make_z (count, lengths, displs) &
28082 result(type_descriptor)
28083 INTEGER, INTENT(IN) :: count
28084 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
28085 TYPE(mp_type_descriptor_type) :: type_descriptor
28086
28087 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_z'
28088
28089 INTEGER :: handle
28090#if defined(__parallel)
28091 INTEGER :: ierr
28092#endif
28093
28094 CALL mp_timeset(routinen, handle)
28095
28096#if defined(__parallel)
28097 CALL mpi_type_indexed(count, lengths, displs, mpi_double_complex, &
28098 type_descriptor%type_handle, ierr)
28099 IF (ierr /= 0) &
28100 cpabort("MPI_Type_Indexed @ "//routinen)
28101 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
28102 IF (ierr /= 0) &
28103 cpabort("MPI_Type_commit @ "//routinen)
28104#else
28105 type_descriptor%type_handle = 7
28106#endif
28107 type_descriptor%length = count
28108 NULLIFY (type_descriptor%subtype)
28109 type_descriptor%vector_descriptor(1:2) = 1
28110 type_descriptor%has_indexing = .true.
28111 type_descriptor%index_descriptor%index => lengths
28112 type_descriptor%index_descriptor%chunks => displs
28113
28114 CALL mp_timestop(handle)
28115
28116 END FUNCTION mp_type_indexed_make_z
28117
28118! **************************************************************************************************
28119!> \brief Allocates special parallel memory
28120!> \param[in] DATA pointer to integer array to allocate
28121!> \param[in] len number of integers to allocate
28122!> \param[out] stat (optional) allocation status result
28123!> \author UB
28124! **************************************************************************************************
28125 SUBROUTINE mp_allocate_z (DATA, len, stat)
28126 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
28127 INTEGER, INTENT(IN) :: len
28128 INTEGER, INTENT(OUT), OPTIONAL :: stat
28129
28130 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_z'
28131
28132 INTEGER :: handle, ierr
28133
28134 CALL mp_timeset(routinen, handle)
28135
28136#if defined(__parallel)
28137 NULLIFY (data)
28138 CALL mp_alloc_mem(DATA, len, stat=ierr)
28139 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
28140 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
28141 CALL add_perf(perf_id=15, count=1)
28142#else
28143 ALLOCATE (DATA(len), stat=ierr)
28144 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
28145 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
28146#endif
28147 IF (PRESENT(stat)) stat = ierr
28148 CALL mp_timestop(handle)
28149 END SUBROUTINE mp_allocate_z
28150
28151! **************************************************************************************************
28152!> \brief Deallocates special parallel memory
28153!> \param[in] DATA pointer to special memory to deallocate
28154!> \param stat ...
28155!> \author UB
28156! **************************************************************************************************
28157 SUBROUTINE mp_deallocate_z (DATA, stat)
28158 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
28159 INTEGER, INTENT(OUT), OPTIONAL :: stat
28160
28161 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_z'
28162
28163 INTEGER :: handle
28164#if defined(__parallel)
28165 INTEGER :: ierr
28166#endif
28167
28168 CALL mp_timeset(routinen, handle)
28169
28170#if defined(__parallel)
28171 CALL mp_free_mem(DATA, ierr)
28172 IF (PRESENT(stat)) THEN
28173 stat = ierr
28174 ELSE
28175 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
28176 END IF
28177 NULLIFY (data)
28178 CALL add_perf(perf_id=15, count=1)
28179#else
28180 DEALLOCATE (data)
28181 IF (PRESENT(stat)) stat = 0
28182#endif
28183 CALL mp_timestop(handle)
28184 END SUBROUTINE mp_deallocate_z
28185
28186! **************************************************************************************************
28187!> \brief (parallel) Blocking individual file write using explicit offsets
28188!> (serial) Unformatted stream write
28189!> \param[in] fh file handle (file storage unit)
28190!> \param[in] offset file offset (position)
28191!> \param[in] msg data to be written to the file
28192!> \param msglen ...
28193!> \par MPI-I/O mapping mpi_file_write_at
28194!> \par STREAM-I/O mapping WRITE
28195!> \param[in](optional) msglen number of the elements of data
28196! **************************************************************************************************
28197 SUBROUTINE mp_file_write_at_zv(fh, offset, msg, msglen)
28198 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
28199 CLASS(mp_file_type), INTENT(IN) :: fh
28200 INTEGER, INTENT(IN), OPTIONAL :: msglen
28201 INTEGER(kind=file_offset), INTENT(IN) :: offset
28202
28203 INTEGER :: msg_len
28204#if defined(__parallel)
28205 INTEGER :: ierr
28206#endif
28207
28208 msg_len = SIZE(msg)
28209 IF (PRESENT(msglen)) msg_len = msglen
28210#if defined(__parallel)
28211 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28212 IF (ierr .NE. 0) &
28213 cpabort("mpi_file_write_at_zv @ mp_file_write_at_zv")
28214#else
28215 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28216#endif
28217 END SUBROUTINE mp_file_write_at_zv
28218
28219! **************************************************************************************************
28220!> \brief ...
28221!> \param fh ...
28222!> \param offset ...
28223!> \param msg ...
28224! **************************************************************************************************
28225 SUBROUTINE mp_file_write_at_z (fh, offset, msg)
28226 COMPLEX(kind=real_8), INTENT(IN) :: msg
28227 CLASS(mp_file_type), INTENT(IN) :: fh
28228 INTEGER(kind=file_offset), INTENT(IN) :: offset
28229
28230#if defined(__parallel)
28231 INTEGER :: ierr
28232
28233 ierr = 0
28234 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28235 IF (ierr .NE. 0) &
28236 cpabort("mpi_file_write_at_z @ mp_file_write_at_z")
28237#else
28238 WRITE (unit=fh%handle, pos=offset + 1) msg
28239#endif
28240 END SUBROUTINE mp_file_write_at_z
28241
28242! **************************************************************************************************
28243!> \brief (parallel) Blocking collective file write using explicit offsets
28244!> (serial) Unformatted stream write
28245!> \param fh ...
28246!> \param offset ...
28247!> \param msg ...
28248!> \param msglen ...
28249!> \par MPI-I/O mapping mpi_file_write_at_all
28250!> \par STREAM-I/O mapping WRITE
28251! **************************************************************************************************
28252 SUBROUTINE mp_file_write_at_all_zv(fh, offset, msg, msglen)
28253 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
28254 CLASS(mp_file_type), INTENT(IN) :: fh
28255 INTEGER, INTENT(IN), OPTIONAL :: msglen
28256 INTEGER(kind=file_offset), INTENT(IN) :: offset
28257
28258 INTEGER :: msg_len
28259#if defined(__parallel)
28260 INTEGER :: ierr
28261#endif
28262
28263 msg_len = SIZE(msg)
28264 IF (PRESENT(msglen)) msg_len = msglen
28265#if defined(__parallel)
28266 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28267 IF (ierr .NE. 0) &
28268 cpabort("mpi_file_write_at_all_zv @ mp_file_write_at_all_zv")
28269#else
28270 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28271#endif
28272 END SUBROUTINE mp_file_write_at_all_zv
28273
28274! **************************************************************************************************
28275!> \brief ...
28276!> \param fh ...
28277!> \param offset ...
28278!> \param msg ...
28279! **************************************************************************************************
28280 SUBROUTINE mp_file_write_at_all_z (fh, offset, msg)
28281 COMPLEX(kind=real_8), INTENT(IN) :: msg
28282 CLASS(mp_file_type), INTENT(IN) :: fh
28283 INTEGER(kind=file_offset), INTENT(IN) :: offset
28284
28285#if defined(__parallel)
28286 INTEGER :: ierr
28287
28288 ierr = 0
28289 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28290 IF (ierr .NE. 0) &
28291 cpabort("mpi_file_write_at_all_z @ mp_file_write_at_all_z")
28292#else
28293 WRITE (unit=fh%handle, pos=offset + 1) msg
28294#endif
28295 END SUBROUTINE mp_file_write_at_all_z
28296
28297! **************************************************************************************************
28298!> \brief (parallel) Blocking individual file read using explicit offsets
28299!> (serial) Unformatted stream read
28300!> \param[in] fh file handle (file storage unit)
28301!> \param[in] offset file offset (position)
28302!> \param[out] msg data to be read from the file
28303!> \param msglen ...
28304!> \par MPI-I/O mapping mpi_file_read_at
28305!> \par STREAM-I/O mapping READ
28306!> \param[in](optional) msglen number of elements of data
28307! **************************************************************************************************
28308 SUBROUTINE mp_file_read_at_zv(fh, offset, msg, msglen)
28309 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
28310 CLASS(mp_file_type), INTENT(IN) :: fh
28311 INTEGER, INTENT(IN), OPTIONAL :: msglen
28312 INTEGER(kind=file_offset), INTENT(IN) :: offset
28313
28314 INTEGER :: msg_len
28315#if defined(__parallel)
28316 INTEGER :: ierr
28317#endif
28318
28319 msg_len = SIZE(msg)
28320 IF (PRESENT(msglen)) msg_len = msglen
28321#if defined(__parallel)
28322 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28323 IF (ierr .NE. 0) &
28324 cpabort("mpi_file_read_at_zv @ mp_file_read_at_zv")
28325#else
28326 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28327#endif
28328 END SUBROUTINE mp_file_read_at_zv
28329
28330! **************************************************************************************************
28331!> \brief ...
28332!> \param fh ...
28333!> \param offset ...
28334!> \param msg ...
28335! **************************************************************************************************
28336 SUBROUTINE mp_file_read_at_z (fh, offset, msg)
28337 COMPLEX(kind=real_8), INTENT(OUT) :: msg
28338 CLASS(mp_file_type), INTENT(IN) :: fh
28339 INTEGER(kind=file_offset), INTENT(IN) :: offset
28340
28341#if defined(__parallel)
28342 INTEGER :: ierr
28343
28344 ierr = 0
28345 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28346 IF (ierr .NE. 0) &
28347 cpabort("mpi_file_read_at_z @ mp_file_read_at_z")
28348#else
28349 READ (unit=fh%handle, pos=offset + 1) msg
28350#endif
28351 END SUBROUTINE mp_file_read_at_z
28352
28353! **************************************************************************************************
28354!> \brief (parallel) Blocking collective file read using explicit offsets
28355!> (serial) Unformatted stream read
28356!> \param fh ...
28357!> \param offset ...
28358!> \param msg ...
28359!> \param msglen ...
28360!> \par MPI-I/O mapping mpi_file_read_at_all
28361!> \par STREAM-I/O mapping READ
28362! **************************************************************************************************
28363 SUBROUTINE mp_file_read_at_all_zv(fh, offset, msg, msglen)
28364 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
28365 CLASS(mp_file_type), INTENT(IN) :: fh
28366 INTEGER, INTENT(IN), OPTIONAL :: msglen
28367 INTEGER(kind=file_offset), INTENT(IN) :: offset
28368
28369 INTEGER :: msg_len
28370#if defined(__parallel)
28371 INTEGER :: ierr
28372#endif
28373
28374 msg_len = SIZE(msg)
28375 IF (PRESENT(msglen)) msg_len = msglen
28376#if defined(__parallel)
28377 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28378 IF (ierr .NE. 0) &
28379 cpabort("mpi_file_read_at_all_zv @ mp_file_read_at_all_zv")
28380#else
28381 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28382#endif
28383 END SUBROUTINE mp_file_read_at_all_zv
28384
28385! **************************************************************************************************
28386!> \brief ...
28387!> \param fh ...
28388!> \param offset ...
28389!> \param msg ...
28390! **************************************************************************************************
28391 SUBROUTINE mp_file_read_at_all_z (fh, offset, msg)
28392 COMPLEX(kind=real_8), INTENT(OUT) :: msg
28393 CLASS(mp_file_type), INTENT(IN) :: fh
28394 INTEGER(kind=file_offset), INTENT(IN) :: offset
28395
28396#if defined(__parallel)
28397 INTEGER :: ierr
28398
28399 ierr = 0
28400 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28401 IF (ierr .NE. 0) &
28402 cpabort("mpi_file_read_at_all_z @ mp_file_read_at_all_z")
28403#else
28404 READ (unit=fh%handle, pos=offset + 1) msg
28405#endif
28406 END SUBROUTINE mp_file_read_at_all_z
28407
28408! **************************************************************************************************
28409!> \brief ...
28410!> \param ptr ...
28411!> \param vector_descriptor ...
28412!> \param index_descriptor ...
28413!> \return ...
28414! **************************************************************************************************
28415 FUNCTION mp_type_make_z (ptr, &
28416 vector_descriptor, index_descriptor) &
28417 result(type_descriptor)
28418 COMPLEX(kind=real_8), DIMENSION(:), TARGET, asynchronous :: ptr
28419 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
28420 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
28421 TYPE(mp_type_descriptor_type) :: type_descriptor
28422
28423 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_z'
28424
28425#if defined(__parallel)
28426 INTEGER :: ierr
28427#endif
28428
28429 NULLIFY (type_descriptor%subtype)
28430 type_descriptor%length = SIZE(ptr)
28431#if defined(__parallel)
28432 type_descriptor%type_handle = mpi_double_complex
28433 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
28434 IF (ierr /= 0) &
28435 cpabort("MPI_Get_address @ "//routinen)
28436#else
28437 type_descriptor%type_handle = 7
28438#endif
28439 type_descriptor%vector_descriptor(1:2) = 1
28440 type_descriptor%has_indexing = .false.
28441 type_descriptor%data_z => ptr
28442 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
28443 cpabort(routinen//": Vectors and indices NYI")
28444 END IF
28445 END FUNCTION mp_type_make_z
28446
28447! **************************************************************************************************
28448!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
28449!> as the Fortran version returns an integer, which we take to be a C_PTR
28450!> \param DATA data array to allocate
28451!> \param[in] len length (in data elements) of data array allocation
28452!> \param[out] stat (optional) allocation status result
28453! **************************************************************************************************
28454 SUBROUTINE mp_alloc_mem_z (DATA, len, stat)
28455 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: data
28456 INTEGER, INTENT(IN) :: len
28457 INTEGER, INTENT(OUT), OPTIONAL :: stat
28458
28459#if defined(__parallel)
28460 INTEGER :: size, ierr, length, &
28461 mp_res
28462 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
28463 TYPE(c_ptr) :: mp_baseptr
28464 mpi_info_type :: mp_info
28465
28466 length = max(len, 1)
28467 CALL mpi_type_size(mpi_double_complex, size, ierr)
28468 mp_size = int(length, kind=mpi_address_kind)*size
28469 IF (mp_size .GT. mp_max_memory_size) THEN
28470 cpabort("MPI cannot allocate more than 2 GiByte")
28471 END IF
28472 mp_info = mpi_info_null
28473 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
28474 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
28475 IF (PRESENT(stat)) stat = mp_res
28476#else
28477 INTEGER :: length, mystat
28478 length = max(len, 1)
28479 IF (PRESENT(stat)) THEN
28480 ALLOCATE (DATA(length), stat=mystat)
28481 stat = mystat ! show to convention checker that stat is used
28482 ELSE
28483 ALLOCATE (DATA(length))
28484 END IF
28485#endif
28486 END SUBROUTINE mp_alloc_mem_z
28487
28488! **************************************************************************************************
28489!> \brief Deallocates am array, ... this is hackish
28490!> as the Fortran version takes an integer, which we hope to get by reference
28491!> \param DATA data array to allocate
28492!> \param[out] stat (optional) allocation status result
28493! **************************************************************************************************
28494 SUBROUTINE mp_free_mem_z (DATA, stat)
28495 COMPLEX(kind=real_8), DIMENSION(:), &
28496 POINTER, asynchronous :: data
28497 INTEGER, INTENT(OUT), OPTIONAL :: stat
28498
28499#if defined(__parallel)
28500 INTEGER :: mp_res
28501 CALL mpi_free_mem(DATA, mp_res)
28502 IF (PRESENT(stat)) stat = mp_res
28503#else
28504 DEALLOCATE (data)
28505 IF (PRESENT(stat)) stat = 0
28506#endif
28507 END SUBROUTINE mp_free_mem_z
28508! **************************************************************************************************
28509!> \brief Shift around the data in msg
28510!> \param[in,out] msg Rank-2 data to shift
28511!> \param[in] comm message passing environment identifier
28512!> \param[in] displ_in displacements (?)
28513!> \par Example
28514!> msg will be moved from rank to rank+displ_in (in a circular way)
28515!> \par Limitations
28516!> * displ_in will be 1 by default (others not tested)
28517!> * the message array needs to be the same size on all processes
28518! **************************************************************************************************
28519 SUBROUTINE mp_shift_cm(msg, comm, displ_in)
28520
28521 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
28522 CLASS(mp_comm_type), INTENT(IN) :: comm
28523 INTEGER, INTENT(IN), OPTIONAL :: displ_in
28524
28525 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_cm'
28526
28527 INTEGER :: handle, ierror
28528#if defined(__parallel)
28529 INTEGER :: displ, left, &
28530 msglen, myrank, nprocs, &
28531 right, tag
28532#endif
28533
28534 ierror = 0
28535 CALL mp_timeset(routinen, handle)
28536
28537#if defined(__parallel)
28538 CALL mpi_comm_rank(comm%handle, myrank, ierror)
28539 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
28540 CALL mpi_comm_size(comm%handle, nprocs, ierror)
28541 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
28542 IF (PRESENT(displ_in)) THEN
28543 displ = displ_in
28544 ELSE
28545 displ = 1
28546 END IF
28547 right = modulo(myrank + displ, nprocs)
28548 left = modulo(myrank - displ, nprocs)
28549 tag = 17
28550 msglen = SIZE(msg)
28551 CALL mpi_sendrecv_replace(msg, msglen, mpi_complex, right, tag, left, tag, &
28552 comm%handle, mpi_status_ignore, ierror)
28553 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
28554 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_4_size))
28555#else
28556 mark_used(msg)
28557 mark_used(comm)
28558 mark_used(displ_in)
28559#endif
28560 CALL mp_timestop(handle)
28561
28562 END SUBROUTINE mp_shift_cm
28563
28564! **************************************************************************************************
28565!> \brief Shift around the data in msg
28566!> \param[in,out] msg Data to shift
28567!> \param[in] comm message passing environment identifier
28568!> \param[in] displ_in displacements (?)
28569!> \par Example
28570!> msg will be moved from rank to rank+displ_in (in a circular way)
28571!> \par Limitations
28572!> * displ_in will be 1 by default (others not tested)
28573!> * the message array needs to be the same size on all processes
28574! **************************************************************************************************
28575 SUBROUTINE mp_shift_c (msg, comm, displ_in)
28576
28577 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
28578 CLASS(mp_comm_type), INTENT(IN) :: comm
28579 INTEGER, INTENT(IN), OPTIONAL :: displ_in
28580
28581 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_c'
28582
28583 INTEGER :: handle, ierror
28584#if defined(__parallel)
28585 INTEGER :: displ, left, &
28586 msglen, myrank, nprocs, &
28587 right, tag
28588#endif
28589
28590 ierror = 0
28591 CALL mp_timeset(routinen, handle)
28592
28593#if defined(__parallel)
28594 CALL mpi_comm_rank(comm%handle, myrank, ierror)
28595 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
28596 CALL mpi_comm_size(comm%handle, nprocs, ierror)
28597 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
28598 IF (PRESENT(displ_in)) THEN
28599 displ = displ_in
28600 ELSE
28601 displ = 1
28602 END IF
28603 right = modulo(myrank + displ, nprocs)
28604 left = modulo(myrank - displ, nprocs)
28605 tag = 19
28606 msglen = SIZE(msg)
28607 CALL mpi_sendrecv_replace(msg, msglen, mpi_complex, right, tag, left, &
28608 tag, comm%handle, mpi_status_ignore, ierror)
28609 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
28610 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_4_size))
28611#else
28612 mark_used(msg)
28613 mark_used(comm)
28614 mark_used(displ_in)
28615#endif
28616 CALL mp_timestop(handle)
28617
28618 END SUBROUTINE mp_shift_c
28619
28620! **************************************************************************************************
28621!> \brief All-to-all data exchange, rank-1 data of different sizes
28622!> \param[in] sb Data to send
28623!> \param[in] scount Data counts for data sent to other processes
28624!> \param[in] sdispl Respective data offsets for data sent to process
28625!> \param[in,out] rb Buffer into which to receive data
28626!> \param[in] rcount Data counts for data received from other
28627!> processes
28628!> \param[in] rdispl Respective data offsets for data received from
28629!> other processes
28630!> \param[in] comm Message passing environment identifier
28631!> \par MPI mapping
28632!> mpi_alltoallv
28633!> \par Array sizes
28634!> The scount, rcount, and the sdispl and rdispl arrays have a
28635!> size equal to the number of processes.
28636!> \par Offsets
28637!> Values in sdispl and rdispl start with 0.
28638! **************************************************************************************************
28639 SUBROUTINE mp_alltoall_c11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
28640
28641 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
28642 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
28643 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
28644 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
28645 CLASS(mp_comm_type), INTENT(IN) :: comm
28646
28647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c11v'
28648
28649 INTEGER :: handle
28650#if defined(__parallel)
28651 INTEGER :: ierr, msglen
28652#else
28653 INTEGER :: i
28654#endif
28655
28656 CALL mp_timeset(routinen, handle)
28657
28658#if defined(__parallel)
28659 CALL mpi_alltoallv(sb, scount, sdispl, mpi_complex, &
28660 rb, rcount, rdispl, mpi_complex, comm%handle, ierr)
28661 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
28662 msglen = sum(scount) + sum(rcount)
28663 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28664#else
28665 mark_used(comm)
28666 mark_used(scount)
28667 mark_used(sdispl)
28668 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
28669 DO i = 1, rcount(1)
28670 rb(rdispl(1) + i) = sb(sdispl(1) + i)
28671 END DO
28672#endif
28673 CALL mp_timestop(handle)
28674
28675 END SUBROUTINE mp_alltoall_c11v
28676
28677! **************************************************************************************************
28678!> \brief All-to-all data exchange, rank-2 data of different sizes
28679!> \param sb ...
28680!> \param scount ...
28681!> \param sdispl ...
28682!> \param rb ...
28683!> \param rcount ...
28684!> \param rdispl ...
28685!> \param comm ...
28686!> \par MPI mapping
28687!> mpi_alltoallv
28688!> \note see mp_alltoall_c11v
28689! **************************************************************************************************
28690 SUBROUTINE mp_alltoall_c22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
28691
28692 COMPLEX(kind=real_4), DIMENSION(:, :), &
28693 INTENT(IN), CONTIGUOUS :: sb
28694 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
28695 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, &
28696 INTENT(INOUT) :: rb
28697 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
28698 CLASS(mp_comm_type), INTENT(IN) :: comm
28699
28700 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c22v'
28701
28702 INTEGER :: handle
28703#if defined(__parallel)
28704 INTEGER :: ierr, msglen
28705#endif
28706
28707 CALL mp_timeset(routinen, handle)
28708
28709#if defined(__parallel)
28710 CALL mpi_alltoallv(sb, scount, sdispl, mpi_complex, &
28711 rb, rcount, rdispl, mpi_complex, comm%handle, ierr)
28712 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
28713 msglen = sum(scount) + sum(rcount)
28714 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*(2*real_4_size))
28715#else
28716 mark_used(comm)
28717 mark_used(scount)
28718 mark_used(sdispl)
28719 mark_used(rcount)
28720 mark_used(rdispl)
28721 rb = sb
28722#endif
28723 CALL mp_timestop(handle)
28724
28725 END SUBROUTINE mp_alltoall_c22v
28726
28727! **************************************************************************************************
28728!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
28729!> \param[in] sb array with data to send
28730!> \param[out] rb array into which data is received
28731!> \param[in] count number of elements to send/receive (product of the
28732!> extents of the first two dimensions)
28733!> \param[in] comm Message passing environment identifier
28734!> \par Index meaning
28735!> \par The first two indices specify the data while the last index counts
28736!> the processes
28737!> \par Sizes of ranks
28738!> All processes have the same data size.
28739!> \par MPI mapping
28740!> mpi_alltoall
28741! **************************************************************************************************
28742 SUBROUTINE mp_alltoall_c (sb, rb, count, comm)
28743
28744 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
28745 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
28746 INTEGER, INTENT(IN) :: count
28747 CLASS(mp_comm_type), INTENT(IN) :: comm
28748
28749 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c'
28750
28751 INTEGER :: handle
28752#if defined(__parallel)
28753 INTEGER :: ierr, msglen, np
28754#endif
28755
28756 CALL mp_timeset(routinen, handle)
28757
28758#if defined(__parallel)
28759 CALL mpi_alltoall(sb, count, mpi_complex, &
28760 rb, count, mpi_complex, comm%handle, ierr)
28761 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28762 CALL mpi_comm_size(comm%handle, np, ierr)
28763 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28764 msglen = 2*count*np
28765 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28766#else
28767 mark_used(count)
28768 mark_used(comm)
28769 rb = sb
28770#endif
28771 CALL mp_timestop(handle)
28772
28773 END SUBROUTINE mp_alltoall_c
28774
28775! **************************************************************************************************
28776!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
28777!> \param sb ...
28778!> \param rb ...
28779!> \param count ...
28780!> \param commp ...
28781!> \note see mp_alltoall_c
28782! **************************************************************************************************
28783 SUBROUTINE mp_alltoall_c22(sb, rb, count, comm)
28784
28785 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
28786 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
28787 INTEGER, INTENT(IN) :: count
28788 CLASS(mp_comm_type), INTENT(IN) :: comm
28789
28790 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c22'
28791
28792 INTEGER :: handle
28793#if defined(__parallel)
28794 INTEGER :: ierr, msglen, np
28795#endif
28796
28797 CALL mp_timeset(routinen, handle)
28798
28799#if defined(__parallel)
28800 CALL mpi_alltoall(sb, count, mpi_complex, &
28801 rb, count, mpi_complex, comm%handle, ierr)
28802 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28803 CALL mpi_comm_size(comm%handle, np, ierr)
28804 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28805 msglen = 2*SIZE(sb)*np
28806 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28807#else
28808 mark_used(count)
28809 mark_used(comm)
28810 rb = sb
28811#endif
28812 CALL mp_timestop(handle)
28813
28814 END SUBROUTINE mp_alltoall_c22
28815
28816! **************************************************************************************************
28817!> \brief All-to-all data exchange, rank-3 data with equal sizes
28818!> \param sb ...
28819!> \param rb ...
28820!> \param count ...
28821!> \param comm ...
28822!> \note see mp_alltoall_c
28823! **************************************************************************************************
28824 SUBROUTINE mp_alltoall_c33(sb, rb, count, comm)
28825
28826 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
28827 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
28828 INTEGER, INTENT(IN) :: count
28829 CLASS(mp_comm_type), INTENT(IN) :: comm
28830
28831 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c33'
28832
28833 INTEGER :: handle
28834#if defined(__parallel)
28835 INTEGER :: ierr, msglen, np
28836#endif
28837
28838 CALL mp_timeset(routinen, handle)
28839
28840#if defined(__parallel)
28841 CALL mpi_alltoall(sb, count, mpi_complex, &
28842 rb, count, mpi_complex, comm%handle, ierr)
28843 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28844 CALL mpi_comm_size(comm%handle, np, ierr)
28845 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28846 msglen = 2*count*np
28847 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28848#else
28849 mark_used(count)
28850 mark_used(comm)
28851 rb = sb
28852#endif
28853 CALL mp_timestop(handle)
28854
28855 END SUBROUTINE mp_alltoall_c33
28856
28857! **************************************************************************************************
28858!> \brief All-to-all data exchange, rank 4 data, equal sizes
28859!> \param sb ...
28860!> \param rb ...
28861!> \param count ...
28862!> \param comm ...
28863!> \note see mp_alltoall_c
28864! **************************************************************************************************
28865 SUBROUTINE mp_alltoall_c44(sb, rb, count, comm)
28866
28867 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28868 INTENT(IN) :: sb
28869 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28870 INTENT(OUT) :: rb
28871 INTEGER, INTENT(IN) :: count
28872 CLASS(mp_comm_type), INTENT(IN) :: comm
28873
28874 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c44'
28875
28876 INTEGER :: handle
28877#if defined(__parallel)
28878 INTEGER :: ierr, msglen, np
28879#endif
28880
28881 CALL mp_timeset(routinen, handle)
28882
28883#if defined(__parallel)
28884 CALL mpi_alltoall(sb, count, mpi_complex, &
28885 rb, count, mpi_complex, comm%handle, ierr)
28886 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28887 CALL mpi_comm_size(comm%handle, np, ierr)
28888 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28889 msglen = 2*count*np
28890 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28891#else
28892 mark_used(count)
28893 mark_used(comm)
28894 rb = sb
28895#endif
28896 CALL mp_timestop(handle)
28897
28898 END SUBROUTINE mp_alltoall_c44
28899
28900! **************************************************************************************************
28901!> \brief All-to-all data exchange, rank 5 data, equal sizes
28902!> \param sb ...
28903!> \param rb ...
28904!> \param count ...
28905!> \param comm ...
28906!> \note see mp_alltoall_c
28907! **************************************************************************************************
28908 SUBROUTINE mp_alltoall_c55(sb, rb, count, comm)
28909
28910 COMPLEX(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
28911 INTENT(IN) :: sb
28912 COMPLEX(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
28913 INTENT(OUT) :: rb
28914 INTEGER, INTENT(IN) :: count
28915 CLASS(mp_comm_type), INTENT(IN) :: comm
28916
28917 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c55'
28918
28919 INTEGER :: handle
28920#if defined(__parallel)
28921 INTEGER :: ierr, msglen, np
28922#endif
28923
28924 CALL mp_timeset(routinen, handle)
28925
28926#if defined(__parallel)
28927 CALL mpi_alltoall(sb, count, mpi_complex, &
28928 rb, count, mpi_complex, comm%handle, ierr)
28929 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28930 CALL mpi_comm_size(comm%handle, np, ierr)
28931 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28932 msglen = 2*count*np
28933 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28934#else
28935 mark_used(count)
28936 mark_used(comm)
28937 rb = sb
28938#endif
28939 CALL mp_timestop(handle)
28940
28941 END SUBROUTINE mp_alltoall_c55
28942
28943! **************************************************************************************************
28944!> \brief All-to-all data exchange, rank-4 data to rank-5 data
28945!> \param sb ...
28946!> \param rb ...
28947!> \param count ...
28948!> \param comm ...
28949!> \note see mp_alltoall_c
28950!> \note User must ensure size consistency.
28951! **************************************************************************************************
28952 SUBROUTINE mp_alltoall_c45(sb, rb, count, comm)
28953
28954 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28955 INTENT(IN) :: sb
28956 COMPLEX(kind=real_4), &
28957 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
28958 INTEGER, INTENT(IN) :: count
28959 CLASS(mp_comm_type), INTENT(IN) :: comm
28960
28961 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c45'
28962
28963 INTEGER :: handle
28964#if defined(__parallel)
28965 INTEGER :: ierr, msglen, np
28966#endif
28967
28968 CALL mp_timeset(routinen, handle)
28969
28970#if defined(__parallel)
28971 CALL mpi_alltoall(sb, count, mpi_complex, &
28972 rb, count, mpi_complex, comm%handle, ierr)
28973 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28974 CALL mpi_comm_size(comm%handle, np, ierr)
28975 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28976 msglen = 2*count*np
28977 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28978#else
28979 mark_used(count)
28980 mark_used(comm)
28981 rb = reshape(sb, shape(rb))
28982#endif
28983 CALL mp_timestop(handle)
28984
28985 END SUBROUTINE mp_alltoall_c45
28986
28987! **************************************************************************************************
28988!> \brief All-to-all data exchange, rank-3 data to rank-4 data
28989!> \param sb ...
28990!> \param rb ...
28991!> \param count ...
28992!> \param comm ...
28993!> \note see mp_alltoall_c
28994!> \note User must ensure size consistency.
28995! **************************************************************************************************
28996 SUBROUTINE mp_alltoall_c34(sb, rb, count, comm)
28997
28998 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, &
28999 INTENT(IN) :: sb
29000 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29001 INTENT(OUT) :: rb
29002 INTEGER, INTENT(IN) :: count
29003 CLASS(mp_comm_type), INTENT(IN) :: comm
29004
29005 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c34'
29006
29007 INTEGER :: handle
29008#if defined(__parallel)
29009 INTEGER :: ierr, msglen, np
29010#endif
29011
29012 CALL mp_timeset(routinen, handle)
29013
29014#if defined(__parallel)
29015 CALL mpi_alltoall(sb, count, mpi_complex, &
29016 rb, count, mpi_complex, comm%handle, ierr)
29017 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29018 CALL mpi_comm_size(comm%handle, np, ierr)
29019 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29020 msglen = 2*count*np
29021 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29022#else
29023 mark_used(count)
29024 mark_used(comm)
29025 rb = reshape(sb, shape(rb))
29026#endif
29027 CALL mp_timestop(handle)
29028
29029 END SUBROUTINE mp_alltoall_c34
29030
29031! **************************************************************************************************
29032!> \brief All-to-all data exchange, rank-5 data to rank-4 data
29033!> \param sb ...
29034!> \param rb ...
29035!> \param count ...
29036!> \param comm ...
29037!> \note see mp_alltoall_c
29038!> \note User must ensure size consistency.
29039! **************************************************************************************************
29040 SUBROUTINE mp_alltoall_c54(sb, rb, count, comm)
29041
29042 COMPLEX(kind=real_4), &
29043 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
29044 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29045 INTENT(OUT) :: rb
29046 INTEGER, INTENT(IN) :: count
29047 CLASS(mp_comm_type), INTENT(IN) :: comm
29048
29049 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c54'
29050
29051 INTEGER :: handle
29052#if defined(__parallel)
29053 INTEGER :: ierr, msglen, np
29054#endif
29055
29056 CALL mp_timeset(routinen, handle)
29057
29058#if defined(__parallel)
29059 CALL mpi_alltoall(sb, count, mpi_complex, &
29060 rb, count, mpi_complex, comm%handle, ierr)
29061 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29062 CALL mpi_comm_size(comm%handle, np, ierr)
29063 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29064 msglen = 2*count*np
29065 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29066#else
29067 mark_used(count)
29068 mark_used(comm)
29069 rb = reshape(sb, shape(rb))
29070#endif
29071 CALL mp_timestop(handle)
29072
29073 END SUBROUTINE mp_alltoall_c54
29074
29075! **************************************************************************************************
29076!> \brief Send one datum to another process
29077!> \param[in] msg Scalar to send
29078!> \param[in] dest Destination process
29079!> \param[in] tag Transfer identifier
29080!> \param[in] comm Message passing environment identifier
29081!> \par MPI mapping
29082!> mpi_send
29083! **************************************************************************************************
29084 SUBROUTINE mp_send_c (msg, dest, tag, comm)
29085 COMPLEX(kind=real_4), INTENT(IN) :: msg
29086 INTEGER, INTENT(IN) :: dest, tag
29087 CLASS(mp_comm_type), INTENT(IN) :: comm
29088
29089 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_c'
29090
29091 INTEGER :: handle
29092#if defined(__parallel)
29093 INTEGER :: ierr, msglen
29094#endif
29095
29096 CALL mp_timeset(routinen, handle)
29097
29098#if defined(__parallel)
29099 msglen = 1
29100 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29101 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29102 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29103#else
29104 mark_used(msg)
29105 mark_used(dest)
29106 mark_used(tag)
29107 mark_used(comm)
29108 ! only defined in parallel
29109 cpabort("not in parallel mode")
29110#endif
29111 CALL mp_timestop(handle)
29112 END SUBROUTINE mp_send_c
29113
29114! **************************************************************************************************
29115!> \brief Send rank-1 data to another process
29116!> \param[in] msg Rank-1 data to send
29117!> \param dest ...
29118!> \param tag ...
29119!> \param comm ...
29120!> \note see mp_send_c
29121! **************************************************************************************************
29122 SUBROUTINE mp_send_cv(msg, dest, tag, comm)
29123 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
29124 INTEGER, INTENT(IN) :: dest, tag
29125 CLASS(mp_comm_type), INTENT(IN) :: comm
29126
29127 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_cv'
29128
29129 INTEGER :: handle
29130#if defined(__parallel)
29131 INTEGER :: ierr, msglen
29132#endif
29133
29134 CALL mp_timeset(routinen, handle)
29135
29136#if defined(__parallel)
29137 msglen = SIZE(msg)
29138 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29139 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29140 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29141#else
29142 mark_used(msg)
29143 mark_used(dest)
29144 mark_used(tag)
29145 mark_used(comm)
29146 ! only defined in parallel
29147 cpabort("not in parallel mode")
29148#endif
29149 CALL mp_timestop(handle)
29150 END SUBROUTINE mp_send_cv
29151
29152! **************************************************************************************************
29153!> \brief Send rank-2 data to another process
29154!> \param[in] msg Rank-2 data to send
29155!> \param dest ...
29156!> \param tag ...
29157!> \param comm ...
29158!> \note see mp_send_c
29159! **************************************************************************************************
29160 SUBROUTINE mp_send_cm2(msg, dest, tag, comm)
29161 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
29162 INTEGER, INTENT(IN) :: dest, tag
29163 CLASS(mp_comm_type), INTENT(IN) :: comm
29164
29165 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_cm2'
29166
29167 INTEGER :: handle
29168#if defined(__parallel)
29169 INTEGER :: ierr, msglen
29170#endif
29171
29172 CALL mp_timeset(routinen, handle)
29173
29174#if defined(__parallel)
29175 msglen = SIZE(msg)
29176 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29177 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29178 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29179#else
29180 mark_used(msg)
29181 mark_used(dest)
29182 mark_used(tag)
29183 mark_used(comm)
29184 ! only defined in parallel
29185 cpabort("not in parallel mode")
29186#endif
29187 CALL mp_timestop(handle)
29188 END SUBROUTINE mp_send_cm2
29189
29190! **************************************************************************************************
29191!> \brief Send rank-3 data to another process
29192!> \param[in] msg Rank-3 data to send
29193!> \param dest ...
29194!> \param tag ...
29195!> \param comm ...
29196!> \note see mp_send_c
29197! **************************************************************************************************
29198 SUBROUTINE mp_send_cm3(msg, dest, tag, comm)
29199 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
29200 INTEGER, INTENT(IN) :: dest, tag
29201 CLASS(mp_comm_type), INTENT(IN) :: comm
29202
29203 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
29204
29205 INTEGER :: handle
29206#if defined(__parallel)
29207 INTEGER :: ierr, msglen
29208#endif
29209
29210 CALL mp_timeset(routinen, handle)
29211
29212#if defined(__parallel)
29213 msglen = SIZE(msg)
29214 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29215 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29216 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29217#else
29218 mark_used(msg)
29219 mark_used(dest)
29220 mark_used(tag)
29221 mark_used(comm)
29222 ! only defined in parallel
29223 cpabort("not in parallel mode")
29224#endif
29225 CALL mp_timestop(handle)
29226 END SUBROUTINE mp_send_cm3
29227
29228! **************************************************************************************************
29229!> \brief Receive one datum from another process
29230!> \param[in,out] msg Place received data into this variable
29231!> \param[in,out] source Process to receive from
29232!> \param[in,out] tag Transfer identifier
29233!> \param[in] comm Message passing environment identifier
29234!> \par MPI mapping
29235!> mpi_send
29236! **************************************************************************************************
29237 SUBROUTINE mp_recv_c (msg, source, tag, comm)
29238 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29239 INTEGER, INTENT(INOUT) :: source, tag
29240 CLASS(mp_comm_type), INTENT(IN) :: comm
29241
29242 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_c'
29243
29244 INTEGER :: handle
29245#if defined(__parallel)
29246 INTEGER :: ierr, msglen
29247 mpi_status_type :: status
29248#endif
29249
29250 CALL mp_timeset(routinen, handle)
29251
29252#if defined(__parallel)
29253 msglen = 1
29254 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29255 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29256 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29257 ELSE
29258 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29259 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29260 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29261 source = status mpi_status_extract(mpi_source)
29262 tag = status mpi_status_extract(mpi_tag)
29263 END IF
29264#else
29265 mark_used(msg)
29266 mark_used(source)
29267 mark_used(tag)
29268 mark_used(comm)
29269 ! only defined in parallel
29270 cpabort("not in parallel mode")
29271#endif
29272 CALL mp_timestop(handle)
29273 END SUBROUTINE mp_recv_c
29274
29275! **************************************************************************************************
29276!> \brief Receive rank-1 data from another process
29277!> \param[in,out] msg Place received data into this rank-1 array
29278!> \param source ...
29279!> \param tag ...
29280!> \param comm ...
29281!> \note see mp_recv_c
29282! **************************************************************************************************
29283 SUBROUTINE mp_recv_cv(msg, source, tag, comm)
29284 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29285 INTEGER, INTENT(INOUT) :: source, tag
29286 CLASS(mp_comm_type), INTENT(IN) :: comm
29287
29288 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cv'
29289
29290 INTEGER :: handle
29291#if defined(__parallel)
29292 INTEGER :: ierr, msglen
29293 mpi_status_type :: status
29294#endif
29295
29296 CALL mp_timeset(routinen, handle)
29297
29298#if defined(__parallel)
29299 msglen = SIZE(msg)
29300 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29301 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29302 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29303 ELSE
29304 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29305 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29306 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29307 source = status mpi_status_extract(mpi_source)
29308 tag = status mpi_status_extract(mpi_tag)
29309 END IF
29310#else
29311 mark_used(msg)
29312 mark_used(source)
29313 mark_used(tag)
29314 mark_used(comm)
29315 ! only defined in parallel
29316 cpabort("not in parallel mode")
29317#endif
29318 CALL mp_timestop(handle)
29319 END SUBROUTINE mp_recv_cv
29320
29321! **************************************************************************************************
29322!> \brief Receive rank-2 data from another process
29323!> \param[in,out] msg Place received data into this rank-2 array
29324!> \param source ...
29325!> \param tag ...
29326!> \param comm ...
29327!> \note see mp_recv_c
29328! **************************************************************************************************
29329 SUBROUTINE mp_recv_cm2(msg, source, tag, comm)
29330 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29331 INTEGER, INTENT(INOUT) :: source, tag
29332 CLASS(mp_comm_type), INTENT(IN) :: comm
29333
29334 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cm2'
29335
29336 INTEGER :: handle
29337#if defined(__parallel)
29338 INTEGER :: ierr, msglen
29339 mpi_status_type :: status
29340#endif
29341
29342 CALL mp_timeset(routinen, handle)
29343
29344#if defined(__parallel)
29345 msglen = SIZE(msg)
29346 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29347 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29348 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29349 ELSE
29350 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29351 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29352 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29353 source = status mpi_status_extract(mpi_source)
29354 tag = status mpi_status_extract(mpi_tag)
29355 END IF
29356#else
29357 mark_used(msg)
29358 mark_used(source)
29359 mark_used(tag)
29360 mark_used(comm)
29361 ! only defined in parallel
29362 cpabort("not in parallel mode")
29363#endif
29364 CALL mp_timestop(handle)
29365 END SUBROUTINE mp_recv_cm2
29366
29367! **************************************************************************************************
29368!> \brief Receive rank-3 data from another process
29369!> \param[in,out] msg Place received data into this rank-3 array
29370!> \param source ...
29371!> \param tag ...
29372!> \param comm ...
29373!> \note see mp_recv_c
29374! **************************************************************************************************
29375 SUBROUTINE mp_recv_cm3(msg, source, tag, comm)
29376 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
29377 INTEGER, INTENT(INOUT) :: source, tag
29378 CLASS(mp_comm_type), INTENT(IN) :: comm
29379
29380 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cm3'
29381
29382 INTEGER :: handle
29383#if defined(__parallel)
29384 INTEGER :: ierr, msglen
29385 mpi_status_type :: status
29386#endif
29387
29388 CALL mp_timeset(routinen, handle)
29389
29390#if defined(__parallel)
29391 msglen = SIZE(msg)
29392 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29393 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29394 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29395 ELSE
29396 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29397 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29398 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29399 source = status mpi_status_extract(mpi_source)
29400 tag = status mpi_status_extract(mpi_tag)
29401 END IF
29402#else
29403 mark_used(msg)
29404 mark_used(source)
29405 mark_used(tag)
29406 mark_used(comm)
29407 ! only defined in parallel
29408 cpabort("not in parallel mode")
29409#endif
29410 CALL mp_timestop(handle)
29411 END SUBROUTINE mp_recv_cm3
29412
29413! **************************************************************************************************
29414!> \brief Broadcasts a datum to all processes.
29415!> \param[in] msg Datum to broadcast
29416!> \param[in] source Processes which broadcasts
29417!> \param[in] comm Message passing environment identifier
29418!> \par MPI mapping
29419!> mpi_bcast
29420! **************************************************************************************************
29421 SUBROUTINE mp_bcast_c (msg, source, comm)
29422 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29423 INTEGER, INTENT(IN) :: source
29424 CLASS(mp_comm_type), INTENT(IN) :: comm
29425
29426 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c'
29427
29428 INTEGER :: handle
29429#if defined(__parallel)
29430 INTEGER :: ierr, msglen
29431#endif
29432
29433 CALL mp_timeset(routinen, handle)
29434
29435#if defined(__parallel)
29436 msglen = 1
29437 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29438 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29439 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29440#else
29441 mark_used(msg)
29442 mark_used(source)
29443 mark_used(comm)
29444#endif
29445 CALL mp_timestop(handle)
29446 END SUBROUTINE mp_bcast_c
29447
29448! **************************************************************************************************
29449!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
29450!> \param[in] msg Datum to broadcast
29451!> \param[in] comm Message passing environment identifier
29452!> \par MPI mapping
29453!> mpi_bcast
29454! **************************************************************************************************
29455 SUBROUTINE mp_bcast_c_src(msg, comm)
29456 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29457 CLASS(mp_comm_type), INTENT(IN) :: comm
29458
29459 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c_src'
29460
29461 INTEGER :: handle
29462#if defined(__parallel)
29463 INTEGER :: ierr, msglen
29464#endif
29465
29466 CALL mp_timeset(routinen, handle)
29467
29468#if defined(__parallel)
29469 msglen = 1
29470 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29471 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29472 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29473#else
29474 mark_used(msg)
29475 mark_used(comm)
29476#endif
29477 CALL mp_timestop(handle)
29478 END SUBROUTINE mp_bcast_c_src
29479
29480! **************************************************************************************************
29481!> \brief Broadcasts a datum to all processes.
29482!> \param[in] msg Datum to broadcast
29483!> \param[in] source Processes which broadcasts
29484!> \param[in] comm Message passing environment identifier
29485!> \par MPI mapping
29486!> mpi_bcast
29487! **************************************************************************************************
29488 SUBROUTINE mp_ibcast_c (msg, source, comm, request)
29489 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29490 INTEGER, INTENT(IN) :: source
29491 CLASS(mp_comm_type), INTENT(IN) :: comm
29492 TYPE(mp_request_type), INTENT(OUT) :: request
29493
29494 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_c'
29495
29496 INTEGER :: handle
29497#if defined(__parallel)
29498 INTEGER :: ierr, msglen
29499#endif
29500
29501 CALL mp_timeset(routinen, handle)
29502
29503#if defined(__parallel)
29504 msglen = 1
29505 CALL mpi_ibcast(msg, msglen, mpi_complex, source, comm%handle, request%handle, ierr)
29506 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
29507 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_4_size))
29508#else
29509 mark_used(msg)
29510 mark_used(source)
29511 mark_used(comm)
29512 request = mp_request_null
29513#endif
29514 CALL mp_timestop(handle)
29515 END SUBROUTINE mp_ibcast_c
29516
29517! **************************************************************************************************
29518!> \brief Broadcasts rank-1 data to all processes
29519!> \param[in] msg Data to broadcast
29520!> \param source ...
29521!> \param comm ...
29522!> \note see mp_bcast_c1
29523! **************************************************************************************************
29524 SUBROUTINE mp_bcast_cv(msg, source, comm)
29525 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29526 INTEGER, INTENT(IN) :: source
29527 CLASS(mp_comm_type), INTENT(IN) :: comm
29528
29529 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cv'
29530
29531 INTEGER :: handle
29532#if defined(__parallel)
29533 INTEGER :: ierr, msglen
29534#endif
29535
29536 CALL mp_timeset(routinen, handle)
29537
29538#if defined(__parallel)
29539 msglen = SIZE(msg)
29540 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29541 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29542 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29543#else
29544 mark_used(msg)
29545 mark_used(source)
29546 mark_used(comm)
29547#endif
29548 CALL mp_timestop(handle)
29549 END SUBROUTINE mp_bcast_cv
29550
29551! **************************************************************************************************
29552!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
29553!> \param[in] msg Data to broadcast
29554!> \param comm ...
29555!> \note see mp_bcast_c1
29556! **************************************************************************************************
29557 SUBROUTINE mp_bcast_cv_src(msg, comm)
29558 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29559 CLASS(mp_comm_type), INTENT(IN) :: comm
29560
29561 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cv_src'
29562
29563 INTEGER :: handle
29564#if defined(__parallel)
29565 INTEGER :: ierr, msglen
29566#endif
29567
29568 CALL mp_timeset(routinen, handle)
29569
29570#if defined(__parallel)
29571 msglen = SIZE(msg)
29572 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29573 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29574 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29575#else
29576 mark_used(msg)
29577 mark_used(comm)
29578#endif
29579 CALL mp_timestop(handle)
29580 END SUBROUTINE mp_bcast_cv_src
29581
29582! **************************************************************************************************
29583!> \brief Broadcasts rank-1 data to all processes
29584!> \param[in] msg Data to broadcast
29585!> \param source ...
29586!> \param comm ...
29587!> \note see mp_bcast_c1
29588! **************************************************************************************************
29589 SUBROUTINE mp_ibcast_cv(msg, source, comm, request)
29590 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
29591 INTEGER, INTENT(IN) :: source
29592 CLASS(mp_comm_type), INTENT(IN) :: comm
29593 TYPE(mp_request_type) :: request
29594
29595 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_cv'
29596
29597 INTEGER :: handle
29598#if defined(__parallel)
29599 INTEGER :: ierr, msglen
29600#endif
29601
29602 CALL mp_timeset(routinen, handle)
29603
29604#if defined(__parallel)
29605#if !defined(__GNUC__) || __GNUC__ >= 9
29606 cpassert(is_contiguous(msg))
29607#endif
29608 msglen = SIZE(msg)
29609 CALL mpi_ibcast(msg, msglen, mpi_complex, source, comm%handle, request%handle, ierr)
29610 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
29611 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_4_size))
29612#else
29613 mark_used(msg)
29614 mark_used(source)
29615 mark_used(comm)
29616 request = mp_request_null
29617#endif
29618 CALL mp_timestop(handle)
29619 END SUBROUTINE mp_ibcast_cv
29620
29621! **************************************************************************************************
29622!> \brief Broadcasts rank-2 data to all processes
29623!> \param[in] msg Data to broadcast
29624!> \param source ...
29625!> \param comm ...
29626!> \note see mp_bcast_c1
29627! **************************************************************************************************
29628 SUBROUTINE mp_bcast_cm(msg, source, comm)
29629 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29630 INTEGER, INTENT(IN) :: source
29631 CLASS(mp_comm_type), INTENT(IN) :: comm
29632
29633 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cm'
29634
29635 INTEGER :: handle
29636#if defined(__parallel)
29637 INTEGER :: ierr, msglen
29638#endif
29639
29640 CALL mp_timeset(routinen, handle)
29641
29642#if defined(__parallel)
29643 msglen = SIZE(msg)
29644 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29645 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29646 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29647#else
29648 mark_used(msg)
29649 mark_used(source)
29650 mark_used(comm)
29651#endif
29652 CALL mp_timestop(handle)
29653 END SUBROUTINE mp_bcast_cm
29654
29655! **************************************************************************************************
29656!> \brief Broadcasts rank-2 data to all processes
29657!> \param[in] msg Data to broadcast
29658!> \param source ...
29659!> \param comm ...
29660!> \note see mp_bcast_c1
29661! **************************************************************************************************
29662 SUBROUTINE mp_bcast_cm_src(msg, comm)
29663 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29664 CLASS(mp_comm_type), INTENT(IN) :: comm
29665
29666 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cm_src'
29667
29668 INTEGER :: handle
29669#if defined(__parallel)
29670 INTEGER :: ierr, msglen
29671#endif
29672
29673 CALL mp_timeset(routinen, handle)
29674
29675#if defined(__parallel)
29676 msglen = SIZE(msg)
29677 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29678 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29679 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29680#else
29681 mark_used(msg)
29682 mark_used(comm)
29683#endif
29684 CALL mp_timestop(handle)
29685 END SUBROUTINE mp_bcast_cm_src
29686
29687! **************************************************************************************************
29688!> \brief Broadcasts rank-3 data to all processes
29689!> \param[in] msg Data to broadcast
29690!> \param source ...
29691!> \param comm ...
29692!> \note see mp_bcast_c1
29693! **************************************************************************************************
29694 SUBROUTINE mp_bcast_c3(msg, source, comm)
29695 COMPLEX(kind=real_4), CONTIGUOUS :: msg(:, :, :)
29696 INTEGER, INTENT(IN) :: source
29697 CLASS(mp_comm_type), INTENT(IN) :: comm
29698
29699 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c3'
29700
29701 INTEGER :: handle
29702#if defined(__parallel)
29703 INTEGER :: ierr, msglen
29704#endif
29705
29706 CALL mp_timeset(routinen, handle)
29707
29708#if defined(__parallel)
29709 msglen = SIZE(msg)
29710 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29711 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29712 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29713#else
29714 mark_used(msg)
29715 mark_used(source)
29716 mark_used(comm)
29717#endif
29718 CALL mp_timestop(handle)
29719 END SUBROUTINE mp_bcast_c3
29720
29721! **************************************************************************************************
29722!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
29723!> \param[in] msg Data to broadcast
29724!> \param source ...
29725!> \param comm ...
29726!> \note see mp_bcast_c1
29727! **************************************************************************************************
29728 SUBROUTINE mp_bcast_c3_src(msg, comm)
29729 COMPLEX(kind=real_4), CONTIGUOUS :: msg(:, :, :)
29730 CLASS(mp_comm_type), INTENT(IN) :: comm
29731
29732 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c3_src'
29733
29734 INTEGER :: handle
29735#if defined(__parallel)
29736 INTEGER :: ierr, msglen
29737#endif
29738
29739 CALL mp_timeset(routinen, handle)
29740
29741#if defined(__parallel)
29742 msglen = SIZE(msg)
29743 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29744 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29745 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29746#else
29747 mark_used(msg)
29748 mark_used(comm)
29749#endif
29750 CALL mp_timestop(handle)
29751 END SUBROUTINE mp_bcast_c3_src
29752
29753! **************************************************************************************************
29754!> \brief Sums a datum from all processes with result left on all processes.
29755!> \param[in,out] msg Datum to sum (input) and result (output)
29756!> \param[in] comm Message passing environment identifier
29757!> \par MPI mapping
29758!> mpi_allreduce
29759! **************************************************************************************************
29760 SUBROUTINE mp_sum_c (msg, comm)
29761 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29762 CLASS(mp_comm_type), INTENT(IN) :: comm
29763
29764 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_c'
29765
29766 INTEGER :: handle
29767#if defined(__parallel)
29768 INTEGER :: ierr, msglen
29769#endif
29770
29771 CALL mp_timeset(routinen, handle)
29772
29773#if defined(__parallel)
29774 msglen = 1
29775 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29776 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29777 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29778#else
29779 mark_used(msg)
29780 mark_used(comm)
29781#endif
29782 CALL mp_timestop(handle)
29783 END SUBROUTINE mp_sum_c
29784
29785! **************************************************************************************************
29786!> \brief Element-wise sum of a rank-1 array on all processes.
29787!> \param[in,out] msg Vector to sum and result
29788!> \param comm ...
29789!> \note see mp_sum_c
29790! **************************************************************************************************
29791 SUBROUTINE mp_sum_cv(msg, comm)
29792 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29793 CLASS(mp_comm_type), INTENT(IN) :: comm
29794
29795 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cv'
29796
29797 INTEGER :: handle
29798#if defined(__parallel)
29799 INTEGER :: ierr, msglen
29800#endif
29801
29802 CALL mp_timeset(routinen, handle)
29803
29804#if defined(__parallel)
29805 msglen = SIZE(msg)
29806 IF (msglen > 0) THEN
29807 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29808 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29809 END IF
29810 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29811#else
29812 mark_used(msg)
29813 mark_used(comm)
29814#endif
29815 CALL mp_timestop(handle)
29816 END SUBROUTINE mp_sum_cv
29817
29818! **************************************************************************************************
29819!> \brief Element-wise sum of a rank-1 array on all processes.
29820!> \param[in,out] msg Vector to sum and result
29821!> \param comm ...
29822!> \note see mp_sum_c
29823! **************************************************************************************************
29824 SUBROUTINE mp_isum_cv(msg, comm, request)
29825 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
29826 CLASS(mp_comm_type), INTENT(IN) :: comm
29827 TYPE(mp_request_type), INTENT(OUT) :: request
29828
29829 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_cv'
29830
29831 INTEGER :: handle
29832#if defined(__parallel)
29833 INTEGER :: ierr, msglen
29834#endif
29835
29836 CALL mp_timeset(routinen, handle)
29837
29838#if defined(__parallel)
29839#if !defined(__GNUC__) || __GNUC__ >= 9
29840 cpassert(is_contiguous(msg))
29841#endif
29842 msglen = SIZE(msg)
29843 IF (msglen > 0) THEN
29844 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, request%handle, ierr)
29845 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
29846 ELSE
29847 request = mp_request_null
29848 END IF
29849 CALL add_perf(perf_id=23, count=1, msg_size=msglen*(2*real_4_size))
29850#else
29851 mark_used(msg)
29852 mark_used(comm)
29853 request = mp_request_null
29854#endif
29855 CALL mp_timestop(handle)
29856 END SUBROUTINE mp_isum_cv
29857
29858! **************************************************************************************************
29859!> \brief Element-wise sum of a rank-2 array on all processes.
29860!> \param[in] msg Matrix to sum and result
29861!> \param comm ...
29862!> \note see mp_sum_c
29863! **************************************************************************************************
29864 SUBROUTINE mp_sum_cm(msg, comm)
29865 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29866 CLASS(mp_comm_type), INTENT(IN) :: comm
29867
29868 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm'
29869
29870 INTEGER :: handle
29871#if defined(__parallel)
29872 INTEGER, PARAMETER :: max_msg = 2**25
29873 INTEGER :: ierr, m1, msglen, step, msglensum
29874#endif
29875
29876 CALL mp_timeset(routinen, handle)
29877
29878#if defined(__parallel)
29879 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
29880 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
29881 msglensum = 0
29882 DO m1 = lbound(msg, 2), ubound(msg, 2), step
29883 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
29884 msglensum = msglensum + msglen
29885 IF (msglen > 0) THEN
29886 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29887 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29888 END IF
29889 END DO
29890 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_4_size))
29891#else
29892 mark_used(msg)
29893 mark_used(comm)
29894#endif
29895 CALL mp_timestop(handle)
29896 END SUBROUTINE mp_sum_cm
29897
29898! **************************************************************************************************
29899!> \brief Element-wise sum of a rank-3 array on all processes.
29900!> \param[in] msg Array to sum and result
29901!> \param comm ...
29902!> \note see mp_sum_c
29903! **************************************************************************************************
29904 SUBROUTINE mp_sum_cm3(msg, comm)
29905 COMPLEX(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
29906 CLASS(mp_comm_type), INTENT(IN) :: comm
29907
29908 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm3'
29909
29910 INTEGER :: handle
29911#if defined(__parallel)
29912 INTEGER :: ierr, msglen
29913#endif
29914
29915 CALL mp_timeset(routinen, handle)
29916
29917#if defined(__parallel)
29918 msglen = SIZE(msg)
29919 IF (msglen > 0) THEN
29920 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29921 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29922 END IF
29923 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29924#else
29925 mark_used(msg)
29926 mark_used(comm)
29927#endif
29928 CALL mp_timestop(handle)
29929 END SUBROUTINE mp_sum_cm3
29930
29931! **************************************************************************************************
29932!> \brief Element-wise sum of a rank-4 array on all processes.
29933!> \param[in] msg Array to sum and result
29934!> \param comm ...
29935!> \note see mp_sum_c
29936! **************************************************************************************************
29937 SUBROUTINE mp_sum_cm4(msg, comm)
29938 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
29939 CLASS(mp_comm_type), INTENT(IN) :: comm
29940
29941 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm4'
29942
29943 INTEGER :: handle
29944#if defined(__parallel)
29945 INTEGER :: ierr, msglen
29946#endif
29947
29948 CALL mp_timeset(routinen, handle)
29949
29950#if defined(__parallel)
29951 msglen = SIZE(msg)
29952 IF (msglen > 0) THEN
29953 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29954 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29955 END IF
29956 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29957#else
29958 mark_used(msg)
29959 mark_used(comm)
29960#endif
29961 CALL mp_timestop(handle)
29962 END SUBROUTINE mp_sum_cm4
29963
29964! **************************************************************************************************
29965!> \brief Element-wise sum of data from all processes with result left only on
29966!> one.
29967!> \param[in,out] msg Vector to sum (input) and (only on process root)
29968!> result (output)
29969!> \param root ...
29970!> \param[in] comm Message passing environment identifier
29971!> \par MPI mapping
29972!> mpi_reduce
29973! **************************************************************************************************
29974 SUBROUTINE mp_sum_root_cv(msg, root, comm)
29975 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29976 INTEGER, INTENT(IN) :: root
29977 CLASS(mp_comm_type), INTENT(IN) :: comm
29978
29979 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_cv'
29980
29981 INTEGER :: handle
29982#if defined(__parallel)
29983 INTEGER :: ierr, m1, msglen, taskid
29984 COMPLEX(kind=real_4), ALLOCATABLE :: res(:)
29985#endif
29986
29987 CALL mp_timeset(routinen, handle)
29988
29989#if defined(__parallel)
29990 msglen = SIZE(msg)
29991 CALL mpi_comm_rank(comm%handle, taskid, ierr)
29992 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
29993 IF (msglen > 0) THEN
29994 m1 = SIZE(msg, 1)
29995 ALLOCATE (res(m1))
29996 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_sum, &
29997 root, comm%handle, ierr)
29998 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
29999 IF (taskid == root) THEN
30000 msg = res
30001 END IF
30002 DEALLOCATE (res)
30003 END IF
30004 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30005#else
30006 mark_used(msg)
30007 mark_used(root)
30008 mark_used(comm)
30009#endif
30010 CALL mp_timestop(handle)
30011 END SUBROUTINE mp_sum_root_cv
30012
30013! **************************************************************************************************
30014!> \brief Element-wise sum of data from all processes with result left only on
30015!> one.
30016!> \param[in,out] msg Matrix to sum (input) and (only on process root)
30017!> result (output)
30018!> \param root ...
30019!> \param comm ...
30020!> \note see mp_sum_root_cv
30021! **************************************************************************************************
30022 SUBROUTINE mp_sum_root_cm(msg, root, comm)
30023 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30024 INTEGER, INTENT(IN) :: root
30025 CLASS(mp_comm_type), INTENT(IN) :: comm
30026
30027 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
30028
30029 INTEGER :: handle
30030#if defined(__parallel)
30031 INTEGER :: ierr, m1, m2, msglen, taskid
30032 COMPLEX(kind=real_4), ALLOCATABLE :: res(:, :)
30033#endif
30034
30035 CALL mp_timeset(routinen, handle)
30036
30037#if defined(__parallel)
30038 msglen = SIZE(msg)
30039 CALL mpi_comm_rank(comm%handle, taskid, ierr)
30040 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
30041 IF (msglen > 0) THEN
30042 m1 = SIZE(msg, 1)
30043 m2 = SIZE(msg, 2)
30044 ALLOCATE (res(m1, m2))
30045 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_sum, root, comm%handle, ierr)
30046 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30047 IF (taskid == root) THEN
30048 msg = res
30049 END IF
30050 DEALLOCATE (res)
30051 END IF
30052 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30053#else
30054 mark_used(root)
30055 mark_used(msg)
30056 mark_used(comm)
30057#endif
30058 CALL mp_timestop(handle)
30059 END SUBROUTINE mp_sum_root_cm
30060
30061! **************************************************************************************************
30062!> \brief Partial sum of data from all processes with result on each process.
30063!> \param[in] msg Matrix to sum (input)
30064!> \param[out] res Matrix containing result (output)
30065!> \param[in] comm Message passing environment identifier
30066! **************************************************************************************************
30067 SUBROUTINE mp_sum_partial_cm(msg, res, comm)
30068 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30069 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
30070 CLASS(mp_comm_type), INTENT(IN) :: comm
30071
30072 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_cm'
30073
30074 INTEGER :: handle
30075#if defined(__parallel)
30076 INTEGER :: ierr, msglen, taskid
30077#endif
30078
30079 CALL mp_timeset(routinen, handle)
30080
30081#if defined(__parallel)
30082 msglen = SIZE(msg)
30083 CALL mpi_comm_rank(comm%handle, taskid, ierr)
30084 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
30085 IF (msglen > 0) THEN
30086 CALL mpi_scan(msg, res, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
30087 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
30088 END IF
30089 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30090 ! perf_id is same as for other summation routines
30091#else
30092 res = msg
30093 mark_used(comm)
30094#endif
30095 CALL mp_timestop(handle)
30096 END SUBROUTINE mp_sum_partial_cm
30097
30098! **************************************************************************************************
30099!> \brief Finds the maximum of a datum with the result left on all processes.
30100!> \param[in,out] msg Find maximum among these data (input) and
30101!> maximum (output)
30102!> \param[in] comm Message passing environment identifier
30103!> \par MPI mapping
30104!> mpi_allreduce
30105! **************************************************************************************************
30106 SUBROUTINE mp_max_c (msg, comm)
30107 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30108 CLASS(mp_comm_type), INTENT(IN) :: comm
30109
30110 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_c'
30111
30112 INTEGER :: handle
30113#if defined(__parallel)
30114 INTEGER :: ierr, msglen
30115#endif
30116
30117 CALL mp_timeset(routinen, handle)
30118
30119#if defined(__parallel)
30120 msglen = 1
30121 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_max, comm%handle, ierr)
30122 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30123 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30124#else
30125 mark_used(msg)
30126 mark_used(comm)
30127#endif
30128 CALL mp_timestop(handle)
30129 END SUBROUTINE mp_max_c
30130
30131! **************************************************************************************************
30132!> \brief Finds the maximum of a datum with the result left on all processes.
30133!> \param[in,out] msg Find maximum among these data (input) and
30134!> maximum (output)
30135!> \param[in] comm Message passing environment identifier
30136!> \par MPI mapping
30137!> mpi_allreduce
30138! **************************************************************************************************
30139 SUBROUTINE mp_max_root_c (msg, root, comm)
30140 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30141 INTEGER, INTENT(IN) :: root
30142 CLASS(mp_comm_type), INTENT(IN) :: comm
30143
30144 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_c'
30145
30146 INTEGER :: handle
30147#if defined(__parallel)
30148 INTEGER :: ierr, msglen
30149 COMPLEX(kind=real_4) :: res
30150#endif
30151
30152 CALL mp_timeset(routinen, handle)
30153
30154#if defined(__parallel)
30155 msglen = 1
30156 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_max, root, comm%handle, ierr)
30157 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30158 IF (root == comm%mepos) msg = res
30159 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30160#else
30161 mark_used(msg)
30162 mark_used(comm)
30163 mark_used(root)
30164#endif
30165 CALL mp_timestop(handle)
30166 END SUBROUTINE mp_max_root_c
30167
30168! **************************************************************************************************
30169!> \brief Finds the element-wise maximum of a vector with the result left on
30170!> all processes.
30171!> \param[in,out] msg Find maximum among these data (input) and
30172!> maximum (output)
30173!> \param comm ...
30174!> \note see mp_max_c
30175! **************************************************************************************************
30176 SUBROUTINE mp_max_cv(msg, comm)
30177 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30178 CLASS(mp_comm_type), INTENT(IN) :: comm
30179
30180 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_cv'
30181
30182 INTEGER :: handle
30183#if defined(__parallel)
30184 INTEGER :: ierr, msglen
30185#endif
30186
30187 CALL mp_timeset(routinen, handle)
30188
30189#if defined(__parallel)
30190 msglen = SIZE(msg)
30191 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_max, comm%handle, ierr)
30192 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30193 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30194#else
30195 mark_used(msg)
30196 mark_used(comm)
30197#endif
30198 CALL mp_timestop(handle)
30199 END SUBROUTINE mp_max_cv
30200
30201! **************************************************************************************************
30202!> \brief Finds the element-wise maximum of a vector with the result left on
30203!> all processes.
30204!> \param[in,out] msg Find maximum among these data (input) and
30205!> maximum (output)
30206!> \param comm ...
30207!> \note see mp_max_c
30208! **************************************************************************************************
30209 SUBROUTINE mp_max_root_cm(msg, root, comm)
30210 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30211 INTEGER :: root
30212 CLASS(mp_comm_type), INTENT(IN) :: comm
30213
30214 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_cm'
30215
30216 INTEGER :: handle
30217#if defined(__parallel)
30218 INTEGER :: ierr, msglen
30219 COMPLEX(kind=real_4) :: res(size(msg, 1), size(msg, 2))
30220#endif
30221
30222 CALL mp_timeset(routinen, handle)
30223
30224#if defined(__parallel)
30225 msglen = SIZE(msg)
30226 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_max, root, comm%handle, ierr)
30227 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30228 IF (root == comm%mepos) msg = res
30229 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30230#else
30231 mark_used(msg)
30232 mark_used(comm)
30233 mark_used(root)
30234#endif
30235 CALL mp_timestop(handle)
30236 END SUBROUTINE mp_max_root_cm
30237
30238! **************************************************************************************************
30239!> \brief Finds the minimum of a datum with the result left on all processes.
30240!> \param[in,out] msg Find minimum among these data (input) and
30241!> maximum (output)
30242!> \param[in] comm Message passing environment identifier
30243!> \par MPI mapping
30244!> mpi_allreduce
30245! **************************************************************************************************
30246 SUBROUTINE mp_min_c (msg, comm)
30247 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30248 CLASS(mp_comm_type), INTENT(IN) :: comm
30249
30250 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_c'
30251
30252 INTEGER :: handle
30253#if defined(__parallel)
30254 INTEGER :: ierr, msglen
30255#endif
30256
30257 CALL mp_timeset(routinen, handle)
30258
30259#if defined(__parallel)
30260 msglen = 1
30261 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30262 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30263 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30264#else
30265 mark_used(msg)
30266 mark_used(comm)
30267#endif
30268 CALL mp_timestop(handle)
30269 END SUBROUTINE mp_min_c
30270
30271! **************************************************************************************************
30272!> \brief Finds the element-wise minimum of vector with the result left on
30273!> all processes.
30274!> \param[in,out] msg Find minimum among these data (input) and
30275!> maximum (output)
30276!> \param comm ...
30277!> \par MPI mapping
30278!> mpi_allreduce
30279!> \note see mp_min_c
30280! **************************************************************************************************
30281 SUBROUTINE mp_min_cv(msg, comm)
30282 COMPLEX(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
30283 CLASS(mp_comm_type), INTENT(IN) :: comm
30284
30285 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_cv'
30286
30287 INTEGER :: handle
30288#if defined(__parallel)
30289 INTEGER :: ierr, msglen
30290#endif
30291
30292 CALL mp_timeset(routinen, handle)
30293
30294#if defined(__parallel)
30295 msglen = SIZE(msg)
30296 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30297 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30298 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30299#else
30300 mark_used(msg)
30301 mark_used(comm)
30302#endif
30303 CALL mp_timestop(handle)
30304 END SUBROUTINE mp_min_cv
30305
30306! **************************************************************************************************
30307!> \brief Multiplies a set of numbers scattered across a number of processes,
30308!> then replicates the result.
30309!> \param[in,out] msg a number to multiply (input) and result (output)
30310!> \param[in] comm message passing environment identifier
30311!> \par MPI mapping
30312!> mpi_allreduce
30313! **************************************************************************************************
30314 SUBROUTINE mp_prod_c (msg, comm)
30315 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30316 CLASS(mp_comm_type), INTENT(IN) :: comm
30317
30318 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_c'
30319
30320 INTEGER :: handle
30321#if defined(__parallel)
30322 INTEGER :: ierr, msglen
30323#endif
30324
30325 CALL mp_timeset(routinen, handle)
30326
30327#if defined(__parallel)
30328 msglen = 1
30329 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_prod, comm%handle, ierr)
30330 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30331 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30332#else
30333 mark_used(msg)
30334 mark_used(comm)
30335#endif
30336 CALL mp_timestop(handle)
30337 END SUBROUTINE mp_prod_c
30338
30339! **************************************************************************************************
30340!> \brief Scatters data from one processes to all others
30341!> \param[in] msg_scatter Data to scatter (for root process)
30342!> \param[out] msg Received data
30343!> \param[in] root Process which scatters data
30344!> \param[in] comm Message passing environment identifier
30345!> \par MPI mapping
30346!> mpi_scatter
30347! **************************************************************************************************
30348 SUBROUTINE mp_scatter_cv(msg_scatter, msg, root, comm)
30349 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
30350 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
30351 INTEGER, INTENT(IN) :: root
30352 CLASS(mp_comm_type), INTENT(IN) :: comm
30353
30354 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_cv'
30355
30356 INTEGER :: handle
30357#if defined(__parallel)
30358 INTEGER :: ierr, msglen
30359#endif
30360
30361 CALL mp_timeset(routinen, handle)
30362
30363#if defined(__parallel)
30364 msglen = SIZE(msg)
30365 CALL mpi_scatter(msg_scatter, msglen, mpi_complex, msg, &
30366 msglen, mpi_complex, root, comm%handle, ierr)
30367 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
30368 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30369#else
30370 mark_used(root)
30371 mark_used(comm)
30372 msg = msg_scatter
30373#endif
30374 CALL mp_timestop(handle)
30375 END SUBROUTINE mp_scatter_cv
30376
30377! **************************************************************************************************
30378!> \brief Scatters data from one processes to all others
30379!> \param[in] msg_scatter Data to scatter (for root process)
30380!> \param[in] root Process which scatters data
30381!> \param[in] comm Message passing environment identifier
30382!> \par MPI mapping
30383!> mpi_scatter
30384! **************************************************************************************************
30385 SUBROUTINE mp_iscatter_c (msg_scatter, msg, root, comm, request)
30386 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:)
30387 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30388 INTEGER, INTENT(IN) :: root
30389 CLASS(mp_comm_type), INTENT(IN) :: comm
30390 TYPE(mp_request_type), INTENT(OUT) :: request
30391
30392 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_c'
30393
30394 INTEGER :: handle
30395#if defined(__parallel)
30396 INTEGER :: ierr, msglen
30397#endif
30398
30399 CALL mp_timeset(routinen, handle)
30400
30401#if defined(__parallel)
30402#if !defined(__GNUC__) || __GNUC__ >= 9
30403 cpassert(is_contiguous(msg_scatter))
30404#endif
30405 msglen = 1
30406 CALL mpi_iscatter(msg_scatter, msglen, mpi_complex, msg, &
30407 msglen, mpi_complex, root, comm%handle, request%handle, ierr)
30408 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
30409 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30410#else
30411 mark_used(root)
30412 mark_used(comm)
30413 msg = msg_scatter(1)
30414 request = mp_request_null
30415#endif
30416 CALL mp_timestop(handle)
30417 END SUBROUTINE mp_iscatter_c
30418
30419! **************************************************************************************************
30420!> \brief Scatters data from one processes to all others
30421!> \param[in] msg_scatter Data to scatter (for root process)
30422!> \param[in] root Process which scatters data
30423!> \param[in] comm Message passing environment identifier
30424!> \par MPI mapping
30425!> mpi_scatter
30426! **************************************************************************************************
30427 SUBROUTINE mp_iscatter_cv2(msg_scatter, msg, root, comm, request)
30428 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:, :)
30429 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
30430 INTEGER, INTENT(IN) :: root
30431 CLASS(mp_comm_type), INTENT(IN) :: comm
30432 TYPE(mp_request_type), INTENT(OUT) :: request
30433
30434 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_cv2'
30435
30436 INTEGER :: handle
30437#if defined(__parallel)
30438 INTEGER :: ierr, msglen
30439#endif
30440
30441 CALL mp_timeset(routinen, handle)
30442
30443#if defined(__parallel)
30444#if !defined(__GNUC__) || __GNUC__ >= 9
30445 cpassert(is_contiguous(msg_scatter))
30446#endif
30447 msglen = SIZE(msg)
30448 CALL mpi_iscatter(msg_scatter, msglen, mpi_complex, msg, &
30449 msglen, mpi_complex, root, comm%handle, request%handle, ierr)
30450 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
30451 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30452#else
30453 mark_used(root)
30454 mark_used(comm)
30455 msg(:) = msg_scatter(:, 1)
30456 request = mp_request_null
30457#endif
30458 CALL mp_timestop(handle)
30459 END SUBROUTINE mp_iscatter_cv2
30460
30461! **************************************************************************************************
30462!> \brief Scatters data from one processes to all others
30463!> \param[in] msg_scatter Data to scatter (for root process)
30464!> \param[in] root Process which scatters data
30465!> \param[in] comm Message passing environment identifier
30466!> \par MPI mapping
30467!> mpi_scatter
30468! **************************************************************************************************
30469 SUBROUTINE mp_iscatterv_cv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
30470 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:)
30471 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
30472 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
30473 INTEGER, INTENT(IN) :: recvcount, root
30474 CLASS(mp_comm_type), INTENT(IN) :: comm
30475 TYPE(mp_request_type), INTENT(OUT) :: request
30476
30477 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_cv'
30478
30479 INTEGER :: handle
30480#if defined(__parallel)
30481 INTEGER :: ierr
30482#endif
30483
30484 CALL mp_timeset(routinen, handle)
30485
30486#if defined(__parallel)
30487#if !defined(__GNUC__) || __GNUC__ >= 9
30488 cpassert(is_contiguous(msg_scatter))
30489 cpassert(is_contiguous(msg))
30490 cpassert(is_contiguous(sendcounts))
30491 cpassert(is_contiguous(displs))
30492#endif
30493 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_complex, msg, &
30494 recvcount, mpi_complex, root, comm%handle, request%handle, ierr)
30495 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
30496 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30497#else
30498 mark_used(sendcounts)
30499 mark_used(displs)
30500 mark_used(recvcount)
30501 mark_used(root)
30502 mark_used(comm)
30503 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
30504 request = mp_request_null
30505#endif
30506 CALL mp_timestop(handle)
30507 END SUBROUTINE mp_iscatterv_cv
30508
30509! **************************************************************************************************
30510!> \brief Gathers a datum from all processes to one
30511!> \param[in] msg Datum to send to root
30512!> \param[out] msg_gather Received data (on root)
30513!> \param[in] root Process which gathers the data
30514!> \param[in] comm Message passing environment identifier
30515!> \par MPI mapping
30516!> mpi_gather
30517! **************************************************************************************************
30518 SUBROUTINE mp_gather_c (msg, msg_gather, root, comm)
30519 COMPLEX(kind=real_4), INTENT(IN) :: msg
30520 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30521 INTEGER, INTENT(IN) :: root
30522 CLASS(mp_comm_type), INTENT(IN) :: comm
30523
30524 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_c'
30525
30526 INTEGER :: handle
30527#if defined(__parallel)
30528 INTEGER :: ierr, msglen
30529#endif
30530
30531 CALL mp_timeset(routinen, handle)
30532
30533#if defined(__parallel)
30534 msglen = 1
30535 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30536 msglen, mpi_complex, root, comm%handle, ierr)
30537 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30538 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30539#else
30540 mark_used(root)
30541 mark_used(comm)
30542 msg_gather(1) = msg
30543#endif
30544 CALL mp_timestop(handle)
30545 END SUBROUTINE mp_gather_c
30546
30547! **************************************************************************************************
30548!> \brief Gathers a datum from all processes to one, uses the source process of comm
30549!> \param[in] msg Datum to send to root
30550!> \param[out] msg_gather Received data (on root)
30551!> \param[in] comm Message passing environment identifier
30552!> \par MPI mapping
30553!> mpi_gather
30554! **************************************************************************************************
30555 SUBROUTINE mp_gather_c_src(msg, msg_gather, comm)
30556 COMPLEX(kind=real_4), INTENT(IN) :: msg
30557 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30558 CLASS(mp_comm_type), INTENT(IN) :: comm
30559
30560 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_c_src'
30561
30562 INTEGER :: handle
30563#if defined(__parallel)
30564 INTEGER :: ierr, msglen
30565#endif
30566
30567 CALL mp_timeset(routinen, handle)
30568
30569#if defined(__parallel)
30570 msglen = 1
30571 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30572 msglen, mpi_complex, comm%source, comm%handle, ierr)
30573 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30574 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30575#else
30576 mark_used(comm)
30577 msg_gather(1) = msg
30578#endif
30579 CALL mp_timestop(handle)
30580 END SUBROUTINE mp_gather_c_src
30581
30582! **************************************************************************************************
30583!> \brief Gathers data from all processes to one
30584!> \param[in] msg Datum to send to root
30585!> \param msg_gather ...
30586!> \param root ...
30587!> \param comm ...
30588!> \par Data length
30589!> All data (msg) is equal-sized
30590!> \par MPI mapping
30591!> mpi_gather
30592!> \note see mp_gather_c
30593! **************************************************************************************************
30594 SUBROUTINE mp_gather_cv(msg, msg_gather, root, comm)
30595 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
30596 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30597 INTEGER, INTENT(IN) :: root
30598 CLASS(mp_comm_type), INTENT(IN) :: comm
30599
30600 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cv'
30601
30602 INTEGER :: handle
30603#if defined(__parallel)
30604 INTEGER :: ierr, msglen
30605#endif
30606
30607 CALL mp_timeset(routinen, handle)
30608
30609#if defined(__parallel)
30610 msglen = SIZE(msg)
30611 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30612 msglen, mpi_complex, root, comm%handle, ierr)
30613 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30614 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30615#else
30616 mark_used(root)
30617 mark_used(comm)
30618 msg_gather = msg
30619#endif
30620 CALL mp_timestop(handle)
30621 END SUBROUTINE mp_gather_cv
30622
30623! **************************************************************************************************
30624!> \brief Gathers data from all processes to one. Gathers from comm%source
30625!> \param[in] msg Datum to send to root
30626!> \param msg_gather ...
30627!> \param comm ...
30628!> \par Data length
30629!> All data (msg) is equal-sized
30630!> \par MPI mapping
30631!> mpi_gather
30632!> \note see mp_gather_c
30633! **************************************************************************************************
30634 SUBROUTINE mp_gather_cv_src(msg, msg_gather, comm)
30635 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
30636 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30637 CLASS(mp_comm_type), INTENT(IN) :: comm
30638
30639 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cv_src'
30640
30641 INTEGER :: handle
30642#if defined(__parallel)
30643 INTEGER :: ierr, msglen
30644#endif
30645
30646 CALL mp_timeset(routinen, handle)
30647
30648#if defined(__parallel)
30649 msglen = SIZE(msg)
30650 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30651 msglen, mpi_complex, comm%source, comm%handle, ierr)
30652 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30653 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30654#else
30655 mark_used(comm)
30656 msg_gather = msg
30657#endif
30658 CALL mp_timestop(handle)
30659 END SUBROUTINE mp_gather_cv_src
30660
30661! **************************************************************************************************
30662!> \brief Gathers data from all processes to one
30663!> \param[in] msg Datum to send to root
30664!> \param msg_gather ...
30665!> \param root ...
30666!> \param comm ...
30667!> \par Data length
30668!> All data (msg) is equal-sized
30669!> \par MPI mapping
30670!> mpi_gather
30671!> \note see mp_gather_c
30672! **************************************************************************************************
30673 SUBROUTINE mp_gather_cm(msg, msg_gather, root, comm)
30674 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30675 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
30676 INTEGER, INTENT(IN) :: root
30677 CLASS(mp_comm_type), INTENT(IN) :: comm
30678
30679 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cm'
30680
30681 INTEGER :: handle
30682#if defined(__parallel)
30683 INTEGER :: ierr, msglen
30684#endif
30685
30686 CALL mp_timeset(routinen, handle)
30687
30688#if defined(__parallel)
30689 msglen = SIZE(msg)
30690 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30691 msglen, mpi_complex, root, comm%handle, ierr)
30692 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30693 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30694#else
30695 mark_used(root)
30696 mark_used(comm)
30697 msg_gather = msg
30698#endif
30699 CALL mp_timestop(handle)
30700 END SUBROUTINE mp_gather_cm
30701
30702! **************************************************************************************************
30703!> \brief Gathers data from all processes to one. Gathers from comm%source
30704!> \param[in] msg Datum to send to root
30705!> \param msg_gather ...
30706!> \param comm ...
30707!> \par Data length
30708!> All data (msg) is equal-sized
30709!> \par MPI mapping
30710!> mpi_gather
30711!> \note see mp_gather_c
30712! **************************************************************************************************
30713 SUBROUTINE mp_gather_cm_src(msg, msg_gather, comm)
30714 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30715 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
30716 CLASS(mp_comm_type), INTENT(IN) :: comm
30717
30718 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cm_src'
30719
30720 INTEGER :: handle
30721#if defined(__parallel)
30722 INTEGER :: ierr, msglen
30723#endif
30724
30725 CALL mp_timeset(routinen, handle)
30726
30727#if defined(__parallel)
30728 msglen = SIZE(msg)
30729 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30730 msglen, mpi_complex, comm%source, comm%handle, ierr)
30731 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30732 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30733#else
30734 mark_used(comm)
30735 msg_gather = msg
30736#endif
30737 CALL mp_timestop(handle)
30738 END SUBROUTINE mp_gather_cm_src
30739
30740! **************************************************************************************************
30741!> \brief Gathers data from all processes to one.
30742!> \param[in] sendbuf Data to send to root
30743!> \param[out] recvbuf Received data (on root)
30744!> \param[in] recvcounts Sizes of data received from processes
30745!> \param[in] displs Offsets of data received from processes
30746!> \param[in] root Process which gathers the data
30747!> \param[in] comm Message passing environment identifier
30748!> \par Data length
30749!> Data can have different lengths
30750!> \par Offsets
30751!> Offsets start at 0
30752!> \par MPI mapping
30753!> mpi_gather
30754! **************************************************************************************************
30755 SUBROUTINE mp_gatherv_cv(sendbuf, recvbuf, recvcounts, displs, root, comm)
30756
30757 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
30758 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
30759 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30760 INTEGER, INTENT(IN) :: root
30761 CLASS(mp_comm_type), INTENT(IN) :: comm
30762
30763 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cv'
30764
30765 INTEGER :: handle
30766#if defined(__parallel)
30767 INTEGER :: ierr, sendcount
30768#endif
30769
30770 CALL mp_timeset(routinen, handle)
30771
30772#if defined(__parallel)
30773 sendcount = SIZE(sendbuf)
30774 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30775 recvbuf, recvcounts, displs, mpi_complex, &
30776 root, comm%handle, ierr)
30777 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30778 CALL add_perf(perf_id=4, &
30779 count=1, &
30780 msg_size=sendcount*(2*real_4_size))
30781#else
30782 mark_used(recvcounts)
30783 mark_used(root)
30784 mark_used(comm)
30785 recvbuf(1 + displs(1):) = sendbuf
30786#endif
30787 CALL mp_timestop(handle)
30788 END SUBROUTINE mp_gatherv_cv
30789
30790! **************************************************************************************************
30791!> \brief Gathers data from all processes to one. Gathers from comm%source
30792!> \param[in] sendbuf Data to send to root
30793!> \param[out] recvbuf Received data (on root)
30794!> \param[in] recvcounts Sizes of data received from processes
30795!> \param[in] displs Offsets of data received from processes
30796!> \param[in] comm Message passing environment identifier
30797!> \par Data length
30798!> Data can have different lengths
30799!> \par Offsets
30800!> Offsets start at 0
30801!> \par MPI mapping
30802!> mpi_gather
30803! **************************************************************************************************
30804 SUBROUTINE mp_gatherv_cv_src(sendbuf, recvbuf, recvcounts, displs, comm)
30805
30806 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
30807 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
30808 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30809 CLASS(mp_comm_type), INTENT(IN) :: comm
30810
30811 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cv_src'
30812
30813 INTEGER :: handle
30814#if defined(__parallel)
30815 INTEGER :: ierr, sendcount
30816#endif
30817
30818 CALL mp_timeset(routinen, handle)
30819
30820#if defined(__parallel)
30821 sendcount = SIZE(sendbuf)
30822 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30823 recvbuf, recvcounts, displs, mpi_complex, &
30824 comm%source, comm%handle, ierr)
30825 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30826 CALL add_perf(perf_id=4, &
30827 count=1, &
30828 msg_size=sendcount*(2*real_4_size))
30829#else
30830 mark_used(recvcounts)
30831 mark_used(comm)
30832 recvbuf(1 + displs(1):) = sendbuf
30833#endif
30834 CALL mp_timestop(handle)
30835 END SUBROUTINE mp_gatherv_cv_src
30836
30837! **************************************************************************************************
30838!> \brief Gathers data from all processes to one.
30839!> \param[in] sendbuf Data to send to root
30840!> \param[out] recvbuf Received data (on root)
30841!> \param[in] recvcounts Sizes of data received from processes
30842!> \param[in] displs Offsets of data received from processes
30843!> \param[in] root Process which gathers the data
30844!> \param[in] comm Message passing environment identifier
30845!> \par Data length
30846!> Data can have different lengths
30847!> \par Offsets
30848!> Offsets start at 0
30849!> \par MPI mapping
30850!> mpi_gather
30851! **************************************************************************************************
30852 SUBROUTINE mp_gatherv_cm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
30853
30854 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
30855 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
30856 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30857 INTEGER, INTENT(IN) :: root
30858 CLASS(mp_comm_type), INTENT(IN) :: comm
30859
30860 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cm2'
30861
30862 INTEGER :: handle
30863#if defined(__parallel)
30864 INTEGER :: ierr, sendcount
30865#endif
30866
30867 CALL mp_timeset(routinen, handle)
30868
30869#if defined(__parallel)
30870 sendcount = SIZE(sendbuf)
30871 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30872 recvbuf, recvcounts, displs, mpi_complex, &
30873 root, comm%handle, ierr)
30874 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30875 CALL add_perf(perf_id=4, &
30876 count=1, &
30877 msg_size=sendcount*(2*real_4_size))
30878#else
30879 mark_used(recvcounts)
30880 mark_used(root)
30881 mark_used(comm)
30882 recvbuf(:, 1 + displs(1):) = sendbuf
30883#endif
30884 CALL mp_timestop(handle)
30885 END SUBROUTINE mp_gatherv_cm2
30886
30887! **************************************************************************************************
30888!> \brief Gathers data from all processes to one.
30889!> \param[in] sendbuf Data to send to root
30890!> \param[out] recvbuf Received data (on root)
30891!> \param[in] recvcounts Sizes of data received from processes
30892!> \param[in] displs Offsets of data received from processes
30893!> \param[in] comm Message passing environment identifier
30894!> \par Data length
30895!> Data can have different lengths
30896!> \par Offsets
30897!> Offsets start at 0
30898!> \par MPI mapping
30899!> mpi_gather
30900! **************************************************************************************************
30901 SUBROUTINE mp_gatherv_cm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
30902
30903 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
30904 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
30905 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30906 CLASS(mp_comm_type), INTENT(IN) :: comm
30907
30908 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cm2_src'
30909
30910 INTEGER :: handle
30911#if defined(__parallel)
30912 INTEGER :: ierr, sendcount
30913#endif
30914
30915 CALL mp_timeset(routinen, handle)
30916
30917#if defined(__parallel)
30918 sendcount = SIZE(sendbuf)
30919 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30920 recvbuf, recvcounts, displs, mpi_complex, &
30921 comm%source, comm%handle, ierr)
30922 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30923 CALL add_perf(perf_id=4, &
30924 count=1, &
30925 msg_size=sendcount*(2*real_4_size))
30926#else
30927 mark_used(recvcounts)
30928 mark_used(comm)
30929 recvbuf(:, 1 + displs(1):) = sendbuf
30930#endif
30931 CALL mp_timestop(handle)
30932 END SUBROUTINE mp_gatherv_cm2_src
30933
30934! **************************************************************************************************
30935!> \brief Gathers data from all processes to one.
30936!> \param[in] sendbuf Data to send to root
30937!> \param[out] recvbuf Received data (on root)
30938!> \param[in] recvcounts Sizes of data received from processes
30939!> \param[in] displs Offsets of data received from processes
30940!> \param[in] root Process which gathers the data
30941!> \param[in] comm Message passing environment identifier
30942!> \par Data length
30943!> Data can have different lengths
30944!> \par Offsets
30945!> Offsets start at 0
30946!> \par MPI mapping
30947!> mpi_gather
30948! **************************************************************************************************
30949 SUBROUTINE mp_igatherv_cv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
30950 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: sendbuf
30951 COMPLEX(kind=real_4), DIMENSION(:), INTENT(OUT) :: recvbuf
30952 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30953 INTEGER, INTENT(IN) :: sendcount, root
30954 CLASS(mp_comm_type), INTENT(IN) :: comm
30955 TYPE(mp_request_type), INTENT(OUT) :: request
30956
30957 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_cv'
30958
30959 INTEGER :: handle
30960#if defined(__parallel)
30961 INTEGER :: ierr
30962#endif
30963
30964 CALL mp_timeset(routinen, handle)
30965
30966#if defined(__parallel)
30967#if !defined(__GNUC__) || __GNUC__ >= 9
30968 cpassert(is_contiguous(sendbuf))
30969 cpassert(is_contiguous(recvbuf))
30970 cpassert(is_contiguous(recvcounts))
30971 cpassert(is_contiguous(displs))
30972#endif
30973 CALL mpi_igatherv(sendbuf, sendcount, mpi_complex, &
30974 recvbuf, recvcounts, displs, mpi_complex, &
30975 root, comm%handle, request%handle, ierr)
30976 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30977 CALL add_perf(perf_id=24, &
30978 count=1, &
30979 msg_size=sendcount*(2*real_4_size))
30980#else
30981 mark_used(sendcount)
30982 mark_used(recvcounts)
30983 mark_used(root)
30984 mark_used(comm)
30985 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
30986 request = mp_request_null
30987#endif
30988 CALL mp_timestop(handle)
30989 END SUBROUTINE mp_igatherv_cv
30990
30991! **************************************************************************************************
30992!> \brief Gathers a datum from all processes and all processes receive the
30993!> same data
30994!> \param[in] msgout Datum to send
30995!> \param[out] msgin Received data
30996!> \param[in] comm Message passing environment identifier
30997!> \par Data size
30998!> All processes send equal-sized data
30999!> \par MPI mapping
31000!> mpi_allgather
31001! **************************************************************************************************
31002 SUBROUTINE mp_allgather_c (msgout, msgin, comm)
31003 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31004 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
31005 CLASS(mp_comm_type), INTENT(IN) :: comm
31006
31007 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c'
31008
31009 INTEGER :: handle
31010#if defined(__parallel)
31011 INTEGER :: ierr, rcount, scount
31012#endif
31013
31014 CALL mp_timeset(routinen, handle)
31015
31016#if defined(__parallel)
31017 scount = 1
31018 rcount = 1
31019 CALL mpi_allgather(msgout, scount, mpi_complex, &
31020 msgin, rcount, mpi_complex, &
31021 comm%handle, ierr)
31022 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31023#else
31024 mark_used(comm)
31025 msgin = msgout
31026#endif
31027 CALL mp_timestop(handle)
31028 END SUBROUTINE mp_allgather_c
31029
31030! **************************************************************************************************
31031!> \brief Gathers a datum from all processes and all processes receive the
31032!> same data
31033!> \param[in] msgout Datum to send
31034!> \param[out] msgin Received data
31035!> \param[in] comm Message passing environment identifier
31036!> \par Data size
31037!> All processes send equal-sized data
31038!> \par MPI mapping
31039!> mpi_allgather
31040! **************************************************************************************************
31041 SUBROUTINE mp_allgather_c2(msgout, msgin, comm)
31042 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31043 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31044 CLASS(mp_comm_type), INTENT(IN) :: comm
31045
31046 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c2'
31047
31048 INTEGER :: handle
31049#if defined(__parallel)
31050 INTEGER :: ierr, rcount, scount
31051#endif
31052
31053 CALL mp_timeset(routinen, handle)
31054
31055#if defined(__parallel)
31056 scount = 1
31057 rcount = 1
31058 CALL mpi_allgather(msgout, scount, mpi_complex, &
31059 msgin, rcount, mpi_complex, &
31060 comm%handle, ierr)
31061 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31062#else
31063 mark_used(comm)
31064 msgin = msgout
31065#endif
31066 CALL mp_timestop(handle)
31067 END SUBROUTINE mp_allgather_c2
31068
31069! **************************************************************************************************
31070!> \brief Gathers a datum from all processes and all processes receive the
31071!> same data
31072!> \param[in] msgout Datum to send
31073!> \param[out] msgin Received data
31074!> \param[in] comm Message passing environment identifier
31075!> \par Data size
31076!> All processes send equal-sized data
31077!> \par MPI mapping
31078!> mpi_allgather
31079! **************************************************************************************************
31080 SUBROUTINE mp_iallgather_c (msgout, msgin, comm, request)
31081 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31082 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31083 CLASS(mp_comm_type), INTENT(IN) :: comm
31084 TYPE(mp_request_type), INTENT(OUT) :: request
31085
31086 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c'
31087
31088 INTEGER :: handle
31089#if defined(__parallel)
31090 INTEGER :: ierr, rcount, scount
31091#endif
31092
31093 CALL mp_timeset(routinen, handle)
31094
31095#if defined(__parallel)
31096#if !defined(__GNUC__) || __GNUC__ >= 9
31097 cpassert(is_contiguous(msgin))
31098#endif
31099 scount = 1
31100 rcount = 1
31101 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31102 msgin, rcount, mpi_complex, &
31103 comm%handle, request%handle, ierr)
31104 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31105#else
31106 mark_used(comm)
31107 msgin = msgout
31108 request = mp_request_null
31109#endif
31110 CALL mp_timestop(handle)
31111 END SUBROUTINE mp_iallgather_c
31112
31113! **************************************************************************************************
31114!> \brief Gathers vector data from all processes and all processes receive the
31115!> same data
31116!> \param[in] msgout Rank-1 data to send
31117!> \param[out] msgin Received data
31118!> \param[in] comm Message passing environment identifier
31119!> \par Data size
31120!> All processes send equal-sized data
31121!> \par Ranks
31122!> The last rank counts the processes
31123!> \par MPI mapping
31124!> mpi_allgather
31125! **************************************************************************************************
31126 SUBROUTINE mp_allgather_c12(msgout, msgin, comm)
31127 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:)
31128 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31129 CLASS(mp_comm_type), INTENT(IN) :: comm
31130
31131 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c12'
31132
31133 INTEGER :: handle
31134#if defined(__parallel)
31135 INTEGER :: ierr, rcount, scount
31136#endif
31137
31138 CALL mp_timeset(routinen, handle)
31139
31140#if defined(__parallel)
31141 scount = SIZE(msgout(:))
31142 rcount = scount
31143 CALL mpi_allgather(msgout, scount, mpi_complex, &
31144 msgin, rcount, mpi_complex, &
31145 comm%handle, ierr)
31146 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31147#else
31148 mark_used(comm)
31149 msgin(:, 1) = msgout(:)
31150#endif
31151 CALL mp_timestop(handle)
31152 END SUBROUTINE mp_allgather_c12
31153
31154! **************************************************************************************************
31155!> \brief Gathers matrix data from all processes and all processes receive the
31156!> same data
31157!> \param[in] msgout Rank-2 data to send
31158!> \param msgin ...
31159!> \param comm ...
31160!> \note see mp_allgather_c12
31161! **************************************************************************************************
31162 SUBROUTINE mp_allgather_c23(msgout, msgin, comm)
31163 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
31164 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
31165 CLASS(mp_comm_type), INTENT(IN) :: comm
31166
31167 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c23'
31168
31169 INTEGER :: handle
31170#if defined(__parallel)
31171 INTEGER :: ierr, rcount, scount
31172#endif
31173
31174 CALL mp_timeset(routinen, handle)
31175
31176#if defined(__parallel)
31177 scount = SIZE(msgout(:, :))
31178 rcount = scount
31179 CALL mpi_allgather(msgout, scount, mpi_complex, &
31180 msgin, rcount, mpi_complex, &
31181 comm%handle, ierr)
31182 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31183#else
31184 mark_used(comm)
31185 msgin(:, :, 1) = msgout(:, :)
31186#endif
31187 CALL mp_timestop(handle)
31188 END SUBROUTINE mp_allgather_c23
31189
31190! **************************************************************************************************
31191!> \brief Gathers rank-3 data from all processes and all processes receive the
31192!> same data
31193!> \param[in] msgout Rank-3 data to send
31194!> \param msgin ...
31195!> \param comm ...
31196!> \note see mp_allgather_c12
31197! **************************************************************************************************
31198 SUBROUTINE mp_allgather_c34(msgout, msgin, comm)
31199 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
31200 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
31201 CLASS(mp_comm_type), INTENT(IN) :: comm
31202
31203 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c34'
31204
31205 INTEGER :: handle
31206#if defined(__parallel)
31207 INTEGER :: ierr, rcount, scount
31208#endif
31209
31210 CALL mp_timeset(routinen, handle)
31211
31212#if defined(__parallel)
31213 scount = SIZE(msgout(:, :, :))
31214 rcount = scount
31215 CALL mpi_allgather(msgout, scount, mpi_complex, &
31216 msgin, rcount, mpi_complex, &
31217 comm%handle, ierr)
31218 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31219#else
31220 mark_used(comm)
31221 msgin(:, :, :, 1) = msgout(:, :, :)
31222#endif
31223 CALL mp_timestop(handle)
31224 END SUBROUTINE mp_allgather_c34
31225
31226! **************************************************************************************************
31227!> \brief Gathers rank-2 data from all processes and all processes receive the
31228!> same data
31229!> \param[in] msgout Rank-2 data to send
31230!> \param msgin ...
31231!> \param comm ...
31232!> \note see mp_allgather_c12
31233! **************************************************************************************************
31234 SUBROUTINE mp_allgather_c22(msgout, msgin, comm)
31235 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
31236 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31237 CLASS(mp_comm_type), INTENT(IN) :: comm
31238
31239 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c22'
31240
31241 INTEGER :: handle
31242#if defined(__parallel)
31243 INTEGER :: ierr, rcount, scount
31244#endif
31245
31246 CALL mp_timeset(routinen, handle)
31247
31248#if defined(__parallel)
31249 scount = SIZE(msgout(:, :))
31250 rcount = scount
31251 CALL mpi_allgather(msgout, scount, mpi_complex, &
31252 msgin, rcount, mpi_complex, &
31253 comm%handle, ierr)
31254 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31255#else
31256 mark_used(comm)
31257 msgin(:, :) = msgout(:, :)
31258#endif
31259 CALL mp_timestop(handle)
31260 END SUBROUTINE mp_allgather_c22
31261
31262! **************************************************************************************************
31263!> \brief Gathers rank-1 data from all processes and all processes receive the
31264!> same data
31265!> \param[in] msgout Rank-1 data to send
31266!> \param msgin ...
31267!> \param comm ...
31268!> \param request ...
31269!> \note see mp_allgather_c11
31270! **************************************************************************************************
31271 SUBROUTINE mp_iallgather_c11(msgout, msgin, comm, request)
31272 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31273 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31274 CLASS(mp_comm_type), INTENT(IN) :: comm
31275 TYPE(mp_request_type), INTENT(OUT) :: request
31276
31277 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c11'
31278
31279 INTEGER :: handle
31280#if defined(__parallel)
31281 INTEGER :: ierr, rcount, scount
31282#endif
31283
31284 CALL mp_timeset(routinen, handle)
31285
31286#if defined(__parallel)
31287#if !defined(__GNUC__) || __GNUC__ >= 9
31288 cpassert(is_contiguous(msgout))
31289 cpassert(is_contiguous(msgin))
31290#endif
31291 scount = SIZE(msgout(:))
31292 rcount = scount
31293 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31294 msgin, rcount, mpi_complex, &
31295 comm%handle, request%handle, ierr)
31296 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31297#else
31298 mark_used(comm)
31299 msgin = msgout
31300 request = mp_request_null
31301#endif
31302 CALL mp_timestop(handle)
31303 END SUBROUTINE mp_iallgather_c11
31304
31305! **************************************************************************************************
31306!> \brief Gathers rank-2 data from all processes and all processes receive the
31307!> same data
31308!> \param[in] msgout Rank-2 data to send
31309!> \param msgin ...
31310!> \param comm ...
31311!> \param request ...
31312!> \note see mp_allgather_c12
31313! **************************************************************************************************
31314 SUBROUTINE mp_iallgather_c13(msgout, msgin, comm, request)
31315 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31316 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
31317 CLASS(mp_comm_type), INTENT(IN) :: comm
31318 TYPE(mp_request_type), INTENT(OUT) :: request
31319
31320 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c13'
31321
31322 INTEGER :: handle
31323#if defined(__parallel)
31324 INTEGER :: ierr, rcount, scount
31325#endif
31326
31327 CALL mp_timeset(routinen, handle)
31328
31329#if defined(__parallel)
31330#if !defined(__GNUC__) || __GNUC__ >= 9
31331 cpassert(is_contiguous(msgout))
31332 cpassert(is_contiguous(msgin))
31333#endif
31334
31335 scount = SIZE(msgout(:))
31336 rcount = scount
31337 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31338 msgin, rcount, mpi_complex, &
31339 comm%handle, request%handle, ierr)
31340 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31341#else
31342 mark_used(comm)
31343 msgin(:, 1, 1) = msgout(:)
31344 request = mp_request_null
31345#endif
31346 CALL mp_timestop(handle)
31347 END SUBROUTINE mp_iallgather_c13
31348
31349! **************************************************************************************************
31350!> \brief Gathers rank-2 data from all processes and all processes receive the
31351!> same data
31352!> \param[in] msgout Rank-2 data to send
31353!> \param msgin ...
31354!> \param comm ...
31355!> \param request ...
31356!> \note see mp_allgather_c12
31357! **************************************************************************************************
31358 SUBROUTINE mp_iallgather_c22(msgout, msgin, comm, request)
31359 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :)
31360 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :)
31361 CLASS(mp_comm_type), INTENT(IN) :: comm
31362 TYPE(mp_request_type), INTENT(OUT) :: request
31363
31364 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c22'
31365
31366 INTEGER :: handle
31367#if defined(__parallel)
31368 INTEGER :: ierr, rcount, scount
31369#endif
31370
31371 CALL mp_timeset(routinen, handle)
31372
31373#if defined(__parallel)
31374#if !defined(__GNUC__) || __GNUC__ >= 9
31375 cpassert(is_contiguous(msgout))
31376 cpassert(is_contiguous(msgin))
31377#endif
31378
31379 scount = SIZE(msgout(:, :))
31380 rcount = scount
31381 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31382 msgin, rcount, mpi_complex, &
31383 comm%handle, request%handle, ierr)
31384 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31385#else
31386 mark_used(comm)
31387 msgin(:, :) = msgout(:, :)
31388 request = mp_request_null
31389#endif
31390 CALL mp_timestop(handle)
31391 END SUBROUTINE mp_iallgather_c22
31392
31393! **************************************************************************************************
31394!> \brief Gathers rank-2 data from all processes and all processes receive the
31395!> same data
31396!> \param[in] msgout Rank-2 data to send
31397!> \param msgin ...
31398!> \param comm ...
31399!> \param request ...
31400!> \note see mp_allgather_c12
31401! **************************************************************************************************
31402 SUBROUTINE mp_iallgather_c24(msgout, msgin, comm, request)
31403 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :)
31404 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :, :)
31405 CLASS(mp_comm_type), INTENT(IN) :: comm
31406 TYPE(mp_request_type), INTENT(OUT) :: request
31407
31408 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c24'
31409
31410 INTEGER :: handle
31411#if defined(__parallel)
31412 INTEGER :: ierr, rcount, scount
31413#endif
31414
31415 CALL mp_timeset(routinen, handle)
31416
31417#if defined(__parallel)
31418#if !defined(__GNUC__) || __GNUC__ >= 9
31419 cpassert(is_contiguous(msgout))
31420 cpassert(is_contiguous(msgin))
31421#endif
31422
31423 scount = SIZE(msgout(:, :))
31424 rcount = scount
31425 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31426 msgin, rcount, mpi_complex, &
31427 comm%handle, request%handle, ierr)
31428 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31429#else
31430 mark_used(comm)
31431 msgin(:, :, 1, 1) = msgout(:, :)
31432 request = mp_request_null
31433#endif
31434 CALL mp_timestop(handle)
31435 END SUBROUTINE mp_iallgather_c24
31436
31437! **************************************************************************************************
31438!> \brief Gathers rank-3 data from all processes and all processes receive the
31439!> same data
31440!> \param[in] msgout Rank-3 data to send
31441!> \param msgin ...
31442!> \param comm ...
31443!> \param request ...
31444!> \note see mp_allgather_c12
31445! **************************************************************************************************
31446 SUBROUTINE mp_iallgather_c33(msgout, msgin, comm, request)
31447 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :, :)
31448 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
31449 CLASS(mp_comm_type), INTENT(IN) :: comm
31450 TYPE(mp_request_type), INTENT(OUT) :: request
31451
31452 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c33'
31453
31454 INTEGER :: handle
31455#if defined(__parallel)
31456 INTEGER :: ierr, rcount, scount
31457#endif
31458
31459 CALL mp_timeset(routinen, handle)
31460
31461#if defined(__parallel)
31462#if !defined(__GNUC__) || __GNUC__ >= 9
31463 cpassert(is_contiguous(msgout))
31464 cpassert(is_contiguous(msgin))
31465#endif
31466
31467 scount = SIZE(msgout(:, :, :))
31468 rcount = scount
31469 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31470 msgin, rcount, mpi_complex, &
31471 comm%handle, request%handle, ierr)
31472 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31473#else
31474 mark_used(comm)
31475 msgin(:, :, :) = msgout(:, :, :)
31476 request = mp_request_null
31477#endif
31478 CALL mp_timestop(handle)
31479 END SUBROUTINE mp_iallgather_c33
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_allgatherv_cv(msgout, msgin, rcount, rdispl, comm)
31499 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
31500 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31501 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31502 CLASS(mp_comm_type), INTENT(IN) :: comm
31503
31504 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_cv'
31505
31506 INTEGER :: handle
31507#if defined(__parallel)
31508 INTEGER :: ierr, scount
31509#endif
31510
31511 CALL mp_timeset(routinen, handle)
31512
31513#if defined(__parallel)
31514 scount = SIZE(msgout)
31515 CALL mpi_allgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31516 rdispl, mpi_complex, comm%handle, ierr)
31517 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
31518#else
31519 mark_used(rcount)
31520 mark_used(rdispl)
31521 mark_used(comm)
31522 msgin = msgout
31523#endif
31524 CALL mp_timestop(handle)
31525 END SUBROUTINE mp_allgatherv_cv
31526
31527! **************************************************************************************************
31528!> \brief Gathers vector data from all processes and all processes receive the
31529!> same data
31530!> \param[in] msgout Rank-1 data to send
31531!> \param[out] msgin Received data
31532!> \param[in] rcount Size of sent data for every process
31533!> \param[in] rdispl Offset of sent data for every process
31534!> \param[in] comm Message passing environment identifier
31535!> \par Data size
31536!> Processes can send different-sized data
31537!> \par Ranks
31538!> The last rank counts the processes
31539!> \par Offsets
31540!> Offsets are from 0
31541!> \par MPI mapping
31542!> mpi_allgather
31543! **************************************************************************************************
31544 SUBROUTINE mp_allgatherv_cm2(msgout, msgin, rcount, rdispl, comm)
31545 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
31546 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
31547 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31548 CLASS(mp_comm_type), INTENT(IN) :: comm
31549
31550 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_cv'
31551
31552 INTEGER :: handle
31553#if defined(__parallel)
31554 INTEGER :: ierr, scount
31555#endif
31556
31557 CALL mp_timeset(routinen, handle)
31558
31559#if defined(__parallel)
31560 scount = SIZE(msgout)
31561 CALL mpi_allgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31562 rdispl, mpi_complex, comm%handle, ierr)
31563 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
31564#else
31565 mark_used(rcount)
31566 mark_used(rdispl)
31567 mark_used(comm)
31568 msgin = msgout
31569#endif
31570 CALL mp_timestop(handle)
31571 END SUBROUTINE mp_allgatherv_cm2
31572
31573! **************************************************************************************************
31574!> \brief Gathers vector data from all processes and all processes receive the
31575!> same data
31576!> \param[in] msgout Rank-1 data to send
31577!> \param[out] msgin Received data
31578!> \param[in] rcount Size of sent data for every process
31579!> \param[in] rdispl Offset of sent data for every process
31580!> \param[in] comm Message passing environment identifier
31581!> \par Data size
31582!> Processes can send different-sized data
31583!> \par Ranks
31584!> The last rank counts the processes
31585!> \par Offsets
31586!> Offsets are from 0
31587!> \par MPI mapping
31588!> mpi_allgather
31589! **************************************************************************************************
31590 SUBROUTINE mp_iallgatherv_cv(msgout, msgin, rcount, rdispl, comm, request)
31591 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31592 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31593 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31594 CLASS(mp_comm_type), INTENT(IN) :: comm
31595 TYPE(mp_request_type), INTENT(OUT) :: request
31596
31597 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_cv'
31598
31599 INTEGER :: handle
31600#if defined(__parallel)
31601 INTEGER :: ierr, scount, rsize
31602#endif
31603
31604 CALL mp_timeset(routinen, handle)
31605
31606#if defined(__parallel)
31607#if !defined(__GNUC__) || __GNUC__ >= 9
31608 cpassert(is_contiguous(msgout))
31609 cpassert(is_contiguous(msgin))
31610 cpassert(is_contiguous(rcount))
31611 cpassert(is_contiguous(rdispl))
31612#endif
31613
31614 scount = SIZE(msgout)
31615 rsize = SIZE(rcount)
31616 CALL mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, &
31617 rdispl, comm, request, ierr)
31618 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
31619#else
31620 mark_used(rcount)
31621 mark_used(rdispl)
31622 mark_used(comm)
31623 msgin = msgout
31624 request = mp_request_null
31625#endif
31626 CALL mp_timestop(handle)
31627 END SUBROUTINE mp_iallgatherv_cv
31628
31629! **************************************************************************************************
31630!> \brief Gathers vector data from all processes and all processes receive the
31631!> same data
31632!> \param[in] msgout Rank-1 data to send
31633!> \param[out] msgin Received data
31634!> \param[in] rcount Size of sent data for every process
31635!> \param[in] rdispl Offset of sent data for every process
31636!> \param[in] comm Message passing environment identifier
31637!> \par Data size
31638!> Processes can send different-sized data
31639!> \par Ranks
31640!> The last rank counts the processes
31641!> \par Offsets
31642!> Offsets are from 0
31643!> \par MPI mapping
31644!> mpi_allgather
31645! **************************************************************************************************
31646 SUBROUTINE mp_iallgatherv_cv2(msgout, msgin, rcount, rdispl, comm, request)
31647 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31648 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31649 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
31650 CLASS(mp_comm_type), INTENT(IN) :: comm
31651 TYPE(mp_request_type), INTENT(OUT) :: request
31652
31653 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_cv2'
31654
31655 INTEGER :: handle
31656#if defined(__parallel)
31657 INTEGER :: ierr, scount, rsize
31658#endif
31659
31660 CALL mp_timeset(routinen, handle)
31661
31662#if defined(__parallel)
31663#if !defined(__GNUC__) || __GNUC__ >= 9
31664 cpassert(is_contiguous(msgout))
31665 cpassert(is_contiguous(msgin))
31666 cpassert(is_contiguous(rcount))
31667 cpassert(is_contiguous(rdispl))
31668#endif
31669
31670 scount = SIZE(msgout)
31671 rsize = SIZE(rcount)
31672 CALL mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, &
31673 rdispl, comm, request, ierr)
31674 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
31675#else
31676 mark_used(rcount)
31677 mark_used(rdispl)
31678 mark_used(comm)
31679 msgin = msgout
31680 request = mp_request_null
31681#endif
31682 CALL mp_timestop(handle)
31683 END SUBROUTINE mp_iallgatherv_cv2
31684
31685! **************************************************************************************************
31686!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
31687!> the issue is with the rank of rcount and rdispl
31688!> \param count ...
31689!> \param array_of_requests ...
31690!> \param array_of_statuses ...
31691!> \param ierr ...
31692!> \author Alfio Lazzaro
31693! **************************************************************************************************
31694#if defined(__parallel)
31695 SUBROUTINE mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
31696 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
31697 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31698 INTEGER, INTENT(IN) :: rsize
31699 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
31700 CLASS(mp_comm_type), INTENT(IN) :: comm
31701 TYPE(mp_request_type), INTENT(OUT) :: request
31702 INTEGER, INTENT(INOUT) :: ierr
31703
31704 CALL mpi_iallgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31705 rdispl, mpi_complex, comm%handle, request%handle, ierr)
31706
31707 END SUBROUTINE mp_iallgatherv_cv_internal
31708#endif
31709
31710! **************************************************************************************************
31711!> \brief Sums a vector and partitions the result among processes
31712!> \param[in] msgout Data to sum
31713!> \param[out] msgin Received portion of summed data
31714!> \param[in] rcount Partition sizes of the summed data for
31715!> every process
31716!> \param[in] comm Message passing environment identifier
31717! **************************************************************************************************
31718 SUBROUTINE mp_sum_scatter_cv(msgout, msgin, rcount, comm)
31719 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
31720 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31721 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
31722 CLASS(mp_comm_type), INTENT(IN) :: comm
31723
31724 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_cv'
31725
31726 INTEGER :: handle
31727#if defined(__parallel)
31728 INTEGER :: ierr
31729#endif
31730
31731 CALL mp_timeset(routinen, handle)
31732
31733#if defined(__parallel)
31734 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_complex, mpi_sum, &
31735 comm%handle, ierr)
31736 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
31737
31738 CALL add_perf(perf_id=3, count=1, &
31739 msg_size=rcount(1)*2*(2*real_4_size))
31740#else
31741 mark_used(rcount)
31742 mark_used(comm)
31743 msgin = msgout(:, 1)
31744#endif
31745 CALL mp_timestop(handle)
31746 END SUBROUTINE mp_sum_scatter_cv
31747
31748! **************************************************************************************************
31749!> \brief Sends and receives vector data
31750!> \param[in] msgin Data to send
31751!> \param[in] dest Process to send data to
31752!> \param[out] msgout Received data
31753!> \param[in] source Process from which to receive
31754!> \param[in] comm Message passing environment identifier
31755!> \param[in] tag Send and recv tag (default: 0)
31756! **************************************************************************************************
31757 SUBROUTINE mp_sendrecv_c (msgin, dest, msgout, source, comm, tag)
31758 COMPLEX(kind=real_4), INTENT(IN) :: msgin
31759 INTEGER, INTENT(IN) :: dest
31760 COMPLEX(kind=real_4), INTENT(OUT) :: msgout
31761 INTEGER, INTENT(IN) :: source
31762 CLASS(mp_comm_type), INTENT(IN) :: comm
31763 INTEGER, INTENT(IN), OPTIONAL :: tag
31764
31765 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_c'
31766
31767 INTEGER :: handle
31768#if defined(__parallel)
31769 INTEGER :: ierr, msglen_in, msglen_out, &
31770 recv_tag, send_tag
31771#endif
31772
31773 CALL mp_timeset(routinen, handle)
31774
31775#if defined(__parallel)
31776 msglen_in = 1
31777 msglen_out = 1
31778 send_tag = 0 ! cannot think of something better here, this might be dangerous
31779 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31780 IF (PRESENT(tag)) THEN
31781 send_tag = tag
31782 recv_tag = tag
31783 END IF
31784 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31785 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31786 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31787 CALL add_perf(perf_id=7, count=1, &
31788 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31789#else
31790 mark_used(dest)
31791 mark_used(source)
31792 mark_used(comm)
31793 mark_used(tag)
31794 msgout = msgin
31795#endif
31796 CALL mp_timestop(handle)
31797 END SUBROUTINE mp_sendrecv_c
31798
31799! **************************************************************************************************
31800!> \brief Sends and receives vector data
31801!> \param[in] msgin Data to send
31802!> \param[in] dest Process to send data to
31803!> \param[out] msgout Received data
31804!> \param[in] source Process from which to receive
31805!> \param[in] comm Message passing environment identifier
31806!> \param[in] tag Send and recv tag (default: 0)
31807! **************************************************************************************************
31808 SUBROUTINE mp_sendrecv_cv(msgin, dest, msgout, source, comm, tag)
31809 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
31810 INTEGER, INTENT(IN) :: dest
31811 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
31812 INTEGER, INTENT(IN) :: source
31813 CLASS(mp_comm_type), INTENT(IN) :: comm
31814 INTEGER, INTENT(IN), OPTIONAL :: tag
31815
31816 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cv'
31817
31818 INTEGER :: handle
31819#if defined(__parallel)
31820 INTEGER :: ierr, msglen_in, msglen_out, &
31821 recv_tag, send_tag
31822#endif
31823
31824 CALL mp_timeset(routinen, handle)
31825
31826#if defined(__parallel)
31827 msglen_in = SIZE(msgin)
31828 msglen_out = SIZE(msgout)
31829 send_tag = 0 ! cannot think of something better here, this might be dangerous
31830 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31831 IF (PRESENT(tag)) THEN
31832 send_tag = tag
31833 recv_tag = tag
31834 END IF
31835 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31836 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31837 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31838 CALL add_perf(perf_id=7, count=1, &
31839 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31840#else
31841 mark_used(dest)
31842 mark_used(source)
31843 mark_used(comm)
31844 mark_used(tag)
31845 msgout = msgin
31846#endif
31847 CALL mp_timestop(handle)
31848 END SUBROUTINE mp_sendrecv_cv
31849
31850! **************************************************************************************************
31851!> \brief Sends and receives matrix data
31852!> \param msgin ...
31853!> \param dest ...
31854!> \param msgout ...
31855!> \param source ...
31856!> \param comm ...
31857!> \param tag ...
31858!> \note see mp_sendrecv_cv
31859! **************************************************************************************************
31860 SUBROUTINE mp_sendrecv_cm2(msgin, dest, msgout, source, comm, tag)
31861 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
31862 INTEGER, INTENT(IN) :: dest
31863 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
31864 INTEGER, INTENT(IN) :: source
31865 CLASS(mp_comm_type), INTENT(IN) :: comm
31866 INTEGER, INTENT(IN), OPTIONAL :: tag
31867
31868 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm2'
31869
31870 INTEGER :: handle
31871#if defined(__parallel)
31872 INTEGER :: ierr, msglen_in, msglen_out, &
31873 recv_tag, send_tag
31874#endif
31875
31876 CALL mp_timeset(routinen, handle)
31877
31878#if defined(__parallel)
31879 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
31880 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
31881 send_tag = 0 ! cannot think of something better here, this might be dangerous
31882 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31883 IF (PRESENT(tag)) THEN
31884 send_tag = tag
31885 recv_tag = tag
31886 END IF
31887 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31888 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31889 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31890 CALL add_perf(perf_id=7, count=1, &
31891 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31892#else
31893 mark_used(dest)
31894 mark_used(source)
31895 mark_used(comm)
31896 mark_used(tag)
31897 msgout = msgin
31898#endif
31899 CALL mp_timestop(handle)
31900 END SUBROUTINE mp_sendrecv_cm2
31901
31902! **************************************************************************************************
31903!> \brief Sends and receives rank-3 data
31904!> \param msgin ...
31905!> \param dest ...
31906!> \param msgout ...
31907!> \param source ...
31908!> \param comm ...
31909!> \note see mp_sendrecv_cv
31910! **************************************************************************************************
31911 SUBROUTINE mp_sendrecv_cm3(msgin, dest, msgout, source, comm, tag)
31912 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
31913 INTEGER, INTENT(IN) :: dest
31914 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
31915 INTEGER, INTENT(IN) :: source
31916 CLASS(mp_comm_type), INTENT(IN) :: comm
31917 INTEGER, INTENT(IN), OPTIONAL :: tag
31918
31919 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm3'
31920
31921 INTEGER :: handle
31922#if defined(__parallel)
31923 INTEGER :: ierr, msglen_in, msglen_out, &
31924 recv_tag, send_tag
31925#endif
31926
31927 CALL mp_timeset(routinen, handle)
31928
31929#if defined(__parallel)
31930 msglen_in = SIZE(msgin)
31931 msglen_out = SIZE(msgout)
31932 send_tag = 0 ! cannot think of something better here, this might be dangerous
31933 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31934 IF (PRESENT(tag)) THEN
31935 send_tag = tag
31936 recv_tag = tag
31937 END IF
31938 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31939 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31940 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31941 CALL add_perf(perf_id=7, count=1, &
31942 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31943#else
31944 mark_used(dest)
31945 mark_used(source)
31946 mark_used(comm)
31947 mark_used(tag)
31948 msgout = msgin
31949#endif
31950 CALL mp_timestop(handle)
31951 END SUBROUTINE mp_sendrecv_cm3
31952
31953! **************************************************************************************************
31954!> \brief Sends and receives rank-4 data
31955!> \param msgin ...
31956!> \param dest ...
31957!> \param msgout ...
31958!> \param source ...
31959!> \param comm ...
31960!> \note see mp_sendrecv_cv
31961! **************************************************************************************************
31962 SUBROUTINE mp_sendrecv_cm4(msgin, dest, msgout, source, comm, tag)
31963 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
31964 INTEGER, INTENT(IN) :: dest
31965 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
31966 INTEGER, INTENT(IN) :: source
31967 CLASS(mp_comm_type), INTENT(IN) :: comm
31968 INTEGER, INTENT(IN), OPTIONAL :: tag
31969
31970 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm4'
31971
31972 INTEGER :: handle
31973#if defined(__parallel)
31974 INTEGER :: ierr, msglen_in, msglen_out, &
31975 recv_tag, send_tag
31976#endif
31977
31978 CALL mp_timeset(routinen, handle)
31979
31980#if defined(__parallel)
31981 msglen_in = SIZE(msgin)
31982 msglen_out = SIZE(msgout)
31983 send_tag = 0 ! cannot think of something better here, this might be dangerous
31984 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31985 IF (PRESENT(tag)) THEN
31986 send_tag = tag
31987 recv_tag = tag
31988 END IF
31989 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31990 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31991 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31992 CALL add_perf(perf_id=7, count=1, &
31993 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31994#else
31995 mark_used(dest)
31996 mark_used(source)
31997 mark_used(comm)
31998 mark_used(tag)
31999 msgout = msgin
32000#endif
32001 CALL mp_timestop(handle)
32002 END SUBROUTINE mp_sendrecv_cm4
32003
32004! **************************************************************************************************
32005!> \brief Non-blocking send and receive of a scalar
32006!> \param[in] msgin Scalar data to send
32007!> \param[in] dest Which process to send to
32008!> \param[out] msgout Receive data into this pointer
32009!> \param[in] source Process to receive from
32010!> \param[in] comm Message passing environment identifier
32011!> \param[out] send_request Request handle for the send
32012!> \param[out] recv_request Request handle for the receive
32013!> \param[in] tag (optional) tag to differentiate requests
32014!> \par Implementation
32015!> Calls mpi_isend and mpi_irecv.
32016!> \par History
32017!> 02.2005 created [Alfio Lazzaro]
32018! **************************************************************************************************
32019 SUBROUTINE mp_isendrecv_c (msgin, dest, msgout, source, comm, send_request, &
32020 recv_request, tag)
32021 COMPLEX(kind=real_4), INTENT(IN) :: msgin
32022 INTEGER, INTENT(IN) :: dest
32023 COMPLEX(kind=real_4), INTENT(INOUT) :: msgout
32024 INTEGER, INTENT(IN) :: source
32025 CLASS(mp_comm_type), INTENT(IN) :: comm
32026 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
32027 INTEGER, INTENT(in), OPTIONAL :: tag
32028
32029 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_c'
32030
32031 INTEGER :: handle
32032#if defined(__parallel)
32033 INTEGER :: ierr, my_tag
32034#endif
32035
32036 CALL mp_timeset(routinen, handle)
32037
32038#if defined(__parallel)
32039 my_tag = 0
32040 IF (PRESENT(tag)) my_tag = tag
32041
32042 CALL mpi_irecv(msgout, 1, mpi_complex, source, my_tag, &
32043 comm%handle, recv_request%handle, ierr)
32044 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32045
32046 CALL mpi_isend(msgin, 1, mpi_complex, dest, my_tag, &
32047 comm%handle, send_request%handle, ierr)
32048 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32049
32050 CALL add_perf(perf_id=8, count=1, msg_size=2*(2*real_4_size))
32051#else
32052 mark_used(dest)
32053 mark_used(source)
32054 mark_used(comm)
32055 mark_used(tag)
32056 send_request = mp_request_null
32057 recv_request = mp_request_null
32058 msgout = msgin
32059#endif
32060 CALL mp_timestop(handle)
32061 END SUBROUTINE mp_isendrecv_c
32062
32063! **************************************************************************************************
32064!> \brief Non-blocking send and receive of a vector
32065!> \param[in] msgin Vector data to send
32066!> \param[in] dest Which process to send to
32067!> \param[out] msgout Receive data into this pointer
32068!> \param[in] source Process to receive from
32069!> \param[in] comm Message passing environment identifier
32070!> \param[out] send_request Request handle for the send
32071!> \param[out] recv_request Request handle for the receive
32072!> \param[in] tag (optional) tag to differentiate requests
32073!> \par Implementation
32074!> Calls mpi_isend and mpi_irecv.
32075!> \par History
32076!> 11.2004 created [Joost VandeVondele]
32077!> \note
32078!> arrays can be pointers or assumed shape, but they must be contiguous!
32079! **************************************************************************************************
32080 SUBROUTINE mp_isendrecv_cv(msgin, dest, msgout, source, comm, send_request, &
32081 recv_request, tag)
32082 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
32083 INTEGER, INTENT(IN) :: dest
32084 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
32085 INTEGER, INTENT(IN) :: source
32086 CLASS(mp_comm_type), INTENT(IN) :: comm
32087 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
32088 INTEGER, INTENT(in), OPTIONAL :: tag
32089
32090 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_cv'
32091
32092 INTEGER :: handle
32093#if defined(__parallel)
32094 INTEGER :: ierr, msglen, my_tag
32095 COMPLEX(kind=real_4) :: foo
32096#endif
32097
32098 CALL mp_timeset(routinen, handle)
32099
32100#if defined(__parallel)
32101#if !defined(__GNUC__) || __GNUC__ >= 9
32102 cpassert(is_contiguous(msgout))
32103 cpassert(is_contiguous(msgin))
32104#endif
32105
32106 my_tag = 0
32107 IF (PRESENT(tag)) my_tag = tag
32108
32109 msglen = SIZE(msgout, 1)
32110 IF (msglen > 0) THEN
32111 CALL mpi_irecv(msgout(1), msglen, mpi_complex, source, my_tag, &
32112 comm%handle, recv_request%handle, ierr)
32113 ELSE
32114 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32115 comm%handle, recv_request%handle, ierr)
32116 END IF
32117 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32118
32119 msglen = SIZE(msgin, 1)
32120 IF (msglen > 0) THEN
32121 CALL mpi_isend(msgin(1), msglen, mpi_complex, dest, my_tag, &
32122 comm%handle, send_request%handle, ierr)
32123 ELSE
32124 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32125 comm%handle, send_request%handle, ierr)
32126 END IF
32127 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32128
32129 msglen = (msglen + SIZE(msgout, 1) + 1)/2
32130 CALL add_perf(perf_id=8, count=1, msg_size=msglen*(2*real_4_size))
32131#else
32132 mark_used(dest)
32133 mark_used(source)
32134 mark_used(comm)
32135 mark_used(tag)
32136 send_request = mp_request_null
32137 recv_request = mp_request_null
32138 msgout = msgin
32139#endif
32140 CALL mp_timestop(handle)
32141 END SUBROUTINE mp_isendrecv_cv
32142
32143! **************************************************************************************************
32144!> \brief Non-blocking send of vector data
32145!> \param msgin ...
32146!> \param dest ...
32147!> \param comm ...
32148!> \param request ...
32149!> \param tag ...
32150!> \par History
32151!> 08.2003 created [f&j]
32152!> \note see mp_isendrecv_cv
32153!> \note
32154!> arrays can be pointers or assumed shape, but they must be contiguous!
32155! **************************************************************************************************
32156 SUBROUTINE mp_isend_cv(msgin, dest, comm, request, tag)
32157 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
32158 INTEGER, INTENT(IN) :: dest
32159 CLASS(mp_comm_type), INTENT(IN) :: comm
32160 TYPE(mp_request_type), INTENT(out) :: request
32161 INTEGER, INTENT(in), OPTIONAL :: tag
32162
32163 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cv'
32164
32165 INTEGER :: handle, ierr
32166#if defined(__parallel)
32167 INTEGER :: msglen, my_tag
32168 COMPLEX(kind=real_4) :: foo(1)
32169#endif
32170
32171 CALL mp_timeset(routinen, handle)
32172
32173#if defined(__parallel)
32174#if !defined(__GNUC__) || __GNUC__ >= 9
32175 cpassert(is_contiguous(msgin))
32176#endif
32177 my_tag = 0
32178 IF (PRESENT(tag)) my_tag = tag
32179
32180 msglen = SIZE(msgin)
32181 IF (msglen > 0) THEN
32182 CALL mpi_isend(msgin(1), msglen, mpi_complex, dest, my_tag, &
32183 comm%handle, request%handle, ierr)
32184 ELSE
32185 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32186 comm%handle, request%handle, ierr)
32187 END IF
32188 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32189
32190 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32191#else
32192 mark_used(msgin)
32193 mark_used(dest)
32194 mark_used(comm)
32195 mark_used(request)
32196 mark_used(tag)
32197 ierr = 1
32198 request = mp_request_null
32199 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32200#endif
32201 CALL mp_timestop(handle)
32202 END SUBROUTINE mp_isend_cv
32203
32204! **************************************************************************************************
32205!> \brief Non-blocking send of matrix data
32206!> \param msgin ...
32207!> \param dest ...
32208!> \param comm ...
32209!> \param request ...
32210!> \param tag ...
32211!> \par History
32212!> 2009-11-25 [UB] Made type-generic for templates
32213!> \author fawzi
32214!> \note see mp_isendrecv_cv
32215!> \note see mp_isend_cv
32216!> \note
32217!> arrays can be pointers or assumed shape, but they must be contiguous!
32218! **************************************************************************************************
32219 SUBROUTINE mp_isend_cm2(msgin, dest, comm, request, tag)
32220 COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(IN) :: msgin
32221 INTEGER, INTENT(IN) :: dest
32222 CLASS(mp_comm_type), INTENT(IN) :: comm
32223 TYPE(mp_request_type), INTENT(out) :: request
32224 INTEGER, INTENT(in), OPTIONAL :: tag
32225
32226 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm2'
32227
32228 INTEGER :: handle, ierr
32229#if defined(__parallel)
32230 INTEGER :: msglen, my_tag
32231 COMPLEX(kind=real_4) :: foo(1)
32232#endif
32233
32234 CALL mp_timeset(routinen, handle)
32235
32236#if defined(__parallel)
32237#if !defined(__GNUC__) || __GNUC__ >= 9
32238 cpassert(is_contiguous(msgin))
32239#endif
32240
32241 my_tag = 0
32242 IF (PRESENT(tag)) my_tag = tag
32243
32244 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
32245 IF (msglen > 0) THEN
32246 CALL mpi_isend(msgin(1, 1), msglen, mpi_complex, dest, my_tag, &
32247 comm%handle, request%handle, ierr)
32248 ELSE
32249 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32250 comm%handle, request%handle, ierr)
32251 END IF
32252 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32253
32254 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32255#else
32256 mark_used(msgin)
32257 mark_used(dest)
32258 mark_used(comm)
32259 mark_used(request)
32260 mark_used(tag)
32261 ierr = 1
32262 request = mp_request_null
32263 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32264#endif
32265 CALL mp_timestop(handle)
32266 END SUBROUTINE mp_isend_cm2
32267
32268! **************************************************************************************************
32269!> \brief Non-blocking send of rank-3 data
32270!> \param msgin ...
32271!> \param dest ...
32272!> \param comm ...
32273!> \param request ...
32274!> \param tag ...
32275!> \par History
32276!> 9.2008 added _rm3 subroutine [Iain Bethune]
32277!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
32278!> 2009-11-25 [UB] Made type-generic for templates
32279!> \author fawzi
32280!> \note see mp_isendrecv_cv
32281!> \note see mp_isend_cv
32282!> \note
32283!> arrays can be pointers or assumed shape, but they must be contiguous!
32284! **************************************************************************************************
32285 SUBROUTINE mp_isend_cm3(msgin, dest, comm, request, tag)
32286 COMPLEX(kind=real_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
32287 INTEGER, INTENT(IN) :: dest
32288 CLASS(mp_comm_type), INTENT(IN) :: comm
32289 TYPE(mp_request_type), INTENT(out) :: request
32290 INTEGER, INTENT(in), OPTIONAL :: tag
32291
32292 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm3'
32293
32294 INTEGER :: handle, ierr
32295#if defined(__parallel)
32296 INTEGER :: msglen, my_tag
32297 COMPLEX(kind=real_4) :: foo(1)
32298#endif
32299
32300 CALL mp_timeset(routinen, handle)
32301
32302#if defined(__parallel)
32303#if !defined(__GNUC__) || __GNUC__ >= 9
32304 cpassert(is_contiguous(msgin))
32305#endif
32306
32307 my_tag = 0
32308 IF (PRESENT(tag)) my_tag = tag
32309
32310 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
32311 IF (msglen > 0) THEN
32312 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_complex, dest, my_tag, &
32313 comm%handle, request%handle, ierr)
32314 ELSE
32315 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32316 comm%handle, request%handle, ierr)
32317 END IF
32318 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32319
32320 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32321#else
32322 mark_used(msgin)
32323 mark_used(dest)
32324 mark_used(comm)
32325 mark_used(request)
32326 mark_used(tag)
32327 ierr = 1
32328 request = mp_request_null
32329 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32330#endif
32331 CALL mp_timestop(handle)
32332 END SUBROUTINE mp_isend_cm3
32333
32334! **************************************************************************************************
32335!> \brief Non-blocking send of rank-4 data
32336!> \param msgin the input message
32337!> \param dest the destination processor
32338!> \param comm the communicator object
32339!> \param request the communication request id
32340!> \param tag the message tag
32341!> \par History
32342!> 2.2016 added _cm4 subroutine [Nico Holmberg]
32343!> \author fawzi
32344!> \note see mp_isend_cv
32345!> \note
32346!> arrays can be pointers or assumed shape, but they must be contiguous!
32347! **************************************************************************************************
32348 SUBROUTINE mp_isend_cm4(msgin, dest, comm, request, tag)
32349 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
32350 INTEGER, INTENT(IN) :: dest
32351 CLASS(mp_comm_type), INTENT(IN) :: comm
32352 TYPE(mp_request_type), INTENT(out) :: request
32353 INTEGER, INTENT(in), OPTIONAL :: tag
32354
32355 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm4'
32356
32357 INTEGER :: handle, ierr
32358#if defined(__parallel)
32359 INTEGER :: msglen, my_tag
32360 COMPLEX(kind=real_4) :: foo(1)
32361#endif
32362
32363 CALL mp_timeset(routinen, handle)
32364
32365#if defined(__parallel)
32366#if !defined(__GNUC__) || __GNUC__ >= 9
32367 cpassert(is_contiguous(msgin))
32368#endif
32369
32370 my_tag = 0
32371 IF (PRESENT(tag)) my_tag = tag
32372
32373 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
32374 IF (msglen > 0) THEN
32375 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_complex, dest, my_tag, &
32376 comm%handle, request%handle, ierr)
32377 ELSE
32378 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32379 comm%handle, request%handle, ierr)
32380 END IF
32381 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32382
32383 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32384#else
32385 mark_used(msgin)
32386 mark_used(dest)
32387 mark_used(comm)
32388 mark_used(request)
32389 mark_used(tag)
32390 ierr = 1
32391 request = mp_request_null
32392 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32393#endif
32394 CALL mp_timestop(handle)
32395 END SUBROUTINE mp_isend_cm4
32396
32397! **************************************************************************************************
32398!> \brief Non-blocking receive of vector data
32399!> \param msgout ...
32400!> \param source ...
32401!> \param comm ...
32402!> \param request ...
32403!> \param tag ...
32404!> \par History
32405!> 08.2003 created [f&j]
32406!> 2009-11-25 [UB] Made type-generic for templates
32407!> \note see mp_isendrecv_cv
32408!> \note
32409!> arrays can be pointers or assumed shape, but they must be contiguous!
32410! **************************************************************************************************
32411 SUBROUTINE mp_irecv_cv(msgout, source, comm, request, tag)
32412 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
32413 INTEGER, INTENT(IN) :: source
32414 CLASS(mp_comm_type), INTENT(IN) :: comm
32415 TYPE(mp_request_type), INTENT(out) :: request
32416 INTEGER, INTENT(in), OPTIONAL :: tag
32417
32418 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cv'
32419
32420 INTEGER :: handle
32421#if defined(__parallel)
32422 INTEGER :: ierr, msglen, my_tag
32423 COMPLEX(kind=real_4) :: foo(1)
32424#endif
32425
32426 CALL mp_timeset(routinen, handle)
32427
32428#if defined(__parallel)
32429#if !defined(__GNUC__) || __GNUC__ >= 9
32430 cpassert(is_contiguous(msgout))
32431#endif
32432
32433 my_tag = 0
32434 IF (PRESENT(tag)) my_tag = tag
32435
32436 msglen = SIZE(msgout)
32437 IF (msglen > 0) THEN
32438 CALL mpi_irecv(msgout(1), msglen, mpi_complex, source, my_tag, &
32439 comm%handle, request%handle, ierr)
32440 ELSE
32441 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32442 comm%handle, request%handle, ierr)
32443 END IF
32444 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32445
32446 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32447#else
32448 cpabort("mp_irecv called in non parallel case")
32449 mark_used(msgout)
32450 mark_used(source)
32451 mark_used(comm)
32452 mark_used(tag)
32453 request = mp_request_null
32454#endif
32455 CALL mp_timestop(handle)
32456 END SUBROUTINE mp_irecv_cv
32457
32458! **************************************************************************************************
32459!> \brief Non-blocking receive of matrix data
32460!> \param msgout ...
32461!> \param source ...
32462!> \param comm ...
32463!> \param request ...
32464!> \param tag ...
32465!> \par History
32466!> 2009-11-25 [UB] Made type-generic for templates
32467!> \author fawzi
32468!> \note see mp_isendrecv_cv
32469!> \note see mp_irecv_cv
32470!> \note
32471!> arrays can be pointers or assumed shape, but they must be contiguous!
32472! **************************************************************************************************
32473 SUBROUTINE mp_irecv_cm2(msgout, source, comm, request, tag)
32474 COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
32475 INTEGER, INTENT(IN) :: source
32476 CLASS(mp_comm_type), INTENT(IN) :: comm
32477 TYPE(mp_request_type), INTENT(out) :: request
32478 INTEGER, INTENT(in), OPTIONAL :: tag
32479
32480 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm2'
32481
32482 INTEGER :: handle
32483#if defined(__parallel)
32484 INTEGER :: ierr, msglen, my_tag
32485 COMPLEX(kind=real_4) :: foo(1)
32486#endif
32487
32488 CALL mp_timeset(routinen, handle)
32489
32490#if defined(__parallel)
32491#if !defined(__GNUC__) || __GNUC__ >= 9
32492 cpassert(is_contiguous(msgout))
32493#endif
32494
32495 my_tag = 0
32496 IF (PRESENT(tag)) my_tag = tag
32497
32498 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
32499 IF (msglen > 0) THEN
32500 CALL mpi_irecv(msgout(1, 1), msglen, mpi_complex, source, my_tag, &
32501 comm%handle, request%handle, ierr)
32502 ELSE
32503 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32504 comm%handle, request%handle, ierr)
32505 END IF
32506 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32507
32508 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32509#else
32510 mark_used(msgout)
32511 mark_used(source)
32512 mark_used(comm)
32513 mark_used(tag)
32514 request = mp_request_null
32515 cpabort("mp_irecv called in non parallel case")
32516#endif
32517 CALL mp_timestop(handle)
32518 END SUBROUTINE mp_irecv_cm2
32519
32520! **************************************************************************************************
32521!> \brief Non-blocking send of rank-3 data
32522!> \param msgout ...
32523!> \param source ...
32524!> \param comm ...
32525!> \param request ...
32526!> \param tag ...
32527!> \par History
32528!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
32529!> 2009-11-25 [UB] Made type-generic for templates
32530!> \author fawzi
32531!> \note see mp_isendrecv_cv
32532!> \note see mp_irecv_cv
32533!> \note
32534!> arrays can be pointers or assumed shape, but they must be contiguous!
32535! **************************************************************************************************
32536 SUBROUTINE mp_irecv_cm3(msgout, source, comm, request, tag)
32537 COMPLEX(kind=real_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
32538 INTEGER, INTENT(IN) :: source
32539 CLASS(mp_comm_type), INTENT(IN) :: comm
32540 TYPE(mp_request_type), INTENT(out) :: request
32541 INTEGER, INTENT(in), OPTIONAL :: tag
32542
32543 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm3'
32544
32545 INTEGER :: handle
32546#if defined(__parallel)
32547 INTEGER :: ierr, msglen, my_tag
32548 COMPLEX(kind=real_4) :: foo(1)
32549#endif
32550
32551 CALL mp_timeset(routinen, handle)
32552
32553#if defined(__parallel)
32554#if !defined(__GNUC__) || __GNUC__ >= 9
32555 cpassert(is_contiguous(msgout))
32556#endif
32557
32558 my_tag = 0
32559 IF (PRESENT(tag)) my_tag = tag
32560
32561 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
32562 IF (msglen > 0) THEN
32563 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_complex, source, my_tag, &
32564 comm%handle, request%handle, ierr)
32565 ELSE
32566 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32567 comm%handle, request%handle, ierr)
32568 END IF
32569 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
32570
32571 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32572#else
32573 mark_used(msgout)
32574 mark_used(source)
32575 mark_used(comm)
32576 mark_used(tag)
32577 request = mp_request_null
32578 cpabort("mp_irecv called in non parallel case")
32579#endif
32580 CALL mp_timestop(handle)
32581 END SUBROUTINE mp_irecv_cm3
32582
32583! **************************************************************************************************
32584!> \brief Non-blocking receive of rank-4 data
32585!> \param msgout the output message
32586!> \param source the source processor
32587!> \param comm the communicator object
32588!> \param request the communication request id
32589!> \param tag the message tag
32590!> \par History
32591!> 2.2016 added _cm4 subroutine [Nico Holmberg]
32592!> \author fawzi
32593!> \note see mp_irecv_cv
32594!> \note
32595!> arrays can be pointers or assumed shape, but they must be contiguous!
32596! **************************************************************************************************
32597 SUBROUTINE mp_irecv_cm4(msgout, source, comm, request, tag)
32598 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
32599 INTEGER, INTENT(IN) :: source
32600 CLASS(mp_comm_type), INTENT(IN) :: comm
32601 TYPE(mp_request_type), INTENT(out) :: request
32602 INTEGER, INTENT(in), OPTIONAL :: tag
32603
32604 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm4'
32605
32606 INTEGER :: handle
32607#if defined(__parallel)
32608 INTEGER :: ierr, msglen, my_tag
32609 COMPLEX(kind=real_4) :: foo(1)
32610#endif
32611
32612 CALL mp_timeset(routinen, handle)
32613
32614#if defined(__parallel)
32615#if !defined(__GNUC__) || __GNUC__ >= 9
32616 cpassert(is_contiguous(msgout))
32617#endif
32618
32619 my_tag = 0
32620 IF (PRESENT(tag)) my_tag = tag
32621
32622 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
32623 IF (msglen > 0) THEN
32624 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_complex, source, my_tag, &
32625 comm%handle, request%handle, ierr)
32626 ELSE
32627 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32628 comm%handle, request%handle, ierr)
32629 END IF
32630 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
32631
32632 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32633#else
32634 mark_used(msgout)
32635 mark_used(source)
32636 mark_used(comm)
32637 mark_used(tag)
32638 request = mp_request_null
32639 cpabort("mp_irecv called in non parallel case")
32640#endif
32641 CALL mp_timestop(handle)
32642 END SUBROUTINE mp_irecv_cm4
32643
32644! **************************************************************************************************
32645!> \brief Window initialization function for vector data
32646!> \param base ...
32647!> \param comm ...
32648!> \param win ...
32649!> \par History
32650!> 02.2015 created [Alfio Lazzaro]
32651!> \note
32652!> arrays can be pointers or assumed shape, but they must be contiguous!
32653! **************************************************************************************************
32654 SUBROUTINE mp_win_create_cv(base, comm, win)
32655 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
32656 TYPE(mp_comm_type), INTENT(IN) :: comm
32657 CLASS(mp_win_type), INTENT(INOUT) :: win
32658
32659 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_cv'
32660
32661 INTEGER :: handle
32662#if defined(__parallel)
32663 INTEGER :: ierr
32664 INTEGER(kind=mpi_address_kind) :: len
32665 COMPLEX(kind=real_4) :: foo(1)
32666#endif
32667
32668 CALL mp_timeset(routinen, handle)
32669
32670#if defined(__parallel)
32671
32672 len = SIZE(base)*(2*real_4_size)
32673 IF (len > 0) THEN
32674 CALL mpi_win_create(base(1), len, (2*real_4_size), mpi_info_null, comm%handle, win%handle, ierr)
32675 ELSE
32676 CALL mpi_win_create(foo, len, (2*real_4_size), mpi_info_null, comm%handle, win%handle, ierr)
32677 END IF
32678 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
32679
32680 CALL add_perf(perf_id=20, count=1)
32681#else
32682 mark_used(base)
32683 mark_used(comm)
32684 win%handle = mp_win_null_handle
32685#endif
32686 CALL mp_timestop(handle)
32687 END SUBROUTINE mp_win_create_cv
32688
32689! **************************************************************************************************
32690!> \brief Single-sided get function for vector data
32691!> \param base ...
32692!> \param comm ...
32693!> \param win ...
32694!> \par History
32695!> 02.2015 created [Alfio Lazzaro]
32696!> \note
32697!> arrays can be pointers or assumed shape, but they must be contiguous!
32698! **************************************************************************************************
32699 SUBROUTINE mp_rget_cv(base, source, win, win_data, myproc, disp, request, &
32700 origin_datatype, target_datatype)
32701 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
32702 INTEGER, INTENT(IN) :: source
32703 CLASS(mp_win_type), INTENT(IN) :: win
32704 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: win_data
32705 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
32706 TYPE(mp_request_type), INTENT(OUT) :: request
32707 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
32708
32709 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_cv'
32710
32711 INTEGER :: handle
32712#if defined(__parallel)
32713 INTEGER :: ierr, len, &
32714 origin_len, target_len
32715 LOGICAL :: do_local_copy
32716 INTEGER(kind=mpi_address_kind) :: disp_aint
32717 mpi_data_type :: handle_origin_datatype, handle_target_datatype
32718#endif
32719
32720 CALL mp_timeset(routinen, handle)
32721
32722#if defined(__parallel)
32723 len = SIZE(base)
32724 disp_aint = 0
32725 IF (PRESENT(disp)) THEN
32726 disp_aint = int(disp, kind=mpi_address_kind)
32727 END IF
32728 handle_origin_datatype = mpi_complex
32729 origin_len = len
32730 IF (PRESENT(origin_datatype)) THEN
32731 handle_origin_datatype = origin_datatype%type_handle
32732 origin_len = 1
32733 END IF
32734 handle_target_datatype = mpi_complex
32735 target_len = len
32736 IF (PRESENT(target_datatype)) THEN
32737 handle_target_datatype = target_datatype%type_handle
32738 target_len = 1
32739 END IF
32740 IF (len > 0) THEN
32741 do_local_copy = .false.
32742 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
32743 IF (myproc .EQ. source) do_local_copy = .true.
32744 END IF
32745 IF (do_local_copy) THEN
32746 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
32747 base(:) = win_data(disp_aint + 1:disp_aint + len)
32748 !$OMP END PARALLEL WORKSHARE
32749 request = mp_request_null
32750 ierr = 0
32751 ELSE
32752 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
32753 target_len, handle_target_datatype, win%handle, request%handle, ierr)
32754 END IF
32755 ELSE
32756 request = mp_request_null
32757 ierr = 0
32758 END IF
32759 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
32760
32761 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*(2*real_4_size))
32762#else
32763 mark_used(source)
32764 mark_used(win)
32765 mark_used(myproc)
32766 mark_used(origin_datatype)
32767 mark_used(target_datatype)
32768
32769 request = mp_request_null
32770 !
32771 IF (PRESENT(disp)) THEN
32772 base(:) = win_data(disp + 1:disp + SIZE(base))
32773 ELSE
32774 base(:) = win_data(:SIZE(base))
32775 END IF
32776
32777#endif
32778 CALL mp_timestop(handle)
32779 END SUBROUTINE mp_rget_cv
32780
32781! **************************************************************************************************
32782!> \brief ...
32783!> \param count ...
32784!> \param lengths ...
32785!> \param displs ...
32786!> \return ...
32787! ***************************************************************************
32788 FUNCTION mp_type_indexed_make_c (count, lengths, displs) &
32789 result(type_descriptor)
32790 INTEGER, INTENT(IN) :: count
32791 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
32792 TYPE(mp_type_descriptor_type) :: type_descriptor
32793
32794 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_c'
32795
32796 INTEGER :: handle
32797#if defined(__parallel)
32798 INTEGER :: ierr
32799#endif
32800
32801 CALL mp_timeset(routinen, handle)
32802
32803#if defined(__parallel)
32804 CALL mpi_type_indexed(count, lengths, displs, mpi_complex, &
32805 type_descriptor%type_handle, ierr)
32806 IF (ierr /= 0) &
32807 cpabort("MPI_Type_Indexed @ "//routinen)
32808 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
32809 IF (ierr /= 0) &
32810 cpabort("MPI_Type_commit @ "//routinen)
32811#else
32812 type_descriptor%type_handle = 5
32813#endif
32814 type_descriptor%length = count
32815 NULLIFY (type_descriptor%subtype)
32816 type_descriptor%vector_descriptor(1:2) = 1
32817 type_descriptor%has_indexing = .true.
32818 type_descriptor%index_descriptor%index => lengths
32819 type_descriptor%index_descriptor%chunks => displs
32820
32821 CALL mp_timestop(handle)
32822
32823 END FUNCTION mp_type_indexed_make_c
32824
32825! **************************************************************************************************
32826!> \brief Allocates special parallel memory
32827!> \param[in] DATA pointer to integer array to allocate
32828!> \param[in] len number of integers to allocate
32829!> \param[out] stat (optional) allocation status result
32830!> \author UB
32831! **************************************************************************************************
32832 SUBROUTINE mp_allocate_c (DATA, len, stat)
32833 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
32834 INTEGER, INTENT(IN) :: len
32835 INTEGER, INTENT(OUT), OPTIONAL :: stat
32836
32837 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_c'
32838
32839 INTEGER :: handle, ierr
32840
32841 CALL mp_timeset(routinen, handle)
32842
32843#if defined(__parallel)
32844 NULLIFY (data)
32845 CALL mp_alloc_mem(DATA, len, stat=ierr)
32846 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
32847 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
32848 CALL add_perf(perf_id=15, count=1)
32849#else
32850 ALLOCATE (DATA(len), stat=ierr)
32851 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
32852 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
32853#endif
32854 IF (PRESENT(stat)) stat = ierr
32855 CALL mp_timestop(handle)
32856 END SUBROUTINE mp_allocate_c
32857
32858! **************************************************************************************************
32859!> \brief Deallocates special parallel memory
32860!> \param[in] DATA pointer to special memory to deallocate
32861!> \param stat ...
32862!> \author UB
32863! **************************************************************************************************
32864 SUBROUTINE mp_deallocate_c (DATA, stat)
32865 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
32866 INTEGER, INTENT(OUT), OPTIONAL :: stat
32867
32868 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_c'
32869
32870 INTEGER :: handle
32871#if defined(__parallel)
32872 INTEGER :: ierr
32873#endif
32874
32875 CALL mp_timeset(routinen, handle)
32876
32877#if defined(__parallel)
32878 CALL mp_free_mem(DATA, ierr)
32879 IF (PRESENT(stat)) THEN
32880 stat = ierr
32881 ELSE
32882 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
32883 END IF
32884 NULLIFY (data)
32885 CALL add_perf(perf_id=15, count=1)
32886#else
32887 DEALLOCATE (data)
32888 IF (PRESENT(stat)) stat = 0
32889#endif
32890 CALL mp_timestop(handle)
32891 END SUBROUTINE mp_deallocate_c
32892
32893! **************************************************************************************************
32894!> \brief (parallel) Blocking individual file write using explicit offsets
32895!> (serial) Unformatted stream write
32896!> \param[in] fh file handle (file storage unit)
32897!> \param[in] offset file offset (position)
32898!> \param[in] msg data to be written to the file
32899!> \param msglen ...
32900!> \par MPI-I/O mapping mpi_file_write_at
32901!> \par STREAM-I/O mapping WRITE
32902!> \param[in](optional) msglen number of the elements of data
32903! **************************************************************************************************
32904 SUBROUTINE mp_file_write_at_cv(fh, offset, msg, msglen)
32905 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
32906 CLASS(mp_file_type), INTENT(IN) :: fh
32907 INTEGER, INTENT(IN), OPTIONAL :: msglen
32908 INTEGER(kind=file_offset), INTENT(IN) :: offset
32909
32910 INTEGER :: msg_len
32911#if defined(__parallel)
32912 INTEGER :: ierr
32913#endif
32914
32915 msg_len = SIZE(msg)
32916 IF (PRESENT(msglen)) msg_len = msglen
32917#if defined(__parallel)
32918 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
32919 IF (ierr .NE. 0) &
32920 cpabort("mpi_file_write_at_cv @ mp_file_write_at_cv")
32921#else
32922 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
32923#endif
32924 END SUBROUTINE mp_file_write_at_cv
32925
32926! **************************************************************************************************
32927!> \brief ...
32928!> \param fh ...
32929!> \param offset ...
32930!> \param msg ...
32931! **************************************************************************************************
32932 SUBROUTINE mp_file_write_at_c (fh, offset, msg)
32933 COMPLEX(kind=real_4), INTENT(IN) :: msg
32934 CLASS(mp_file_type), INTENT(IN) :: fh
32935 INTEGER(kind=file_offset), INTENT(IN) :: offset
32936
32937#if defined(__parallel)
32938 INTEGER :: ierr
32939
32940 ierr = 0
32941 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
32942 IF (ierr .NE. 0) &
32943 cpabort("mpi_file_write_at_c @ mp_file_write_at_c")
32944#else
32945 WRITE (unit=fh%handle, pos=offset + 1) msg
32946#endif
32947 END SUBROUTINE mp_file_write_at_c
32948
32949! **************************************************************************************************
32950!> \brief (parallel) Blocking collective file write using explicit offsets
32951!> (serial) Unformatted stream write
32952!> \param fh ...
32953!> \param offset ...
32954!> \param msg ...
32955!> \param msglen ...
32956!> \par MPI-I/O mapping mpi_file_write_at_all
32957!> \par STREAM-I/O mapping WRITE
32958! **************************************************************************************************
32959 SUBROUTINE mp_file_write_at_all_cv(fh, offset, msg, msglen)
32960 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
32961 CLASS(mp_file_type), INTENT(IN) :: fh
32962 INTEGER, INTENT(IN), OPTIONAL :: msglen
32963 INTEGER(kind=file_offset), INTENT(IN) :: offset
32964
32965 INTEGER :: msg_len
32966#if defined(__parallel)
32967 INTEGER :: ierr
32968#endif
32969
32970 msg_len = SIZE(msg)
32971 IF (PRESENT(msglen)) msg_len = msglen
32972#if defined(__parallel)
32973 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
32974 IF (ierr .NE. 0) &
32975 cpabort("mpi_file_write_at_all_cv @ mp_file_write_at_all_cv")
32976#else
32977 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
32978#endif
32979 END SUBROUTINE mp_file_write_at_all_cv
32980
32981! **************************************************************************************************
32982!> \brief ...
32983!> \param fh ...
32984!> \param offset ...
32985!> \param msg ...
32986! **************************************************************************************************
32987 SUBROUTINE mp_file_write_at_all_c (fh, offset, msg)
32988 COMPLEX(kind=real_4), INTENT(IN) :: msg
32989 CLASS(mp_file_type), INTENT(IN) :: fh
32990 INTEGER(kind=file_offset), INTENT(IN) :: offset
32991
32992#if defined(__parallel)
32993 INTEGER :: ierr
32994
32995 ierr = 0
32996 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
32997 IF (ierr .NE. 0) &
32998 cpabort("mpi_file_write_at_all_c @ mp_file_write_at_all_c")
32999#else
33000 WRITE (unit=fh%handle, pos=offset + 1) msg
33001#endif
33002 END SUBROUTINE mp_file_write_at_all_c
33003
33004! **************************************************************************************************
33005!> \brief (parallel) Blocking individual file read using explicit offsets
33006!> (serial) Unformatted stream read
33007!> \param[in] fh file handle (file storage unit)
33008!> \param[in] offset file offset (position)
33009!> \param[out] msg data to be read from the file
33010!> \param msglen ...
33011!> \par MPI-I/O mapping mpi_file_read_at
33012!> \par STREAM-I/O mapping READ
33013!> \param[in](optional) msglen number of elements of data
33014! **************************************************************************************************
33015 SUBROUTINE mp_file_read_at_cv(fh, offset, msg, msglen)
33016 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
33017 CLASS(mp_file_type), INTENT(IN) :: fh
33018 INTEGER, INTENT(IN), OPTIONAL :: msglen
33019 INTEGER(kind=file_offset), INTENT(IN) :: offset
33020
33021 INTEGER :: msg_len
33022#if defined(__parallel)
33023 INTEGER :: ierr
33024#endif
33025
33026 msg_len = SIZE(msg)
33027 IF (PRESENT(msglen)) msg_len = msglen
33028#if defined(__parallel)
33029 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33030 IF (ierr .NE. 0) &
33031 cpabort("mpi_file_read_at_cv @ mp_file_read_at_cv")
33032#else
33033 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33034#endif
33035 END SUBROUTINE mp_file_read_at_cv
33036
33037! **************************************************************************************************
33038!> \brief ...
33039!> \param fh ...
33040!> \param offset ...
33041!> \param msg ...
33042! **************************************************************************************************
33043 SUBROUTINE mp_file_read_at_c (fh, offset, msg)
33044 COMPLEX(kind=real_4), INTENT(OUT) :: msg
33045 CLASS(mp_file_type), INTENT(IN) :: fh
33046 INTEGER(kind=file_offset), INTENT(IN) :: offset
33047
33048#if defined(__parallel)
33049 INTEGER :: ierr
33050
33051 ierr = 0
33052 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33053 IF (ierr .NE. 0) &
33054 cpabort("mpi_file_read_at_c @ mp_file_read_at_c")
33055#else
33056 READ (unit=fh%handle, pos=offset + 1) msg
33057#endif
33058 END SUBROUTINE mp_file_read_at_c
33059
33060! **************************************************************************************************
33061!> \brief (parallel) Blocking collective file read using explicit offsets
33062!> (serial) Unformatted stream read
33063!> \param fh ...
33064!> \param offset ...
33065!> \param msg ...
33066!> \param msglen ...
33067!> \par MPI-I/O mapping mpi_file_read_at_all
33068!> \par STREAM-I/O mapping READ
33069! **************************************************************************************************
33070 SUBROUTINE mp_file_read_at_all_cv(fh, offset, msg, msglen)
33071 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
33072 CLASS(mp_file_type), INTENT(IN) :: fh
33073 INTEGER, INTENT(IN), OPTIONAL :: msglen
33074 INTEGER(kind=file_offset), INTENT(IN) :: offset
33075
33076 INTEGER :: msg_len
33077#if defined(__parallel)
33078 INTEGER :: ierr
33079#endif
33080
33081 msg_len = SIZE(msg)
33082 IF (PRESENT(msglen)) msg_len = msglen
33083#if defined(__parallel)
33084 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33085 IF (ierr .NE. 0) &
33086 cpabort("mpi_file_read_at_all_cv @ mp_file_read_at_all_cv")
33087#else
33088 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33089#endif
33090 END SUBROUTINE mp_file_read_at_all_cv
33091
33092! **************************************************************************************************
33093!> \brief ...
33094!> \param fh ...
33095!> \param offset ...
33096!> \param msg ...
33097! **************************************************************************************************
33098 SUBROUTINE mp_file_read_at_all_c (fh, offset, msg)
33099 COMPLEX(kind=real_4), INTENT(OUT) :: msg
33100 CLASS(mp_file_type), INTENT(IN) :: fh
33101 INTEGER(kind=file_offset), INTENT(IN) :: offset
33102
33103#if defined(__parallel)
33104 INTEGER :: ierr
33105
33106 ierr = 0
33107 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33108 IF (ierr .NE. 0) &
33109 cpabort("mpi_file_read_at_all_c @ mp_file_read_at_all_c")
33110#else
33111 READ (unit=fh%handle, pos=offset + 1) msg
33112#endif
33113 END SUBROUTINE mp_file_read_at_all_c
33114
33115! **************************************************************************************************
33116!> \brief ...
33117!> \param ptr ...
33118!> \param vector_descriptor ...
33119!> \param index_descriptor ...
33120!> \return ...
33121! **************************************************************************************************
33122 FUNCTION mp_type_make_c (ptr, &
33123 vector_descriptor, index_descriptor) &
33124 result(type_descriptor)
33125 COMPLEX(kind=real_4), DIMENSION(:), TARGET, asynchronous :: ptr
33126 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
33127 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
33128 TYPE(mp_type_descriptor_type) :: type_descriptor
33129
33130 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_c'
33131
33132#if defined(__parallel)
33133 INTEGER :: ierr
33134#endif
33135
33136 NULLIFY (type_descriptor%subtype)
33137 type_descriptor%length = SIZE(ptr)
33138#if defined(__parallel)
33139 type_descriptor%type_handle = mpi_complex
33140 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
33141 IF (ierr /= 0) &
33142 cpabort("MPI_Get_address @ "//routinen)
33143#else
33144 type_descriptor%type_handle = 5
33145#endif
33146 type_descriptor%vector_descriptor(1:2) = 1
33147 type_descriptor%has_indexing = .false.
33148 type_descriptor%data_c => ptr
33149 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
33150 cpabort(routinen//": Vectors and indices NYI")
33151 END IF
33152 END FUNCTION mp_type_make_c
33153
33154! **************************************************************************************************
33155!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
33156!> as the Fortran version returns an integer, which we take to be a C_PTR
33157!> \param DATA data array to allocate
33158!> \param[in] len length (in data elements) of data array allocation
33159!> \param[out] stat (optional) allocation status result
33160! **************************************************************************************************
33161 SUBROUTINE mp_alloc_mem_c (DATA, len, stat)
33162 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: data
33163 INTEGER, INTENT(IN) :: len
33164 INTEGER, INTENT(OUT), OPTIONAL :: stat
33165
33166#if defined(__parallel)
33167 INTEGER :: size, ierr, length, &
33168 mp_res
33169 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
33170 TYPE(c_ptr) :: mp_baseptr
33171 mpi_info_type :: mp_info
33172
33173 length = max(len, 1)
33174 CALL mpi_type_size(mpi_complex, size, ierr)
33175 mp_size = int(length, kind=mpi_address_kind)*size
33176 IF (mp_size .GT. mp_max_memory_size) THEN
33177 cpabort("MPI cannot allocate more than 2 GiByte")
33178 END IF
33179 mp_info = mpi_info_null
33180 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
33181 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
33182 IF (PRESENT(stat)) stat = mp_res
33183#else
33184 INTEGER :: length, mystat
33185 length = max(len, 1)
33186 IF (PRESENT(stat)) THEN
33187 ALLOCATE (DATA(length), stat=mystat)
33188 stat = mystat ! show to convention checker that stat is used
33189 ELSE
33190 ALLOCATE (DATA(length))
33191 END IF
33192#endif
33193 END SUBROUTINE mp_alloc_mem_c
33194
33195! **************************************************************************************************
33196!> \brief Deallocates am array, ... this is hackish
33197!> as the Fortran version takes an integer, which we hope to get by reference
33198!> \param DATA data array to allocate
33199!> \param[out] stat (optional) allocation status result
33200! **************************************************************************************************
33201 SUBROUTINE mp_free_mem_c (DATA, stat)
33202 COMPLEX(kind=real_4), DIMENSION(:), &
33203 POINTER, asynchronous :: data
33204 INTEGER, INTENT(OUT), OPTIONAL :: stat
33205
33206#if defined(__parallel)
33207 INTEGER :: mp_res
33208 CALL mpi_free_mem(DATA, mp_res)
33209 IF (PRESENT(stat)) stat = mp_res
33210#else
33211 DEALLOCATE (data)
33212 IF (PRESENT(stat)) stat = 0
33213#endif
33214 END SUBROUTINE mp_free_mem_c
33215
33216 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:890
message_passing::mp_deallocate
Definition message_passing.F:899
message_passing::mp_testall
Definition message_passing.F:874
message_passing::mp_testany
Definition message_passing.F:878
message_passing::mp_type_make
Definition message_passing.F:908
message_passing::mp_waitall
Definition message_passing.F:870
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:811
message_passing::mp_comm_unequal
integer, parameter, public mp_comm_unequal
Definition message_passing.F:829
message_passing::mp_collect_timings
logical, save, public mp_collect_timings
Definition message_passing.F:969
message_passing::mp_dims_create
subroutine, public mp_dims_create(nodes, dims)
wrapper to MPI_Dims_create
Definition message_passing.F:2131
message_passing::mp_para_env_create
subroutine, public mp_para_env_create(para_env, group)
creates a new para environment
Definition message_passing.F:2004
message_passing::intlen
integer, parameter intlen
Definition message_passing.F:964
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:4407
message_passing::mp_world_init
subroutine, public mp_world_init(mp_comm)
initializes the system default communicator
Definition message_passing.F:1273
message_passing::file_amode_rdwr
integer, parameter, public file_amode_rdwr
Definition message_passing.F:163
message_passing::mp_para_cart_create
subroutine, public mp_para_cart_create(cart, group)
creates a cart (multidimensional parallel environment)
Definition message_passing.F:2042
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:4596
message_passing::mp_any_tag
integer, parameter, public mp_any_tag
Definition message_passing.F:144
message_passing::file_amode_wronly
integer, parameter, public file_amode_wronly
Definition message_passing.F:162
message_passing::mpi_character_size
integer, parameter, public mpi_character_size
Definition message_passing.F:170
message_passing::mp_comm_ident
integer, parameter, public mp_comm_ident
Definition message_passing.F:826
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:28083
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:1418
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:23376
message_passing::mp_comm_world
type(mp_comm_type), parameter, public mp_comm_world
Definition message_passing.F:813
message_passing::file_amode_create
integer, parameter, public file_amode_create
Definition message_passing.F:160
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:2026
message_passing::mp_comm_self
type(mp_comm_type), parameter, public mp_comm_self
Definition message_passing.F:812
message_passing::mp_comm_congruent
integer, parameter, public mp_comm_congruent
Definition message_passing.F:827
message_passing::mp_para_cart_release
subroutine, public mp_para_cart_release(cart)
releases the given cart
Definition message_passing.F:2059
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:18669
message_passing::mp_comm_compare_default
integer, parameter, public mp_comm_compare_default
Definition message_passing.F:830
message_passing::mp_world_finalize
subroutine, public mp_world_finalize()
finalizes the system default communicator
Definition message_passing.F:1385
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:3911
message_passing::mp_comm_similar
integer, parameter, public mp_comm_similar
Definition message_passing.F:828
message_passing::mp_file_null
type(mp_file_type), parameter, public mp_file_null
Definition message_passing.F:816
message_passing::mp_any_source
integer, parameter, public mp_any_source
Definition message_passing.F:145
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:32790
message_passing::mp_info_null
type(mp_info_type), parameter, public mp_info_null
Definition message_passing.F:817
message_passing::mp_win_null
type(mp_win_type), parameter, public mp_win_null
Definition message_passing.F:815
message_passing::file_amode_append
integer, parameter, public file_amode_append
Definition message_passing.F:165
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:3820
message_passing::address_kind
integer, parameter, public address_kind
Definition message_passing.F:159
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:4642
message_passing::file_amode_rdonly
integer, parameter, public file_amode_rdonly
Definition message_passing.F:161
message_passing::mp_waitany
subroutine, public mp_waitany(requests, completed)
waits for completion of any of the given requests
Definition message_passing.F:2355
message_passing::file_amode_excl
integer, parameter, public file_amode_excl
Definition message_passing.F:164
message_passing::mp_request_null
type(mp_request_type), parameter, public mp_request_null
Definition message_passing.F:814
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:4450
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:4257
message_passing::mpi_integer_size
integer, parameter, public mpi_integer_size
Definition message_passing.F:171
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:740
message_passing::mp_comm_type
Definition message_passing.F:189
message_passing::mp_file_descriptor_type
Definition message_passing.F:956
message_passing::mp_file_type
Definition message_passing.F:669
message_passing::mp_info_type
Definition message_passing.F:728
message_passing::mp_para_cart_type
represent a multidimensional parallel environment
Definition message_passing.F:800
message_passing::mp_para_env_p_type
represent a pointer to a para env (to build arrays)
Definition message_passing.F:780
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:763
message_passing::mp_request_type
Definition message_passing.F:623
message_passing::mp_type_descriptor_type
Definition message_passing.F:932
message_passing::mp_win_type
Definition message_passing.F:639