(git:374b731)
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-2024 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(.EQ.) => mp_comm_op_eq
204 generic, PUBLIC :: operator(.NE.) => 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(.EQ.) => mp_request_op_eq
632 generic, PUBLIC :: OPERATOR(.NE.) => 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(.EQ.) => mp_win_op_eq
648 generic, PUBLIC :: OPERATOR(.NE.) => 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(.EQ.) => mp_file_op_eq
678 generic, PUBLIC :: OPERATOR(.NE.) => 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(.EQ.) => mp_info_op_eq
737 generic, PUBLIC :: OPERATOR(.NE.) => 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 PUBLIC :: mp_get_node_global_rank
840
841 ! message passing
842 PUBLIC :: mp_waitall, mp_waitany
843 PUBLIC :: mp_testall, mp_testany
844
845 ! Memory management
846 PUBLIC :: mp_allocate, mp_deallocate
847
848 ! I/O
849 PUBLIC :: mp_file_delete
850 PUBLIC :: mp_file_get_amode
851
852 ! some 'advanced types' currently only used for dbcsr
853 PUBLIC :: mp_type_descriptor_type
854 PUBLIC :: mp_type_make
855 PUBLIC :: mp_type_size
856
857 ! vector types
858 PUBLIC :: mp_type_indexed_make_r, mp_type_indexed_make_d, &
859 mp_type_indexed_make_c, mp_type_indexed_make_z
860
861 ! More I/O types and routines: variable spaced data using bytes for spacings
862 PUBLIC :: mp_file_descriptor_type
863 PUBLIC :: mp_file_type_free
864 PUBLIC :: mp_file_type_hindexed_make_chv
865 PUBLIC :: mp_file_type_set_view_chv
866
867 PUBLIC :: mp_get_library_version
868
869 ! assumed to be private
870
871 INTERFACE mp_waitall
872 MODULE PROCEDURE mp_waitall_1, mp_waitall_2
873 END INTERFACE
874
875 INTERFACE mp_testall
876 MODULE PROCEDURE mp_testall_tv
877 END INTERFACE
878
879 INTERFACE mp_testany
880 MODULE PROCEDURE mp_testany_1, mp_testany_2
881 END INTERFACE
882
883 INTERFACE mp_type_free
884 MODULE PROCEDURE mp_type_free_m, mp_type_free_v
885 END INTERFACE
886
887 !
888 ! interfaces to deal easily with scalars / vectors / matrices / ...
889 ! of the different types (integers, doubles, logicals, characters)
890 !
891 INTERFACE mp_allocate
892 MODULE PROCEDURE mp_allocate_i, &
893 mp_allocate_l, &
894 mp_allocate_r, &
895 mp_allocate_d, &
896 mp_allocate_c, &
897 mp_allocate_z
898 END INTERFACE
899
900 INTERFACE mp_deallocate
901 MODULE PROCEDURE mp_deallocate_i, &
902 mp_deallocate_l, &
903 mp_deallocate_r, &
904 mp_deallocate_d, &
905 mp_deallocate_c, &
906 mp_deallocate_z
907 END INTERFACE
908
909 INTERFACE mp_type_make
910 MODULE PROCEDURE mp_type_make_struct
911 MODULE PROCEDURE mp_type_make_i, mp_type_make_l, &
912 mp_type_make_r, mp_type_make_d, &
913 mp_type_make_c, mp_type_make_z
914 END INTERFACE
915
916 INTERFACE mp_alloc_mem
917 MODULE PROCEDURE mp_alloc_mem_i, mp_alloc_mem_l, &
918 mp_alloc_mem_d, mp_alloc_mem_z, &
919 mp_alloc_mem_r, mp_alloc_mem_c
920 END INTERFACE
921
922 INTERFACE mp_free_mem
923 MODULE PROCEDURE mp_free_mem_i, mp_free_mem_l, &
924 mp_free_mem_d, mp_free_mem_z, &
925 mp_free_mem_r, mp_free_mem_c
926 END INTERFACE
927
928! Type declarations
929 TYPE mp_indexing_meta_type
930 INTEGER, DIMENSION(:), POINTER :: index => null(), chunks => null()
931 END TYPE mp_indexing_meta_type
932
933 TYPE mp_type_descriptor_type
934 mpi_data_type :: type_handle = mp_datatype_null_handle
935 INTEGER :: length = -1
936#if defined(__parallel)
937 INTEGER(kind=mpi_address_kind) :: base = -1
938#endif
939 INTEGER(kind=int_4), DIMENSION(:), POINTER :: data_i => null()
940 INTEGER(kind=int_8), DIMENSION(:), POINTER :: data_l => null()
941 REAL(kind=real_4), DIMENSION(:), POINTER :: data_r => null()
942 REAL(kind=real_8), DIMENSION(:), POINTER :: data_d => null()
943 COMPLEX(kind=real_4), DIMENSION(:), POINTER :: data_c => null()
944 COMPLEX(kind=real_8), DIMENSION(:), POINTER :: data_z => null()
945 TYPE(mp_type_descriptor_type), DIMENSION(:), POINTER :: subtype => null()
946 INTEGER :: vector_descriptor(2) = -1
947 LOGICAL :: has_indexing = .false.
948 TYPE(mp_indexing_meta_type) :: index_descriptor = mp_indexing_meta_type()
949 END TYPE mp_type_descriptor_type
950
951 TYPE mp_file_indexing_meta_type
952 INTEGER, DIMENSION(:), POINTER :: index => null()
953 INTEGER(kind=file_offset), &
954 DIMENSION(:), POINTER :: chunks => null()
955 END TYPE mp_file_indexing_meta_type
956
957 TYPE mp_file_descriptor_type
958 mpi_data_type :: type_handle = mp_datatype_null_handle
959 INTEGER :: length = -1
960 LOGICAL :: has_indexing = .false.
961 TYPE(mp_file_indexing_meta_type) :: index_descriptor = mp_file_indexing_meta_type()
962 END TYPE
963
964 ! we make some assumptions on the length of INTEGERS, REALS and LOGICALS
965 INTEGER, PARAMETER :: intlen = bit_size(0)/8
966 INTEGER, PARAMETER :: reallen = 8
967 INTEGER, PARAMETER :: loglen = bit_size(0)/8
968 INTEGER, PARAMETER :: charlen = 1
969
970 LOGICAL, PUBLIC, SAVE :: mp_collect_timings = .false.
971
972CONTAINS
973
974 LOGICAL FUNCTION mp_comm_op_eq(comm1, comm2)
975 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
976#if defined(__parallel) && defined(__MPI_F08)
977 mp_comm_op_eq = (comm1%handle%mpi_val .EQ. comm2%handle%mpi_val)
978#else
979 mp_comm_op_eq = (comm1%handle .EQ. comm2%handle)
980#endif
981 END FUNCTION mp_comm_op_eq
982
983 LOGICAL FUNCTION mp_comm_op_neq(comm1, comm2)
984 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
985#if defined(__parallel) && defined(__MPI_F08)
986 mp_comm_op_neq = (comm1%handle%mpi_val .NE. comm2%handle%mpi_val)
987#else
988 mp_comm_op_neq = (comm1%handle .NE. comm2%handle)
989#endif
990 END FUNCTION mp_comm_op_neq
991
992 ELEMENTAL IMPURE SUBROUTINE mp_comm_type_set_handle(this, handle , ndims)
993 CLASS(mp_comm_type), INTENT(INOUT) :: this
994 INTEGER, INTENT(IN) :: handle
995 INTEGER, INTENT(IN), OPTIONAL :: ndims
996
997#if defined(__parallel) && defined(__MPI_F08)
998 this%handle%mpi_val = handle
999#else
1000 this%handle = handle
1001#endif
1002
1003 SELECT TYPE (this)
1004 CLASS IS (mp_cart_type)
1005 IF (.NOT. PRESENT(ndims)) &
1006 CALL cp_abort(__location__, &
1007 "Setup of a cartesian communicator requires information on the number of dimensions!")
1008 END SELECT
1009 IF (PRESENT(ndims)) this%ndims = ndims
1010 CALL this%init()
1011
1012 END SUBROUTINE mp_comm_type_set_handle
1013
1014 ELEMENTAL FUNCTION mp_comm_type_get_handle(this) RESULT(handle)
1015 CLASS(mp_comm_type), INTENT(IN) :: this
1016 INTEGER :: handle
1017
1018#if defined(__parallel) && defined(__MPI_F08)
1019 handle = this%handle%mpi_val
1020#else
1021 handle = this%handle
1022#endif
1023 END FUNCTION mp_comm_type_get_handle
1024 LOGICAL FUNCTION mp_request_op_eq(request1, request2)
1025 CLASS(mp_request_type), INTENT(IN) :: request1, request2
1026#if defined(__parallel) && defined(__MPI_F08)
1027 mp_request_op_eq = (request1%handle%mpi_val .EQ. request2%handle%mpi_val)
1028#else
1029 mp_request_op_eq = (request1%handle .EQ. request2%handle)
1030#endif
1031 END FUNCTION mp_request_op_eq
1032
1033 LOGICAL FUNCTION mp_request_op_neq(request1, request2)
1034 CLASS(mp_request_type), INTENT(IN) :: request1, request2
1035#if defined(__parallel) && defined(__MPI_F08)
1036 mp_request_op_neq = (request1%handle%mpi_val .NE. request2%handle%mpi_val)
1037#else
1038 mp_request_op_neq = (request1%handle .NE. request2%handle)
1039#endif
1040 END FUNCTION mp_request_op_neq
1041
1042 ELEMENTAL SUBROUTINE mp_request_type_set_handle(this, handle )
1043 CLASS(mp_request_type), INTENT(INOUT) :: this
1044 INTEGER, INTENT(IN) :: handle
1045
1046#if defined(__parallel) && defined(__MPI_F08)
1047 this%handle%mpi_val = handle
1048#else
1049 this%handle = handle
1050#endif
1051
1052
1053 END SUBROUTINE mp_request_type_set_handle
1054
1055 ELEMENTAL FUNCTION mp_request_type_get_handle(this) RESULT(handle)
1056 CLASS(mp_request_type), INTENT(IN) :: this
1057 INTEGER :: handle
1058
1059#if defined(__parallel) && defined(__MPI_F08)
1060 handle = this%handle%mpi_val
1061#else
1062 handle = this%handle
1063#endif
1064 END FUNCTION mp_request_type_get_handle
1065 LOGICAL FUNCTION mp_win_op_eq(win1, win2)
1066 CLASS(mp_win_type), INTENT(IN) :: win1, win2
1067#if defined(__parallel) && defined(__MPI_F08)
1068 mp_win_op_eq = (win1%handle%mpi_val .EQ. win2%handle%mpi_val)
1069#else
1070 mp_win_op_eq = (win1%handle .EQ. win2%handle)
1071#endif
1072 END FUNCTION mp_win_op_eq
1073
1074 LOGICAL FUNCTION mp_win_op_neq(win1, win2)
1075 CLASS(mp_win_type), INTENT(IN) :: win1, win2
1076#if defined(__parallel) && defined(__MPI_F08)
1077 mp_win_op_neq = (win1%handle%mpi_val .NE. win2%handle%mpi_val)
1078#else
1079 mp_win_op_neq = (win1%handle .NE. win2%handle)
1080#endif
1081 END FUNCTION mp_win_op_neq
1082
1083 ELEMENTAL SUBROUTINE mp_win_type_set_handle(this, handle )
1084 CLASS(mp_win_type), INTENT(INOUT) :: this
1085 INTEGER, INTENT(IN) :: handle
1086
1087#if defined(__parallel) && defined(__MPI_F08)
1088 this%handle%mpi_val = handle
1089#else
1090 this%handle = handle
1091#endif
1092
1093
1094 END SUBROUTINE mp_win_type_set_handle
1095
1096 ELEMENTAL FUNCTION mp_win_type_get_handle(this) RESULT(handle)
1097 CLASS(mp_win_type), INTENT(IN) :: this
1098 INTEGER :: handle
1099
1100#if defined(__parallel) && defined(__MPI_F08)
1101 handle = this%handle%mpi_val
1102#else
1103 handle = this%handle
1104#endif
1105 END FUNCTION mp_win_type_get_handle
1106 LOGICAL FUNCTION mp_file_op_eq(file1, file2)
1107 CLASS(mp_file_type), INTENT(IN) :: file1, file2
1108#if defined(__parallel) && defined(__MPI_F08)
1109 mp_file_op_eq = (file1%handle%mpi_val .EQ. file2%handle%mpi_val)
1110#else
1111 mp_file_op_eq = (file1%handle .EQ. file2%handle)
1112#endif
1113 END FUNCTION mp_file_op_eq
1114
1115 LOGICAL FUNCTION mp_file_op_neq(file1, file2)
1116 CLASS(mp_file_type), INTENT(IN) :: file1, file2
1117#if defined(__parallel) && defined(__MPI_F08)
1118 mp_file_op_neq = (file1%handle%mpi_val .NE. file2%handle%mpi_val)
1119#else
1120 mp_file_op_neq = (file1%handle .NE. file2%handle)
1121#endif
1122 END FUNCTION mp_file_op_neq
1123
1124 ELEMENTAL SUBROUTINE mp_file_type_set_handle(this, handle )
1125 CLASS(mp_file_type), INTENT(INOUT) :: this
1126 INTEGER, INTENT(IN) :: handle
1127
1128#if defined(__parallel) && defined(__MPI_F08)
1129 this%handle%mpi_val = handle
1130#else
1131 this%handle = handle
1132#endif
1133
1134
1135 END SUBROUTINE mp_file_type_set_handle
1136
1137 ELEMENTAL FUNCTION mp_file_type_get_handle(this) RESULT(handle)
1138 CLASS(mp_file_type), INTENT(IN) :: this
1139 INTEGER :: handle
1140
1141#if defined(__parallel) && defined(__MPI_F08)
1142 handle = this%handle%mpi_val
1143#else
1144 handle = this%handle
1145#endif
1146 END FUNCTION mp_file_type_get_handle
1147 LOGICAL FUNCTION mp_info_op_eq(info1, info2)
1148 CLASS(mp_info_type), INTENT(IN) :: info1, info2
1149#if defined(__parallel) && defined(__MPI_F08)
1150 mp_info_op_eq = (info1%handle%mpi_val .EQ. info2%handle%mpi_val)
1151#else
1152 mp_info_op_eq = (info1%handle .EQ. info2%handle)
1153#endif
1154 END FUNCTION mp_info_op_eq
1155
1156 LOGICAL FUNCTION mp_info_op_neq(info1, info2)
1157 CLASS(mp_info_type), INTENT(IN) :: info1, info2
1158#if defined(__parallel) && defined(__MPI_F08)
1159 mp_info_op_neq = (info1%handle%mpi_val .NE. info2%handle%mpi_val)
1160#else
1161 mp_info_op_neq = (info1%handle .NE. info2%handle)
1162#endif
1163 END FUNCTION mp_info_op_neq
1164
1165 ELEMENTAL SUBROUTINE mp_info_type_set_handle(this, handle )
1166 CLASS(mp_info_type), INTENT(INOUT) :: this
1167 INTEGER, INTENT(IN) :: handle
1168
1169#if defined(__parallel) && defined(__MPI_F08)
1170 this%handle%mpi_val = handle
1171#else
1172 this%handle = handle
1173#endif
1174
1175
1176 END SUBROUTINE mp_info_type_set_handle
1177
1178 ELEMENTAL FUNCTION mp_info_type_get_handle(this) RESULT(handle)
1179 CLASS(mp_info_type), INTENT(IN) :: this
1180 INTEGER :: handle
1181
1182#if defined(__parallel) && defined(__MPI_F08)
1183 handle = this%handle%mpi_val
1184#else
1185 handle = this%handle
1186#endif
1187 END FUNCTION mp_info_type_get_handle
1188
1189 FUNCTION mp_comm_get_tag_ub(comm) RESULT(tag_ub)
1190 CLASS(mp_comm_type), INTENT(IN) :: comm
1191 INTEGER :: tag_ub
1192
1193#if defined(__parallel)
1194 INTEGER :: ierr
1195 LOGICAL :: flag
1196 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1197
1198 CALL mpi_comm_get_attr(comm%handle, mpi_tag_ub, attrval, flag, ierr)
1199 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_tag_ub")
1200 IF (.NOT. flag) cpabort("Upper bound of tags not available!")
1201 tag_ub = int(attrval, kind=kind(tag_ub))
1202#else
1203 mark_used(comm)
1204 tag_ub = huge(1)
1205#endif
1206 END FUNCTION mp_comm_get_tag_ub
1207
1208 FUNCTION mp_comm_get_host_rank(comm) RESULT(host_rank)
1209 CLASS(mp_comm_type), INTENT(IN) :: comm
1210 INTEGER :: host_rank
1211
1212#if defined(__parallel)
1213 INTEGER :: ierr
1214 LOGICAL :: flag
1215 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1216
1217 CALL mpi_comm_get_attr(comm%handle, mpi_host, attrval, flag, ierr)
1218 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_host_rank")
1219 IF (.NOT. flag) cpabort("Host process rank not available!")
1220 host_rank = int(attrval, kind=kind(host_rank))
1221#else
1222 mark_used(comm)
1223 host_rank = 0
1224#endif
1225 END FUNCTION mp_comm_get_host_rank
1226
1227 FUNCTION mp_comm_get_io_rank(comm) RESULT(io_rank)
1228 CLASS(mp_comm_type), INTENT(IN) :: comm
1229 INTEGER :: io_rank
1230
1231#if defined(__parallel)
1232 INTEGER :: ierr
1233 LOGICAL :: flag
1234 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1235
1236 CALL mpi_comm_get_attr(comm%handle, mpi_io, attrval, flag, ierr)
1237 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_io_rank")
1238 IF (.NOT. flag) cpabort("IO rank not available!")
1239 io_rank = int(attrval, kind=kind(io_rank))
1240#else
1241 mark_used(comm)
1242 io_rank = 0
1243#endif
1244 END FUNCTION mp_comm_get_io_rank
1245
1246 FUNCTION mp_comm_get_wtime_is_global(comm) RESULT(wtime_is_global)
1247 CLASS(mp_comm_type), INTENT(IN) :: comm
1248 LOGICAL :: wtime_is_global
1249
1250#if defined(__parallel)
1251 INTEGER :: ierr
1252 LOGICAL :: flag
1253 INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1254
1255 CALL mpi_comm_get_attr(comm%handle, mpi_tag_ub, attrval, flag, ierr)
1256 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_wtime_is_global")
1257 IF (.NOT. flag) cpabort("Synchronization state of WTIME not available!")
1258 wtime_is_global = (attrval == 1_mpi_address_kind)
1259#else
1260 mark_used(comm)
1261 wtime_is_global = .true.
1262#endif
1263 END FUNCTION mp_comm_get_wtime_is_global
1264
1265! **************************************************************************************************
1266!> \brief initializes the system default communicator
1267!> \param mp_comm [output] : handle of the default communicator
1268!> \par History
1269!> 2.2004 created [Joost VandeVondele ]
1270!> \note
1271!> should only be called once
1272! **************************************************************************************************
1273 SUBROUTINE mp_world_init(mp_comm)
1274 CLASS(mp_comm_type), INTENT(OUT) :: mp_comm
1275#if defined(__parallel)
1276 INTEGER :: ierr
1277!$ INTEGER :: provided_tsl
1278!$ LOGICAL :: no_threading_support
1279
1280#if defined(__NO_MPI_THREAD_SUPPORT_CHECK)
1281 ! Hack that does not request or check MPI thread support level.
1282 ! User asserts that the MPI library will work correctly with
1283 ! threads.
1284!
1285!$ no_threading_support = .TRUE.
1286#else
1287 ! Does the right thing when using OpenMP: requests that the MPI
1288 ! library supports serialized mode and verifies that the MPI library
1289 ! provides that support.
1290 !
1291 ! Developers: Only the master thread will ever make calls to the
1292 ! MPI library.
1293!
1294!$ no_threading_support = .FALSE.
1295#endif
1296!$ IF (no_threading_support) THEN
1297 CALL mpi_init(ierr)
1298 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init @ mp_world_init")
1299!$ ELSE
1300!$OMP MASTER
1301#if defined(__DLAF)
1302 ! DLA-Future requires that the MPI library supports
1303 ! THREAD_MULTIPLE mode
1304!$ CALL mpi_init_thread(MPI_THREAD_MULTIPLE, provided_tsl, ierr)
1305#else
1306!$ CALL mpi_init_thread(MPI_THREAD_SERIALIZED, provided_tsl, ierr)
1307#endif
1308!$ IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
1309#if defined(__DLAF)
1310!$ IF (provided_tsl .LT. MPI_THREAD_MULTIPLE) THEN
1311!$ 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.")
1312!$ END IF
1313#else
1314!$ IF (provided_tsl .LT. MPI_THREAD_SERIALIZED) THEN
1315!$ CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_SERIALIZED).")
1316!$ END IF
1317#endif
1318!$OMP END MASTER
1319!$ END IF
1320 CALL mpi_comm_set_errhandler(mpi_comm_world, mpi_errors_return, ierr)
1321 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_set_errhandler @ mp_world_init")
1322#endif
1323 debug_comm_count = 1
1324 mp_comm = mp_comm_world
1325 CALL mp_comm%init()
1326 CALL add_mp_perf_env()
1327 END SUBROUTINE mp_world_init
1328
1329! **************************************************************************************************
1330!> \brief re-create the system default communicator with a different MPI
1331!> rank order
1332!> \param mp_comm [output] : handle of the default communicator
1333!> \param mp_new_comm ...
1334!> \param ranks_order ...
1335!> \par History
1336!> 1.2012 created [ Christiane Pousa ]
1337!> \note
1338!> should only be called once, at very beginning of CP2K run
1339! **************************************************************************************************
1340 SUBROUTINE mp_reordering(mp_comm, mp_new_comm, ranks_order)
1341 CLASS(mp_comm_type), INTENT(IN) :: mp_comm
1342 CLASS(mp_comm_type), INTENT(out) :: mp_new_comm
1343 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: ranks_order
1344
1345 CHARACTER(len=*), PARAMETER :: routinen = 'mp_reordering'
1346
1347 INTEGER :: handle, ierr
1348#if defined(__parallel)
1349 mpi_group_type :: newgroup, oldgroup
1350#endif
1351
1352 CALL mp_timeset(routinen, handle)
1353 ierr = 0
1354#if defined(__parallel)
1355
1356 CALL mpi_comm_group(mp_comm%handle, oldgroup, ierr)
1357 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_reordering")
1358 CALL mpi_group_incl(oldgroup, SIZE(ranks_order), ranks_order, newgroup, ierr)
1359 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_incl @ mp_reordering")
1360
1361 CALL mpi_comm_create(mp_comm%handle, newgroup, mp_new_comm%handle, ierr)
1362 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_create @ mp_reordering")
1363
1364 CALL mpi_group_free(oldgroup, ierr)
1365 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1366 CALL mpi_group_free(newgroup, ierr)
1367 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1368
1369 CALL add_perf(perf_id=1, count=1)
1370#else
1371 mark_used(mp_comm)
1372 mark_used(ranks_order)
1373 mp_new_comm%handle = mp_comm_default_handle
1374#endif
1375 debug_comm_count = debug_comm_count + 1
1376 CALL mp_new_comm%init()
1377 CALL mp_timestop(handle)
1378 END SUBROUTINE mp_reordering
1379
1380! **************************************************************************************************
1381!> \brief finalizes the system default communicator
1382!> \par History
1383!> 2.2004 created [Joost VandeVondele]
1384! **************************************************************************************************
1385 SUBROUTINE mp_world_finalize()
1386
1387 CHARACTER(LEN=default_string_length) :: debug_comm_count_char
1388#if defined(__parallel)
1389 INTEGER :: ierr
1390 CALL mpi_barrier(mpi_comm_world, ierr) ! call mpi directly to avoid 0 stack pointer
1391#endif
1392 CALL rm_mp_perf_env()
1393
1394 debug_comm_count = debug_comm_count - 1
1395#if defined(__parallel)
1396 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_world_finalize")
1397#endif
1398 IF (debug_comm_count .NE. 0) THEN
1399 ! A bug, we're leaking or double-freeing communicators. Needs to be fixed where the leak happens.
1400 ! Memory leak checking might be helpful to locate the culprit
1401 WRITE (unit=debug_comm_count_char, fmt='(I0)')
1402 CALL cp_abort(__location__, "mp_world_finalize: assert failed:"// &
1403 " leaking communicators "//trim(debug_comm_count_char))
1404 END IF
1405#if defined(__parallel)
1406 CALL mpi_finalize(ierr)
1407 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_finalize @ mp_world_finalize")
1408#endif
1409
1410 END SUBROUTINE mp_world_finalize
1411
1412! all the following routines should work for a given communicator, not MPI_WORLD
1413
1414! **************************************************************************************************
1415!> \brief globally stops all tasks
1416!> this is intended to be low level, most of CP2K should call cp_abort()
1417! **************************************************************************************************
1418 SUBROUTINE mp_abort()
1419 INTEGER :: ierr
1420
1421 ierr = 0
1422
1423#if !defined(__NO_ABORT)
1424#if defined(__parallel)
1425 CALL mpi_abort(mpi_comm_world, 1, ierr)
1426#else
1427 CALL m_abort()
1428#endif
1429#endif
1430 ! this routine never returns and levels with non-zero exit code
1431 stop 1
1432 END SUBROUTINE mp_abort
1433
1434! **************************************************************************************************
1435!> \brief stops *after an mpi error* translating the error code
1436!> \param ierr an error code * returned by an mpi call *
1437!> \param prg_code ...
1438!> \note
1439!> this function is private to message_passing.F
1440! **************************************************************************************************
1441 SUBROUTINE mp_stop(ierr, prg_code)
1442 INTEGER, INTENT(IN) :: ierr
1443 CHARACTER(LEN=*), INTENT(IN) :: prg_code
1444
1445#if defined(__parallel)
1446 INTEGER :: istat, len
1447 CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: error_string
1448 CHARACTER(LEN=MPI_MAX_ERROR_STRING + 512) :: full_error
1449#else
1450 CHARACTER(LEN=512) :: full_error
1451#endif
1452
1453#if defined(__parallel)
1454 CALL mpi_error_string(ierr, error_string, len, istat)
1455 WRITE (full_error, '(A,I0,A)') ' MPI error ', ierr, ' in '//trim(prg_code)//' : '//error_string(1:len)
1456#else
1457 WRITE (full_error, '(A,I0,A)') ' MPI error (!?) ', ierr, ' in '//trim(prg_code)
1458#endif
1459
1460 cpabort(full_error)
1461
1462 END SUBROUTINE mp_stop
1463
1464! **************************************************************************************************
1465!> \brief synchronizes with a barrier a given group of mpi tasks
1466!> \param group mpi communicator
1467! **************************************************************************************************
1468 SUBROUTINE mp_sync(comm)
1469 CLASS(mp_comm_type), INTENT(IN) :: comm
1470
1471 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sync'
1472
1473 INTEGER :: handle, ierr
1474
1475 ierr = 0
1476 CALL mp_timeset(routinen, handle)
1477
1478#if defined(__parallel)
1479 CALL mpi_barrier(comm%handle, ierr)
1480 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_sync")
1481 CALL add_perf(perf_id=5, count=1)
1482#else
1483 mark_used(comm)
1484#endif
1485 CALL mp_timestop(handle)
1486
1487 END SUBROUTINE mp_sync
1488
1489! **************************************************************************************************
1490!> \brief synchronizes with a barrier a given group of mpi tasks
1491!> \param comm mpi communicator
1492!> \param request ...
1493! **************************************************************************************************
1494 SUBROUTINE mp_isync(comm, request)
1495 CLASS(mp_comm_type), INTENT(IN) :: comm
1496 TYPE(mp_request_type), INTENT(OUT) :: request
1497
1498 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isync'
1499
1500 INTEGER :: handle, ierr
1501
1502 ierr = 0
1503 CALL mp_timeset(routinen, handle)
1504
1505#if defined(__parallel)
1506 CALL mpi_ibarrier(comm%handle, request%handle, ierr)
1507 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibarrier @ mp_isync")
1508 CALL add_perf(perf_id=26, count=1)
1509#else
1510 mark_used(comm)
1511 request = mp_request_null
1512#endif
1513 CALL mp_timestop(handle)
1514
1515 END SUBROUTINE mp_isync
1516
1517! **************************************************************************************************
1518!> \brief returns task id for a given mpi communicator
1519!> \param taskid The ID of the communicator
1520!> \param comm mpi communicator
1521! **************************************************************************************************
1522 SUBROUTINE mp_comm_rank(taskid, comm)
1523
1524 INTEGER, INTENT(OUT) :: taskid
1525 CLASS(mp_comm_type), INTENT(IN) :: comm
1526
1527 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_rank'
1528
1529 INTEGER :: handle
1530#if defined(__parallel)
1531 INTEGER :: ierr
1532#endif
1533
1534 CALL mp_timeset(routinen, handle)
1535
1536#if defined(__parallel)
1537 CALL mpi_comm_rank(comm%handle, taskid, ierr)
1538 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_rank")
1539#else
1540 mark_used(comm)
1541 taskid = 0
1542#endif
1543 CALL mp_timestop(handle)
1544
1545 END SUBROUTINE mp_comm_rank
1546
1547! **************************************************************************************************
1548!> \brief returns number of tasks for a given mpi communicator
1549!> \param numtask ...
1550!> \param comm mpi communicator
1551! **************************************************************************************************
1552 SUBROUTINE mp_comm_size(numtask, comm)
1553
1554 INTEGER, INTENT(OUT) :: numtask
1555 CLASS(mp_comm_type), INTENT(IN) :: comm
1556
1557 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_size'
1558
1559 INTEGER :: handle
1560#if defined(__parallel)
1561 INTEGER :: ierr
1562#endif
1563
1564 CALL mp_timeset(routinen, handle)
1565
1566#if defined(__parallel)
1567 CALL mpi_comm_size(comm%handle, numtask, ierr)
1568 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_size")
1569#else
1570 mark_used(comm)
1571 numtask = 1
1572#endif
1573 CALL mp_timestop(handle)
1574
1575 END SUBROUTINE mp_comm_size
1576
1577! **************************************************************************************************
1578!> \brief returns info for a given Cartesian MPI communicator
1579!> \param comm ...
1580!> \param ndims ...
1581!> \param dims ...
1582!> \param task_coor ...
1583!> \param periods ...
1584! **************************************************************************************************
1585 SUBROUTINE mp_cart_get(comm, dims, task_coor, periods)
1586
1587 CLASS(mp_cart_type), INTENT(IN) :: comm
1588 INTEGER, INTENT(OUT), OPTIONAL :: dims(comm%ndims), task_coor(comm%ndims)
1589 LOGICAL, INTENT(out), OPTIONAL :: periods(comm%ndims)
1590
1591 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_get'
1592
1593 INTEGER :: handle
1594#if defined(__parallel)
1595 INTEGER :: ierr
1596 INTEGER :: my_dims(comm%ndims), my_task_coor(comm%ndims)
1597 LOGICAL :: my_periods(comm%ndims)
1598#endif
1599
1600 CALL mp_timeset(routinen, handle)
1601
1602#if defined(__parallel)
1603 CALL mpi_cart_get(comm%handle, comm%ndims, my_dims, my_periods, my_task_coor, ierr)
1604 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_cart_get")
1605 IF (PRESENT(dims)) dims = my_dims
1606 IF (PRESENT(task_coor)) task_coor = my_task_coor
1607 IF (PRESENT(periods)) periods = my_periods
1608#else
1609 mark_used(comm)
1610 IF (PRESENT(task_coor)) task_coor = 0
1611 IF (PRESENT(dims)) dims = 1
1612 IF (PRESENT(periods)) periods = .false.
1613#endif
1614 CALL mp_timestop(handle)
1615
1616 END SUBROUTINE mp_cart_get
1617
1618 INTEGER ELEMENTAL function mp_comm_get_ndims(comm)
1619 CLASS(mp_comm_type), INTENT(IN) :: comm
1620
1621 mp_comm_get_ndims = comm%ndims
1622
1623 END FUNCTION
1624
1625! **************************************************************************************************
1626!> \brief creates a cartesian communicator from any communicator
1627!> \param comm_old ...
1628!> \param ndims ...
1629!> \param dims ...
1630!> \param pos ...
1631!> \param comm_cart ...
1632! **************************************************************************************************
1633 SUBROUTINE mp_cart_create(comm_old, ndims, dims, comm_cart)
1634
1635 CLASS(mp_comm_type), INTENT(IN) :: comm_old
1636 INTEGER, INTENT(IN) :: ndims
1637 INTEGER, INTENT(INOUT) :: dims(ndims)
1638 CLASS(mp_cart_type), INTENT(OUT) :: comm_cart
1639
1640 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_create'
1641
1642 INTEGER :: handle, ierr
1643#if defined(__parallel)
1644 LOGICAL, DIMENSION(1:ndims) :: period
1645 LOGICAL :: reorder
1646#endif
1647
1648 ierr = 0
1649 CALL mp_timeset(routinen, handle)
1650
1651 comm_cart%handle = comm_old%handle
1652#if defined(__parallel)
1653
1654 IF (any(dims == 0)) CALL mpi_dims_create(comm_old%num_pe, ndims, dims, ierr)
1655 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_cart_create")
1656
1657 ! FIX ME. Quick hack to avoid problems with realspace grids for compilers
1658 ! like IBM that actually reorder the processors when creating the new
1659 ! communicator
1660 reorder = .false.
1661 period = .true.
1662 CALL mpi_cart_create(comm_old%handle, ndims, dims, period, reorder, comm_cart%handle, &
1663 ierr)
1664 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_create @ mp_cart_create")
1665 CALL add_perf(perf_id=1, count=1)
1666#else
1667 dims = 1
1668 comm_cart%handle = mp_comm_default_handle
1669#endif
1670 comm_cart%ndims = ndims
1671 debug_comm_count = debug_comm_count + 1
1672 CALL comm_cart%init()
1673 CALL mp_timestop(handle)
1674
1675 END SUBROUTINE mp_cart_create
1676
1677! **************************************************************************************************
1678!> \brief wrapper to MPI_Cart_coords
1679!> \param comm ...
1680!> \param rank ...
1681!> \param coords ...
1682! **************************************************************************************************
1683 SUBROUTINE mp_cart_coords(comm, rank, coords)
1684
1685 CLASS(mp_cart_type), INTENT(IN) :: comm
1686 INTEGER, INTENT(IN) :: rank
1687 INTEGER, DIMENSION(:), INTENT(OUT) :: coords
1688
1689 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_coords'
1690
1691 INTEGER :: handle, ierr, m
1692
1693 ierr = 0
1694 CALL mp_timeset(routinen, handle)
1695
1696 m = SIZE(coords)
1697#if defined(__parallel)
1698 CALL mpi_cart_coords(comm%handle, rank, m, coords, ierr)
1699 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_coords @ mp_cart_coords")
1700#else
1701 coords = 0
1702 mark_used(rank)
1703 mark_used(comm)
1704#endif
1705 CALL mp_timestop(handle)
1706
1707 END SUBROUTINE mp_cart_coords
1708
1709! **************************************************************************************************
1710!> \brief wrapper to MPI_Comm_compare
1711!> \param comm1 ...
1712!> \param comm2 ...
1713!> \param res ...
1714! **************************************************************************************************
1715 FUNCTION mp_comm_compare(comm1, comm2) RESULT(res)
1716
1717 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
1718 INTEGER :: res
1719
1720 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_compare'
1721
1722 INTEGER :: handle
1723#if defined(__parallel)
1724 INTEGER :: ierr, iout
1725#endif
1726
1727 CALL mp_timeset(routinen, handle)
1728
1729 res = 0
1730#if defined(__parallel)
1731 CALL mpi_comm_compare(comm1%handle, comm2%handle, iout, ierr)
1732 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_compare @ mp_comm_compare")
1733 SELECT CASE (iout)
1734 CASE (mpi_ident)
1735 res = mp_comm_ident
1736 CASE (mpi_congruent)
1737 res = mp_comm_congruent
1738 CASE (mpi_similar)
1739 res = mp_comm_similar
1740 CASE (mpi_unequal)
1741 res = mp_comm_unequal
1742 CASE default
1743 cpabort("Unknown comparison state of the communicators!")
1744 END SELECT
1745#else
1746 mark_used(comm1)
1747 mark_used(comm2)
1748#endif
1749 CALL mp_timestop(handle)
1750
1751 END FUNCTION mp_comm_compare
1752
1753! **************************************************************************************************
1754!> \brief wrapper to MPI_Cart_sub
1755!> \param comm ...
1756!> \param rdim ...
1757!> \param sub_comm ...
1758! **************************************************************************************************
1759 SUBROUTINE mp_cart_sub(comm, rdim, sub_comm)
1760
1761 CLASS(mp_cart_type), INTENT(IN) :: comm
1762 LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: rdim
1763 CLASS(mp_cart_type), INTENT(OUT) :: sub_comm
1764
1765 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_sub'
1766
1767 INTEGER :: handle
1768#if defined(__parallel)
1769 INTEGER :: ierr
1770#endif
1771
1772 CALL mp_timeset(routinen, handle)
1773
1774#if defined(__parallel)
1775 CALL mpi_cart_sub(comm%handle, rdim, sub_comm%handle, ierr)
1776 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_sub @ mp_cart_sub")
1777#else
1778 mark_used(comm)
1779 mark_used(rdim)
1780 sub_comm%handle = mp_comm_default_handle
1781#endif
1782 sub_comm%ndims = count(rdim)
1783 debug_comm_count = debug_comm_count + 1
1784 CALL sub_comm%init()
1785 CALL mp_timestop(handle)
1786
1787 END SUBROUTINE mp_cart_sub
1788
1789! **************************************************************************************************
1790!> \brief wrapper to MPI_Comm_free
1791!> \param comm ...
1792! **************************************************************************************************
1793 SUBROUTINE mp_comm_free(comm)
1794
1795 CLASS(mp_comm_type), INTENT(INOUT) :: comm
1796
1797 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_free'
1798
1799 INTEGER :: handle
1800 LOGICAL :: free_comm
1801#if defined(__parallel)
1802 INTEGER :: ierr
1803#endif
1804
1805 free_comm = .true.
1806 SELECT TYPE (comm)
1807 CLASS IS (mp_para_env_type)
1808 free_comm = .false.
1809 IF (comm%ref_count <= 0) &
1810 cpabort("para_env%ref_count <= 0")
1811 comm%ref_count = comm%ref_count - 1
1812 IF (comm%ref_count <= 0) THEN
1813 free_comm = comm%owns_group
1814 END IF
1815 CLASS IS (mp_para_cart_type)
1816 free_comm = .false.
1817 IF (comm%ref_count <= 0) &
1818 cpabort("para_cart%ref_count <= 0")
1819 comm%ref_count = comm%ref_count - 1
1820 IF (comm%ref_count <= 0) THEN
1821 free_comm = comm%owns_group
1822 END IF
1823 END SELECT
1824
1825 CALL mp_timeset(routinen, handle)
1826
1827 IF (free_comm) THEN
1828#if defined(__parallel)
1829 CALL mpi_comm_free(comm%handle, ierr)
1830 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_free @ mp_comm_free")
1831#else
1832 comm%handle = mp_comm_null_handle
1833#endif
1834 debug_comm_count = debug_comm_count - 1
1835 END IF
1836
1837 SELECT TYPE (comm)
1838 CLASS IS (mp_cart_type)
1839 DEALLOCATE (comm%periodic, comm%mepos_cart, comm%num_pe_cart)
1840 END SELECT
1841
1842 CALL mp_timestop(handle)
1843
1844 END SUBROUTINE mp_comm_free
1845
1846! **************************************************************************************************
1847!> \brief check whether the environment exists
1848!> \param para_env ...
1849!> \return ...
1850! **************************************************************************************************
1851 ELEMENTAL LOGICAL FUNCTION mp_para_env_is_valid(para_env)
1852 CLASS(mp_para_env_type), INTENT(IN) :: para_env
1853
1854 mp_para_env_is_valid = para_env%ref_count > 0
1855
1856 END FUNCTION mp_para_env_is_valid
1857
1858! **************************************************************************************************
1859!> \brief increase the reference counter but ensure that you free it later
1860!> \param para_env ...
1861! **************************************************************************************************
1862 ELEMENTAL SUBROUTINE mp_para_env_retain(para_env)
1863 CLASS(mp_para_env_type), INTENT(INOUT) :: para_env
1864
1865 para_env%ref_count = para_env%ref_count + 1
1866
1867 END SUBROUTINE mp_para_env_retain
1868
1869! **************************************************************************************************
1870!> \brief check whether the given environment is valid, i.e. existent
1871!> \param cart ...
1872!> \return ...
1873! **************************************************************************************************
1874 ELEMENTAL LOGICAL FUNCTION mp_para_cart_is_valid(cart)
1875 CLASS(mp_para_cart_type), INTENT(IN) :: cart
1876
1877 mp_para_cart_is_valid = cart%ref_count > 0
1878
1879 END FUNCTION mp_para_cart_is_valid
1880
1881! **************************************************************************************************
1882!> \brief increase the reference counter, don't forget to free it later
1883!> \param cart ...
1884! **************************************************************************************************
1885 ELEMENTAL SUBROUTINE mp_para_cart_retain(cart)
1886 CLASS(mp_para_cart_type), INTENT(INOUT) :: cart
1887
1888 cart%ref_count = cart%ref_count + 1
1889
1890 END SUBROUTINE mp_para_cart_retain
1891
1892! **************************************************************************************************
1893!> \brief wrapper to MPI_Comm_dup
1894!> \param comm1 ...
1895!> \param comm2 ...
1896! **************************************************************************************************
1897 SUBROUTINE mp_comm_dup(comm1, comm2)
1898
1899 CLASS(mp_comm_type), INTENT(IN) :: comm1
1900 CLASS(mp_comm_type), INTENT(OUT) :: comm2
1901
1902 CHARACTER(len=*), PARAMETER :: routinen = 'mp_comm_dup'
1903
1904 INTEGER :: handle
1905#if defined(__parallel)
1906 INTEGER :: ierr
1907#endif
1908
1909 CALL mp_timeset(routinen, handle)
1910
1911#if defined(__parallel)
1912 CALL mpi_comm_dup(comm1%handle, comm2%handle, ierr)
1913 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_dup @ mp_comm_dup")
1914#else
1915 mark_used(comm1)
1916 comm2%handle = mp_comm_default_handle
1917#endif
1918 comm2%ndims = comm1%ndims
1919 debug_comm_count = debug_comm_count + 1
1920 CALL comm2%init()
1921 CALL mp_timestop(handle)
1922
1923 END SUBROUTINE mp_comm_dup
1924
1925! **************************************************************************************************
1926!> \brief Implements a simple assignment function to overload the assignment operator
1927!> \param comm_new communicator on the r.h.s. of the assignment operator
1928!> \param comm_old communicator on the l.h.s. of the assignment operator
1929! **************************************************************************************************
1930 ELEMENTAL IMPURE SUBROUTINE mp_comm_assign(comm_new, comm_old)
1931 CLASS(mp_comm_type), INTENT(IN) :: comm_old
1932 CLASS(mp_comm_type), INTENT(OUT) :: comm_new
1933
1934 comm_new%handle = comm_old%handle
1935 comm_new%ndims = comm_old%ndims
1936 CALL comm_new%init(.false.)
1937 END SUBROUTINE
1938
1939! **************************************************************************************************
1940!> \brief check whether the local process is the source process
1941!> \param para_env ...
1942!> \return ...
1943! **************************************************************************************************
1944 ELEMENTAL LOGICAL FUNCTION mp_comm_is_source(comm)
1945 CLASS(mp_comm_type), INTENT(IN) :: comm
1946
1947 mp_comm_is_source = comm%source == comm%mepos
1948
1949 END FUNCTION mp_comm_is_source
1950
1951! **************************************************************************************************
1952!> \brief Initializes the communicator (mostly relevant for its derived classes)
1953!> \param comm ...
1954! **************************************************************************************************
1955 ELEMENTAL IMPURE SUBROUTINE mp_comm_init(comm, owns_group)
1956 CLASS(mp_comm_type), INTENT(INOUT) :: comm
1957 LOGICAL, INTENT(IN), OPTIONAL :: owns_group
1958
1959 IF (comm%handle mpi_get_comp .NE. mp_comm_null_handle mpi_get_comp) THEN
1960 comm%source = 0
1961 CALL comm%get_size(comm%num_pe)
1962 CALL comm%get_rank(comm%mepos)
1963 END IF
1964
1965 SELECT TYPE (comm)
1966 CLASS IS (mp_cart_type)
1967 IF (ALLOCATED(comm%periodic)) DEALLOCATE (comm%periodic)
1968 IF (ALLOCATED(comm%mepos_cart)) DEALLOCATE (comm%mepos_cart)
1969 IF (ALLOCATED(comm%num_pe_cart)) DEALLOCATE (comm%num_pe_cart)
1970
1971 associate(ndims => comm%ndims)
1972
1973 ALLOCATE (comm%periodic(ndims), comm%mepos_cart(ndims), &
1974 comm%num_pe_cart(ndims))
1975 END associate
1976
1977 comm%mepos_cart = 0
1978 comm%periodic = .false.
1979 IF (comm%handle mpi_get_comp .NE. mp_comm_null_handle mpi_get_comp) THEN
1980 CALL comm%get_info_cart(comm%num_pe_cart, comm%mepos_cart, &
1981 comm%periodic)
1982 END IF
1983 END SELECT
1984
1985 SELECT TYPE (comm)
1986 CLASS IS (mp_para_env_type)
1987 IF (PRESENT(owns_group)) comm%owns_group = owns_group
1988 comm%ref_count = 1
1989 CLASS IS (mp_para_cart_type)
1990 IF (PRESENT(owns_group)) comm%owns_group = owns_group
1991 comm%ref_count = 1
1992 END SELECT
1993
1994 END SUBROUTINE
1995
1996! **************************************************************************************************
1997!> \brief creates a new para environment
1998!> \param para_env the new parallel environment
1999!> \param group the id of the actual mpi_group
2000!> \par History
2001!> 08.2002 created [fawzi]
2002!> \author Fawzi Mohamed
2003! **************************************************************************************************
2004 SUBROUTINE mp_para_env_create(para_env, group)
2005 TYPE(mp_para_env_type), POINTER :: para_env
2006 CLASS(mp_comm_type), INTENT(in) :: group
2007
2008 IF (ASSOCIATED(para_env)) &
2009 cpabort("The passed para_env must not be associated!")
2010 ALLOCATE (para_env)
2011 para_env%mp_comm_type = group
2012 CALL para_env%init()
2013 END SUBROUTINE mp_para_env_create
2014
2015! **************************************************************************************************
2016!> \brief releases the para object (to be called when you don't want anymore
2017!> the shared copy of this object)
2018!> \param para_env the new group
2019!> \par History
2020!> 08.2002 created [fawzi]
2021!> \author Fawzi Mohamed
2022!> \note
2023!> to avoid circular dependencies cp_log_handling has a private copy
2024!> of this method (see cp_log_handling:my_mp_para_env_release)!
2025! **************************************************************************************************
2026 SUBROUTINE mp_para_env_release(para_env)
2027 TYPE(mp_para_env_type), POINTER :: para_env
2028
2029 IF (ASSOCIATED(para_env)) THEN
2030 CALL para_env%free()
2031 IF (.NOT. para_env%is_valid()) DEALLOCATE (para_env)
2032 END IF
2033 NULLIFY (para_env)
2034 END SUBROUTINE mp_para_env_release
2035
2036! **************************************************************************************************
2037!> \brief creates a cart (multidimensional parallel environment)
2038!> \param cart the cart environment to create
2039!> \param group the mpi communicator
2040!> \author fawzi
2041! **************************************************************************************************
2042 SUBROUTINE mp_para_cart_create(cart, group)
2043 TYPE(mp_para_cart_type), POINTER, INTENT(OUT) :: cart
2044 CLASS(mp_comm_type), INTENT(in) :: group
2045
2046 IF (ASSOCIATED(cart)) &
2047 cpabort("The passed para_cart must not be associated!")
2048 ALLOCATE (cart)
2049 cart%mp_cart_type = group
2050 CALL cart%init()
2051
2052 END SUBROUTINE mp_para_cart_create
2053
2054! **************************************************************************************************
2055!> \brief releases the given cart
2056!> \param cart the cart to release
2057!> \author fawzi
2058! **************************************************************************************************
2059 SUBROUTINE mp_para_cart_release(cart)
2060 TYPE(mp_para_cart_type), POINTER :: cart
2061
2062 IF (ASSOCIATED(cart)) THEN
2063 CALL cart%free()
2064 IF (.NOT. cart%is_valid()) DEALLOCATE (cart)
2065 END IF
2066 NULLIFY (cart)
2067 END SUBROUTINE mp_para_cart_release
2068
2069! **************************************************************************************************
2070!> \brief wrapper to MPI_Group_translate_ranks
2071!> \param comm1 ...
2072!> \param comm2 ...
2073!> \param rank ...
2074! **************************************************************************************************
2075 SUBROUTINE mp_rank_compare(comm1, comm2, rank)
2076
2077 CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
2078 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rank
2079
2080 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rank_compare'
2081
2082 INTEGER :: handle
2083#if defined(__parallel)
2084 INTEGER :: i, ierr, n, n1, n2
2085 INTEGER, ALLOCATABLE, DIMENSION(:) :: rin
2086 mpi_group_type :: g1, g2
2087#endif
2088
2089 CALL mp_timeset(routinen, handle)
2090
2091 rank = 0
2092#if defined(__parallel)
2093 CALL mpi_comm_size(comm1%handle, n1, ierr)
2094 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
2095 CALL mpi_comm_size(comm2%handle, n2, ierr)
2096 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
2097 n = max(n1, n2)
2098 CALL mpi_comm_group(comm1%handle, g1, ierr)
2099 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
2100 CALL mpi_comm_group(comm2%handle, g2, ierr)
2101 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
2102 ALLOCATE (rin(0:n - 1), stat=ierr)
2103 IF (ierr /= 0) &
2104 cpabort("allocate @ mp_rank_compare")
2105 DO i = 0, n - 1
2106 rin(i) = i
2107 END DO
2108 CALL mpi_group_translate_ranks(g1, n, rin, g2, rank, ierr)
2109 IF (ierr /= 0) CALL mp_stop(ierr, &
2110 "mpi_group_translate_rank @ mp_rank_compare")
2111 CALL mpi_group_free(g1, ierr)
2112 IF (ierr /= 0) &
2113 cpabort("group_free @ mp_rank_compare")
2114 CALL mpi_group_free(g2, ierr)
2115 IF (ierr /= 0) &
2116 cpabort("group_free @ mp_rank_compare")
2117 DEALLOCATE (rin)
2118#else
2119 mark_used(comm1)
2120 mark_used(comm2)
2121#endif
2122 CALL mp_timestop(handle)
2123
2124 END SUBROUTINE mp_rank_compare
2125
2126! **************************************************************************************************
2127!> \brief wrapper to MPI_Dims_create
2128!> \param nodes ...
2129!> \param dims ...
2130! **************************************************************************************************
2131 SUBROUTINE mp_dims_create(nodes, dims)
2132
2133 INTEGER, INTENT(IN) :: nodes
2134 INTEGER, DIMENSION(:), INTENT(INOUT) :: dims
2135
2136 CHARACTER(len=*), PARAMETER :: routinen = 'mp_dims_create'
2137
2138 INTEGER :: handle, ndim
2139#if defined(__parallel)
2140 INTEGER :: ierr
2141#endif
2142
2143 CALL mp_timeset(routinen, handle)
2144
2145 ndim = SIZE(dims)
2146#if defined(__parallel)
2147 IF (any(dims == 0)) CALL mpi_dims_create(nodes, ndim, dims, ierr)
2148 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_dims_create")
2149#else
2150 dims = 1
2151 mark_used(nodes)
2152#endif
2153 CALL mp_timestop(handle)
2154
2155 END SUBROUTINE mp_dims_create
2156
2157! **************************************************************************************************
2158!> \brief wrapper to MPI_Cart_rank
2159!> \param comm ...
2160!> \param pos ...
2161!> \param rank ...
2162! **************************************************************************************************
2163 SUBROUTINE mp_cart_rank(comm, pos, rank)
2164 CLASS(mp_cart_type), INTENT(IN) :: comm
2165 INTEGER, DIMENSION(:), INTENT(IN) :: pos
2166 INTEGER, INTENT(OUT) :: rank
2167
2168 CHARACTER(len=*), PARAMETER :: routinen = 'mp_cart_rank'
2169
2170 INTEGER :: handle
2171#if defined(__parallel)
2172 INTEGER :: ierr
2173#endif
2174
2175 CALL mp_timeset(routinen, handle)
2176
2177#if defined(__parallel)
2178 CALL mpi_cart_rank(comm%handle, pos, rank, ierr)
2179 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_rank @ mp_cart_rank")
2180#else
2181 rank = 0
2182 mark_used(comm)
2183 mark_used(pos)
2184#endif
2185 CALL mp_timestop(handle)
2186
2187 END SUBROUTINE mp_cart_rank
2188
2189! **************************************************************************************************
2190!> \brief waits for completion of the given request
2191!> \param request ...
2192!> \par History
2193!> 08.2003 created [f&j]
2194!> \author joost & fawzi
2195!> \note
2196!> see isendrecv
2197! **************************************************************************************************
2198 SUBROUTINE mp_wait(request)
2199 CLASS(mp_request_type), INTENT(inout) :: request
2200
2201 CHARACTER(len=*), PARAMETER :: routinen = 'mp_wait'
2202
2203 INTEGER :: handle
2204#if defined(__parallel)
2205 INTEGER :: ierr
2206#endif
2207
2208 CALL mp_timeset(routinen, handle)
2209
2210#if defined(__parallel)
2211
2212 CALL mpi_wait(request%handle, mpi_status_ignore, ierr)
2213 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_wait @ mp_wait")
2214
2215 CALL add_perf(perf_id=9, count=1)
2216#else
2217 request%handle = mp_request_null_handle
2218#endif
2219 CALL mp_timestop(handle)
2220 END SUBROUTINE mp_wait
2221
2222! **************************************************************************************************
2223!> \brief waits for completion of the given requests
2224!> \param requests ...
2225!> \par History
2226!> 08.2003 created [f&j]
2227!> \author joost & fawzi
2228!> \note
2229!> see isendrecv
2230! **************************************************************************************************
2231 SUBROUTINE mp_waitall_1(requests)
2232 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2233
2234 CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_1'
2235
2236 INTEGER :: handle
2237#if defined(__parallel)
2238 INTEGER :: count, ierr
2239#if !defined(__MPI_F08)
2240 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: status
2241#else
2242 TYPE(mpi_status), ALLOCATABLE, DIMENSION(:) :: status
2243#endif
2244#endif
2245
2246 CALL mp_timeset(routinen, handle)
2247
2248#if defined(__parallel)
2249 count = SIZE(requests)
2250#if !defined(__MPI_F08)
2251 ALLOCATE (status(mpi_status_size, count))
2252#else
2253 ALLOCATE (status(count))
2254#endif
2255 CALL mpi_waitall_internal(count, requests, status, ierr) ! MPI_STATUSES_IGNORE openmpi workaround
2256 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_1")
2257 DEALLOCATE (status)
2258 CALL add_perf(perf_id=9, count=1)
2259#else
2260 requests = mp_request_null
2261#endif
2262 CALL mp_timestop(handle)
2263 END SUBROUTINE mp_waitall_1
2264
2265! **************************************************************************************************
2266!> \brief waits for completion of the given requests
2267!> \param requests ...
2268!> \par History
2269!> 08.2003 created [f&j]
2270!> \author joost & fawzi
2271! **************************************************************************************************
2272 SUBROUTINE mp_waitall_2(requests)
2273 TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2274
2275 CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_2'
2276
2277 INTEGER :: handle
2278#if defined(__parallel)
2279 INTEGER :: count, ierr
2280#if !defined(__MPI_F08)
2281 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: status
2282#else
2283 TYPE(mpi_status), ALLOCATABLE, DIMENSION(:) :: status
2284#endif
2285#endif
2286
2287 CALL mp_timeset(routinen, handle)
2288
2289#if defined(__parallel)
2290 count = SIZE(requests)
2291#if !defined(__MPI_F08)
2292 ALLOCATE (status(mpi_status_size, count))
2293#else
2294 ALLOCATE (status(count))
2295#endif
2296
2297 CALL mpi_waitall_internal(count, requests, status, ierr) ! MPI_STATUSES_IGNORE openmpi workaround
2298 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_2")
2299 DEALLOCATE (status)
2300
2301 CALL add_perf(perf_id=9, count=1)
2302#else
2303 requests = mp_request_null
2304#endif
2305 CALL mp_timestop(handle)
2306 END SUBROUTINE mp_waitall_2
2307
2308! **************************************************************************************************
2309!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2310!> the issue is with the rank or requests
2311!> \param count ...
2312!> \param array_of_requests ...
2313!> \param array_of_statuses ...
2314!> \param ierr ...
2315!> \author Joost VandeVondele
2316! **************************************************************************************************
2317#if defined(__parallel)
2318 SUBROUTINE mpi_waitall_internal(count, array_of_requests, array_of_statuses, ierr)
2319 INTEGER, INTENT(in) :: count
2320 TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2321#if !defined(__MPI_F08)
2322 INTEGER, DIMENSION(MPI_STATUS_SIZE, count), &
2323 INTENT(out) :: array_of_statuses
2324#else
2325 TYPE(mpi_status), DIMENSION(count), &
2326 INTENT(out) :: array_of_statuses
2327#endif
2328 INTEGER, INTENT(out) :: ierr
2329
2330 INTEGER :: i
2331 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2332
2333 ALLOCATE (request_handles(count))
2334 DO i = 1, count
2335 request_handles(i) = array_of_requests(i)%handle
2336 END DO
2337
2338 CALL mpi_waitall(count, request_handles, array_of_statuses, ierr)
2339
2340 DO i = 1, count
2341 array_of_requests(i)%handle = request_handles(i)
2342 END DO
2343
2344 END SUBROUTINE mpi_waitall_internal
2345#endif
2346
2347! **************************************************************************************************
2348!> \brief waits for completion of any of the given requests
2349!> \param requests ...
2350!> \param completed ...
2351!> \par History
2352!> 09.2008 created
2353!> \author Iain Bethune (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
2354! **************************************************************************************************
2355 SUBROUTINE mp_waitany(requests, completed)
2356 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2357 INTEGER, INTENT(out) :: completed
2358
2359 CHARACTER(len=*), PARAMETER :: routinen = 'mp_waitany'
2360
2361 INTEGER :: handle
2362#if defined(__parallel)
2363 INTEGER :: count, i, ierr
2364 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2365#endif
2366
2367 CALL mp_timeset(routinen, handle)
2368
2369#if defined(__parallel)
2370 count = SIZE(requests)
2371! Convert CP2K's request_handles to the plane handle for the library
2372! (Maybe, the compiler optimizes it away)
2373 ALLOCATE (request_handles(count))
2374 DO i = 1, count
2375 request_handles(i) = requests(i)%handle
2376 END DO
2377 CALL mpi_waitany(count, request_handles, completed, mpi_status_ignore, ierr)
2378 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitany @ mp_waitany")
2379! Convert the plane handles to CP2K handles
2380 DO i = 1, count
2381 requests(i)%handle = request_handles(i)
2382 END DO
2383 CALL add_perf(perf_id=9, count=1)
2384#else
2385 requests = mp_request_null
2386 completed = 1
2387#endif
2388 CALL mp_timestop(handle)
2389 END SUBROUTINE mp_waitany
2390
2391! **************************************************************************************************
2392!> \brief Tests for completion of the given requests.
2393!> \brief We use mpi_test so that we can use a single status.
2394!> \param requests the list of requests to test
2395!> \return logical which determines if requests are complete
2396!> \par History
2397!> 3.2016 adapted to any shape [Nico Holmberg]
2398!> \author Alfio Lazzaro
2399! **************************************************************************************************
2400 FUNCTION mp_testall_tv(requests) RESULT(flag)
2401 TYPE(mp_request_type), DIMENSION(:), INTENT(INOUT) :: requests
2402 LOGICAL :: flag
2403
2404#if defined(__parallel)
2405 INTEGER :: i, ierr
2406 LOGICAL, DIMENSION(:), POINTER :: flags
2407#endif
2408
2409 flag = .true.
2410
2411#if defined(__parallel)
2412 ALLOCATE (flags(SIZE(requests)))
2413 DO i = 1, SIZE(requests)
2414 CALL mpi_test(requests(i)%handle, flags(i), mpi_status_ignore, ierr)
2415 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testall @ mp_testall_tv")
2416 flag = flag .AND. flags(i)
2417 END DO
2418 DEALLOCATE (flags)
2419#else
2420 requests = mp_request_null
2421#endif
2422 END FUNCTION mp_testall_tv
2423
2424! **************************************************************************************************
2425!> \brief Tests for completion of the given request.
2426!> \param request the request
2427!> \param flag logical which determines if the request is completed
2428!> \par History
2429!> 3.2016 created
2430!> \author Nico Holmberg
2431! **************************************************************************************************
2432 FUNCTION mp_test_1(request) RESULT(flag)
2433 CLASS(mp_request_type), INTENT(inout) :: request
2434 LOGICAL :: flag
2435
2436#if defined(__parallel)
2437 INTEGER :: ierr
2438
2439 CALL mpi_test(request%handle, flag, mpi_status_ignore, ierr)
2440 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_test @ mp_test_1")
2441#else
2442 mark_used(request)
2443 flag = .true.
2444#endif
2445 END FUNCTION mp_test_1
2446
2447! **************************************************************************************************
2448!> \brief tests for completion of the given requests
2449!> \param requests ...
2450!> \param completed ...
2451!> \param flag ...
2452!> \par History
2453!> 08.2011 created
2454!> \author Iain Bethune
2455! **************************************************************************************************
2456 SUBROUTINE mp_testany_1(requests, completed, flag)
2457 TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2458 INTEGER, INTENT(out), OPTIONAL :: completed
2459 LOGICAL, INTENT(out), OPTIONAL :: flag
2460
2461#if defined(__parallel)
2462 INTEGER :: completed_l, count, ierr
2463 LOGICAL :: flag_l
2464
2465 count = SIZE(requests)
2466
2467 CALL mpi_testany_internal(count, requests, completed_l, flag_l, mpi_status_ignore, ierr)
2468 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_1 @ mp_testany")
2469
2470 IF (PRESENT(completed)) completed = completed_l
2471 IF (PRESENT(flag)) flag = flag_l
2472#else
2473 mark_used(requests)
2474 IF (PRESENT(completed)) completed = 1
2475 IF (PRESENT(flag)) flag = .true.
2476#endif
2477 END SUBROUTINE mp_testany_1
2478
2479! **************************************************************************************************
2480!> \brief tests for completion of the given requests
2481!> \param requests ...
2482!> \param completed ...
2483!> \param flag ...
2484!> \par History
2485!> 08.2011 created
2486!> \author Iain Bethune
2487! **************************************************************************************************
2488 SUBROUTINE mp_testany_2(requests, completed, flag)
2489 TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2490 INTEGER, INTENT(out), OPTIONAL :: completed
2491 LOGICAL, INTENT(out), OPTIONAL :: flag
2492
2493#if defined(__parallel)
2494 INTEGER :: completed_l, count, ierr
2495 LOGICAL :: flag_l
2496
2497 count = SIZE(requests)
2498
2499 CALL mpi_testany_internal(count, requests, completed_l, flag_l, mpi_status_ignore, ierr)
2500 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_2 @ mp_testany")
2501
2502 IF (PRESENT(completed)) completed = completed_l
2503 IF (PRESENT(flag)) flag = flag_l
2504#else
2505 mark_used(requests)
2506 IF (PRESENT(completed)) completed = 1
2507 IF (PRESENT(flag)) flag = .true.
2508#endif
2509 END SUBROUTINE mp_testany_2
2510
2511! **************************************************************************************************
2512!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2513!> the issue is with the rank or requests
2514!> \param count ...
2515!> \param array_of_requests ...
2516!> \param index ...
2517!> \param flag ...
2518!> \param status ...
2519!> \param ierr ...
2520!> \author Joost VandeVondele
2521! **************************************************************************************************
2522#if defined(__parallel)
2523 SUBROUTINE mpi_testany_internal(count, array_of_requests, index, flag, status, ierr)
2524 INTEGER, INTENT(in) :: count
2525 TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2526 INTEGER, INTENT(out) :: index
2527 LOGICAL, INTENT(out) :: flag
2528 mpi_status_type, INTENT(out) :: status
2529 INTEGER, INTENT(out) :: ierr
2530
2531 INTEGER :: i
2532 mpi_request_type, ALLOCATABLE, DIMENSION(:) :: request_handles
2533
2534 ALLOCATE (request_handles(count))
2535 DO i = 1, count
2536 request_handles(i) = array_of_requests(i)%handle
2537 END DO
2538
2539 CALL mpi_testany(count, request_handles, index, flag, status, ierr)
2540
2541 DO i = 1, count
2542 array_of_requests(i)%handle = request_handles(i)
2543 END DO
2544
2545 END SUBROUTINE mpi_testany_internal
2546#endif
2547
2548! **************************************************************************************************
2549!> \brief the direct way to split a communicator each color is a sub_comm,
2550!> the rank order is according to the order in the orig comm
2551!> \param comm ...
2552!> \param sub_comm ...
2553!> \param color ...
2554!> \param key ...
2555!> \author Joost VandeVondele
2556! **************************************************************************************************
2557 SUBROUTINE mp_comm_split_direct(comm, sub_comm, color, key)
2558 CLASS(mp_comm_type), INTENT(in) :: comm
2559 CLASS(mp_comm_type), INTENT(OUT) :: sub_comm
2560 INTEGER, INTENT(in) :: color
2561 INTEGER, INTENT(in), OPTIONAL :: key
2562
2563 CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_split_direct'
2564
2565 INTEGER :: handle
2566#if defined(__parallel)
2567 INTEGER :: ierr, my_key
2568#endif
2569
2570 CALL mp_timeset(routinen, handle)
2571
2572#if defined(__parallel)
2573 my_key = 0
2574 IF (PRESENT(key)) my_key = key
2575 CALL mpi_comm_split(comm%handle, color, my_key, sub_comm%handle, ierr)
2576 IF (ierr /= mpi_success) CALL mp_stop(ierr, routinen)
2577 CALL add_perf(perf_id=10, count=1)
2578#else
2579 sub_comm%handle = mp_comm_default_handle
2580 mark_used(comm)
2581 mark_used(color)
2582 mark_used(key)
2583#endif
2584 debug_comm_count = debug_comm_count + 1
2585 CALL sub_comm%init()
2586 CALL mp_timestop(handle)
2587
2588 END SUBROUTINE mp_comm_split_direct
2589! **************************************************************************************************
2590!> \brief splits the given communicator in group in subgroups trying to organize
2591!> them in a way that the communication within each subgroup is
2592!> efficient (but not necessarily the communication between subgroups)
2593!> \param comm the mpi communicator that you want to split
2594!> \param sub_comm the communicator for the subgroup (created, needs to be freed later)
2595!> \param ngroups actual number of groups
2596!> \param group_distribution input : allocated with array with the nprocs entries (0 .. nprocs-1)
2597!> \param subgroup_min_size the minimum size of the subgroup
2598!> \param n_subgroups the number of subgroups wanted
2599!> \param group_partition n_subgroups sized array containing the number of cpus wanted per group.
2600!> should match the total number of cpus (only used if present and associated) (0..ngroups-1)
2601!> \param stride create groups using a stride (default=1) through the ranks of the comm to be split.
2602!> \par History
2603!> 10.2003 created [fawzi]
2604!> 02.2004 modified [Joost VandeVondele]
2605!> \author Fawzi Mohamed
2606!> \note
2607!> at least one of subgroup_min_size and n_subgroups is needed,
2608!> the other default to the value needed to use most processors.
2609!> if less cpus are present than needed for subgroup min size, n_subgroups,
2610!> just one comm is created that contains all cpus
2611! **************************************************************************************************
2612 SUBROUTINE mp_comm_split(comm, sub_comm, ngroups, group_distribution, &
2613 subgroup_min_size, n_subgroups, group_partition, stride)
2614 CLASS(mp_comm_type), INTENT(in) :: comm
2615 CLASS(mp_comm_type), INTENT(out) :: sub_comm
2616 INTEGER, INTENT(out) :: ngroups
2617 INTEGER, DIMENSION(0:), INTENT(INOUT) :: group_distribution
2618 INTEGER, INTENT(in), OPTIONAL :: subgroup_min_size, n_subgroups
2619 INTEGER, DIMENSION(0:), INTENT(IN), OPTIONAL :: group_partition
2620 INTEGER, OPTIONAL, INTENT(IN) :: stride
2621
2622 CHARACTER(LEN=*), PARAMETER :: routineN = 'mp_comm_split', &
2623 routinep = modulen//':'//routinen
2624
2625 INTEGER :: handle, mepos, nnodes
2626#if defined(__parallel)
2627 INTEGER :: color, i, ierr, j, k, &
2628 my_subgroup_min_size, &
2629 istride, local_stride, irank
2630 INTEGER, DIMENSION(:), ALLOCATABLE :: rank_permutation
2631#endif
2632
2633 CALL mp_timeset(routinen, handle)
2634
2635 ! actual number of groups
2636
2637 IF (.NOT. PRESENT(subgroup_min_size) .AND. .NOT. PRESENT(n_subgroups)) THEN
2638 cpabort(routinep//" missing arguments")
2639 END IF
2640 IF (PRESENT(subgroup_min_size) .AND. PRESENT(n_subgroups)) THEN
2641 cpabort(routinep//" too many arguments")
2642 END IF
2643
2644 CALL comm%get_size(nnodes)
2645 CALL comm%get_rank(mepos)
2646
2647 IF (ubound(group_distribution, 1) .NE. nnodes - 1) THEN
2648 cpabort(routinep//" group_distribution wrong bounds")
2649 END IF
2650
2651#if defined(__parallel)
2652 IF (PRESENT(subgroup_min_size)) THEN
2653 IF (subgroup_min_size < 0 .OR. subgroup_min_size > nnodes) THEN
2654 cpabort(routinep//" subgroup_min_size too small or too large")
2655 END IF
2656 ngroups = nnodes/subgroup_min_size
2657 my_subgroup_min_size = subgroup_min_size
2658 ELSE ! n_subgroups
2659 IF (n_subgroups <= 0) THEN
2660 cpabort(routinep//" n_subgroups too small")
2661 END IF
2662 IF (nnodes/n_subgroups > 0) THEN ! we have a least one cpu per group
2663 ngroups = n_subgroups
2664 ELSE ! well, only one group then
2665 ngroups = 1
2666 END IF
2667 my_subgroup_min_size = nnodes/ngroups
2668 END IF
2669
2670 ! rank_permutation: is a permutation of ranks, so that groups are not necessarily continuous in rank of the master group
2671 ! 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
2672 ! (by setting stride equal to the number of mpi ranks per node), or by sharing a node between two groups (stride 2).
2673 ALLOCATE (rank_permutation(0:nnodes - 1))
2674 local_stride = 1
2675 IF (PRESENT(stride)) local_stride = stride
2676 k = 0
2677 DO istride = 1, local_stride
2678 DO irank = istride - 1, nnodes - 1, local_stride
2679 rank_permutation(k) = irank
2680 k = k + 1
2681 END DO
2682 END DO
2683
2684 DO i = 0, nnodes - 1
2685 group_distribution(rank_permutation(i)) = min(i/my_subgroup_min_size, ngroups - 1)
2686 END DO
2687 ! even the user gave a partition, see if we can use it to overwrite this choice
2688 IF (PRESENT(group_partition)) THEN
2689 IF (all(group_partition > 0) .AND. (sum(group_partition) .EQ. nnodes) .AND. (ngroups == SIZE(group_partition))) THEN
2690 k = 0
2691 DO i = 0, SIZE(group_partition) - 1
2692 DO j = 1, group_partition(i)
2693 group_distribution(rank_permutation(k)) = i
2694 k = k + 1
2695 END DO
2696 END DO
2697 ELSE
2698 ! just ignore silently as we have reasonable defaults. Probably a warning would not be to bad
2699 END IF
2700 END IF
2701 color = group_distribution(mepos)
2702 CALL mpi_comm_split(comm%handle, color, 0, sub_comm%handle, ierr)
2703 IF (ierr /= mpi_success) CALL mp_stop(ierr, "in "//routinep//" split")
2704
2705 CALL add_perf(perf_id=10, count=1)
2706#else
2707 sub_comm%handle = mp_comm_default_handle
2708 group_distribution(0) = 0
2709 ngroups = 1
2710 mark_used(comm)
2711 mark_used(stride)
2712 mark_used(group_partition)
2713#endif
2714 debug_comm_count = debug_comm_count + 1
2715 CALL sub_comm%init()
2716 CALL mp_timestop(handle)
2717
2718 END SUBROUTINE mp_comm_split
2719
2720! **************************************************************************************************
2721!> \brief Get the local rank on the node according to the global communicator
2722!> \return Node Rank id
2723!> \author Alfio Lazzaro
2724! **************************************************************************************************
2725 FUNCTION mp_get_node_global_rank() &
2726 result(node_rank)
2727
2728 INTEGER :: node_rank
2729
2730 CHARACTER(len=*), PARAMETER :: routinen = 'mp_get_node_global_rank'
2731 INTEGER :: handle
2732#if defined(__parallel)
2733 INTEGER :: ierr, rank
2734 TYPE(mp_comm_type) :: comm
2735#endif
2736
2737 CALL mp_timeset(routinen, handle)
2738
2739#if defined(__parallel)
2740 CALL mpi_comm_rank(mpi_comm_world, rank, ierr)
2741 IF (ierr /= mpi_success) CALL mp_stop(ierr, routinen)
2742 CALL mpi_comm_split_type(mpi_comm_world, mpi_comm_type_shared, rank, mpi_info_null, comm%handle, ierr)
2743 IF (ierr /= mpi_success) CALL mp_stop(ierr, routinen)
2744 CALL mpi_comm_rank(comm%handle, node_rank, ierr)
2745 IF (ierr /= mpi_success) CALL mp_stop(ierr, routinen)
2746 CALL mpi_comm_free(comm%handle, ierr)
2747 IF (ierr /= mpi_success) CALL mp_stop(ierr, routinen)
2748#else
2749 node_rank = 0
2750#endif
2751 CALL mp_timestop(handle)
2752
2753 END FUNCTION mp_get_node_global_rank
2754
2755! **************************************************************************************************
2756!> \brief probes for an incoming message with any tag
2757!> \param[inout] source the source of the possible incoming message,
2758!> if MP_ANY_SOURCE it is a blocking one and return value is the source
2759!> of the next incoming message
2760!> if source is a different value it is a non-blocking probe returning
2761!> MP_ANY_SOURCE if there is no incoming message
2762!> \param[in] comm the communicator
2763!> \param[out] tag the tag of the incoming message
2764!> \author Mandes
2765! **************************************************************************************************
2766 SUBROUTINE mp_probe(source, comm, tag)
2767 INTEGER, INTENT(INOUT) :: source
2768 CLASS(mp_comm_type), INTENT(IN) :: comm
2769 INTEGER, INTENT(OUT) :: tag
2770
2771 CHARACTER(len=*), PARAMETER :: routinen = 'mp_probe'
2772
2773 INTEGER :: handle
2774#if defined(__parallel)
2775 INTEGER :: ierr
2776 mpi_status_type :: status_single
2777 LOGICAL :: flag
2778#endif
2779
2780! ---------------------------------------------------------------------------
2781
2782 CALL mp_timeset(routinen, handle)
2783
2784#if defined(__parallel)
2785 IF (source .EQ. mp_any_source) THEN
2786 CALL mpi_probe(mp_any_source, mp_any_tag, comm%handle, status_single, ierr)
2787 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_probe @ mp_probe")
2788 source = status_single mpi_status_extract(mpi_source)
2789 tag = status_single mpi_status_extract(mpi_tag)
2790 ELSE
2791 flag = .false.
2792 CALL mpi_iprobe(source, mp_any_tag, comm%handle, flag, status_single, ierr)
2793 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iprobe @ mp_probe")
2794 IF (flag .EQV. .false.) THEN
2795 source = mp_any_source
2796 tag = -1 !status_single(MPI_TAG) ! in case of flag==false status is undefined
2797 ELSE
2798 tag = status_single mpi_status_extract(mpi_tag)
2799 END IF
2800 END IF
2801#else
2802 tag = -1
2803 mark_used(comm)
2804 mark_used(source)
2805#endif
2806 CALL mp_timestop(handle)
2807 END SUBROUTINE mp_probe
2808
2809! **************************************************************************************************
2810! Here come the data routines with none of the standard data types.
2811! **************************************************************************************************
2812
2813! **************************************************************************************************
2814!> \brief ...
2815!> \param msg ...
2816!> \param source ...
2817!> \param comm ...
2818! **************************************************************************************************
2819 SUBROUTINE mp_bcast_b(msg, source, comm)
2820 LOGICAL, INTENT(INOUT) :: msg
2821 INTEGER, INTENT(IN) :: source
2822 CLASS(mp_comm_type), INTENT(IN) :: comm
2823
2824 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_b'
2825
2826 INTEGER :: handle
2827#if defined(__parallel)
2828 INTEGER :: ierr, msglen
2829#endif
2830
2831 CALL mp_timeset(routinen, handle)
2832
2833#if defined(__parallel)
2834 msglen = 1
2835 CALL mpi_bcast(msg, msglen, mpi_logical, source, comm%handle, ierr)
2836 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2837 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2838#else
2839 mark_used(msg)
2840 mark_used(source)
2841 mark_used(comm)
2842#endif
2843 CALL mp_timestop(handle)
2844 END SUBROUTINE mp_bcast_b
2845
2846! **************************************************************************************************
2847!> \brief ...
2848!> \param msg ...
2849!> \param source ...
2850!> \param comm ...
2851! **************************************************************************************************
2852 SUBROUTINE mp_bcast_b_src(msg, comm)
2853 LOGICAL, INTENT(INOUT) :: msg
2854 CLASS(mp_comm_type), INTENT(IN) :: comm
2855
2856 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_b_src'
2857
2858 INTEGER :: handle
2859#if defined(__parallel)
2860 INTEGER :: ierr, msglen
2861#endif
2862
2863 CALL mp_timeset(routinen, handle)
2864
2865#if defined(__parallel)
2866 msglen = 1
2867 CALL mpi_bcast(msg, msglen, mpi_logical, comm%source, comm%handle, ierr)
2868 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2869 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2870#else
2871 mark_used(msg)
2872 mark_used(comm)
2873#endif
2874 CALL mp_timestop(handle)
2875 END SUBROUTINE mp_bcast_b_src
2876
2877! **************************************************************************************************
2878!> \brief ...
2879!> \param msg ...
2880!> \param source ...
2881!> \param comm ...
2882! **************************************************************************************************
2883 SUBROUTINE mp_bcast_bv(msg, source, comm)
2884 LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2885 INTEGER, INTENT(IN) :: source
2886 CLASS(mp_comm_type), INTENT(IN) :: comm
2887
2888 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_bv'
2889
2890 INTEGER :: handle
2891#if defined(__parallel)
2892 INTEGER :: ierr, msglen
2893#endif
2894
2895 CALL mp_timeset(routinen, handle)
2896
2897#if defined(__parallel)
2898 msglen = SIZE(msg)
2899 CALL mpi_bcast(msg, msglen, mpi_logical, source, comm%handle, ierr)
2900 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2901 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2902#else
2903 mark_used(msg)
2904 mark_used(source)
2905 mark_used(comm)
2906#endif
2907 CALL mp_timestop(handle)
2908 END SUBROUTINE mp_bcast_bv
2909
2910! **************************************************************************************************
2911!> \brief ...
2912!> \param msg ...
2913!> \param comm ...
2914! **************************************************************************************************
2915 SUBROUTINE mp_bcast_bv_src(msg, comm)
2916 LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2917 CLASS(mp_comm_type), INTENT(IN) :: comm
2918
2919 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_bv_src'
2920
2921 INTEGER :: handle
2922#if defined(__parallel)
2923 INTEGER :: ierr, msglen
2924#endif
2925
2926 CALL mp_timeset(routinen, handle)
2927
2928#if defined(__parallel)
2929 msglen = SIZE(msg)
2930 CALL mpi_bcast(msg, msglen, mpi_logical, comm%source, comm%handle, ierr)
2931 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
2932 CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2933#else
2934 mark_used(msg)
2935 mark_used(comm)
2936#endif
2937 CALL mp_timestop(handle)
2938 END SUBROUTINE mp_bcast_bv_src
2939
2940! **************************************************************************************************
2941!> \brief Non-blocking send of logical vector data
2942!> \param msgin the input message
2943!> \param dest the destination processor
2944!> \param comm the communicator object
2945!> \param request communication request index
2946!> \param tag message tag
2947!> \par History
2948!> 3.2016 added _bv subroutine [Nico Holmberg]
2949!> \author fawzi
2950!> \note see mp_irecv_iv
2951!> \note
2952!> arrays can be pointers or assumed shape, but they must be contiguous!
2953! **************************************************************************************************
2954 SUBROUTINE mp_isend_bv(msgin, dest, comm, request, tag)
2955 LOGICAL, DIMENSION(:), INTENT(IN) :: msgin
2956 INTEGER, INTENT(IN) :: dest
2957 CLASS(mp_comm_type), INTENT(IN) :: comm
2958 TYPE(mp_request_type), INTENT(out) :: request
2959 INTEGER, INTENT(in), OPTIONAL :: tag
2960
2961 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_bv'
2962
2963 INTEGER :: handle
2964#if defined(__parallel)
2965 INTEGER :: ierr, msglen, my_tag
2966 LOGICAL :: foo(1)
2967#endif
2968
2969 CALL mp_timeset(routinen, handle)
2970
2971#if defined(__parallel)
2972#if !defined(__GNUC__) || __GNUC__ >= 9
2973 cpassert(is_contiguous(msgin))
2974#endif
2975
2976 my_tag = 0
2977 IF (PRESENT(tag)) my_tag = tag
2978
2979 msglen = SIZE(msgin, 1)
2980 IF (msglen > 0) THEN
2981 CALL mpi_isend(msgin(1), msglen, mpi_logical, dest, my_tag, &
2982 comm%handle, request%handle, ierr)
2983 ELSE
2984 CALL mpi_isend(foo, msglen, mpi_logical, dest, my_tag, &
2985 comm%handle, request%handle, ierr)
2986 END IF
2987 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
2988
2989 CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2990#else
2991 cpabort("mp_isend called in non parallel case")
2992 mark_used(msgin)
2993 mark_used(dest)
2994 mark_used(comm)
2995 mark_used(tag)
2996 request = mp_request_null
2997#endif
2998 CALL mp_timestop(handle)
2999 END SUBROUTINE mp_isend_bv
3000
3001! **************************************************************************************************
3002!> \brief Non-blocking receive of logical vector data
3003!> \param msgout the received message
3004!> \param source the source processor
3005!> \param comm the communicator object
3006!> \param request communication request index
3007!> \param tag message tag
3008!> \par History
3009!> 3.2016 added _bv subroutine [Nico Holmberg]
3010!> \author fawzi
3011!> \note see mp_irecv_iv
3012!> \note
3013!> arrays can be pointers or assumed shape, but they must be contiguous!
3014! **************************************************************************************************
3015 SUBROUTINE mp_irecv_bv(msgout, source, comm, request, tag)
3016 LOGICAL, DIMENSION(:), INTENT(INOUT) :: msgout
3017 INTEGER, INTENT(IN) :: source
3018 CLASS(mp_comm_type), INTENT(IN) :: comm
3019 TYPE(mp_request_type), INTENT(out) :: request
3020 INTEGER, INTENT(in), OPTIONAL :: tag
3021
3022 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_bv'
3023
3024 INTEGER :: handle
3025#if defined(__parallel)
3026 INTEGER :: ierr, msglen, my_tag
3027 LOGICAL :: foo(1)
3028#endif
3029
3030 CALL mp_timeset(routinen, handle)
3031
3032#if defined(__parallel)
3033#if !defined(__GNUC__) || __GNUC__ >= 9
3034 cpassert(is_contiguous(msgout))
3035#endif
3036
3037 my_tag = 0
3038 IF (PRESENT(tag)) my_tag = tag
3039
3040 msglen = SIZE(msgout, 1)
3041 IF (msglen > 0) THEN
3042 CALL mpi_irecv(msgout(1), msglen, mpi_logical, source, my_tag, &
3043 comm%handle, request%handle, ierr)
3044 ELSE
3045 CALL mpi_irecv(foo, msglen, mpi_logical, source, my_tag, &
3046 comm%handle, request%handle, ierr)
3047 END IF
3048 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
3049
3050 CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
3051#else
3052 cpabort("mp_irecv called in non parallel case")
3053 mark_used(msgout)
3054 mark_used(source)
3055 mark_used(comm)
3056 mark_used(tag)
3057 request = mp_request_null
3058#endif
3059 CALL mp_timestop(handle)
3060 END SUBROUTINE mp_irecv_bv
3061
3062! **************************************************************************************************
3063!> \brief Non-blocking send of rank-3 logical data
3064!> \param msgin the input message
3065!> \param dest the destination processor
3066!> \param comm the communicator object
3067!> \param request communication request index
3068!> \param tag message tag
3069!> \par History
3070!> 2.2016 added _bm3 subroutine [Nico Holmberg]
3071!> \author fawzi
3072!> \note see mp_irecv_iv
3073!> \note
3074!> arrays can be pointers or assumed shape, but they must be contiguous!
3075! **************************************************************************************************
3076 SUBROUTINE mp_isend_bm3(msgin, dest, comm, request, tag)
3077 LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgin
3078 INTEGER, INTENT(IN) :: dest
3079 CLASS(mp_comm_type), INTENT(IN) :: comm
3080 TYPE(mp_request_type), INTENT(out) :: request
3081 INTEGER, INTENT(in), OPTIONAL :: tag
3082
3083 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_bm3'
3084
3085 INTEGER :: handle
3086#if defined(__parallel)
3087 INTEGER :: ierr, msglen, my_tag
3088 LOGICAL :: foo(1)
3089#endif
3090
3091 CALL mp_timeset(routinen, handle)
3092
3093#if defined(__parallel)
3094#if !defined(__GNUC__) || __GNUC__ >= 9
3095 cpassert(is_contiguous(msgin))
3096#endif
3097
3098 my_tag = 0
3099 IF (PRESENT(tag)) my_tag = tag
3100
3101 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
3102 IF (msglen > 0) THEN
3103 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_logical, dest, my_tag, &
3104 comm%handle, request%handle, ierr)
3105 ELSE
3106 CALL mpi_isend(foo, msglen, mpi_logical, dest, my_tag, &
3107 comm%handle, request%handle, ierr)
3108 END IF
3109 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
3110
3111 CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
3112#else
3113 cpabort("mp_isend called in non parallel case")
3114 mark_used(msgin)
3115 mark_used(dest)
3116 mark_used(comm)
3117 mark_used(tag)
3118 request = mp_request_null
3119#endif
3120 CALL mp_timestop(handle)
3121 END SUBROUTINE mp_isend_bm3
3122
3123! **************************************************************************************************
3124!> \brief Non-blocking receive of rank-3 logical data
3125!> \param msgout the received message
3126!> \param source the source processor
3127!> \param comm the communicator object
3128!> \param request communication request index
3129!> \param tag message tag
3130!> \par History
3131!> 2.2016 added _bm3 subroutine [Nico Holmberg]
3132!> \author fawzi
3133!> \note see mp_irecv_iv
3134!> \note
3135!> arrays can be pointers or assumed shape, but they must be contiguous!
3136! **************************************************************************************************
3137 SUBROUTINE mp_irecv_bm3(msgout, source, comm, request, tag)
3138 LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgout
3139 INTEGER, INTENT(IN) :: source
3140 CLASS(mp_comm_type), INTENT(IN) :: comm
3141 TYPE(mp_request_type), INTENT(out) :: request
3142 INTEGER, INTENT(in), OPTIONAL :: tag
3143
3144 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_bm3'
3145
3146 INTEGER :: handle
3147#if defined(__parallel)
3148 INTEGER :: ierr, msglen, my_tag
3149 LOGICAL :: foo(1)
3150#endif
3151
3152 CALL mp_timeset(routinen, handle)
3153
3154#if defined(__parallel)
3155#if !defined(__GNUC__) || __GNUC__ >= 9
3156 cpassert(is_contiguous(msgout))
3157#endif
3158
3159 my_tag = 0
3160 IF (PRESENT(tag)) my_tag = tag
3161
3162 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
3163 IF (msglen > 0) THEN
3164 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_logical, source, my_tag, &
3165 comm%handle, request%handle, ierr)
3166 ELSE
3167 CALL mpi_irecv(foo, msglen, mpi_logical, source, my_tag, &
3168 comm%handle, request%handle, ierr)
3169 END IF
3170 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
3171
3172 CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
3173#else
3174 cpabort("mp_irecv called in non parallel case")
3175 mark_used(msgout)
3176 mark_used(source)
3177 mark_used(comm)
3178 mark_used(request)
3179 mark_used(tag)
3180 request = mp_request_null
3181#endif
3182 CALL mp_timestop(handle)
3183 END SUBROUTINE mp_irecv_bm3
3184
3185! **************************************************************************************************
3186!> \brief ...
3187!> \param msg ...
3188!> \param source ...
3189!> \param comm ...
3190! **************************************************************************************************
3191 SUBROUTINE mp_bcast_av(msg, source, comm)
3192 CHARACTER(LEN=*), INTENT(INOUT) :: msg
3193 INTEGER, INTENT(IN) :: source
3194 CLASS(mp_comm_type), INTENT(IN) :: comm
3195
3196 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_av'
3197
3198 INTEGER :: handle
3199#if defined(__parallel)
3200 INTEGER :: i, ierr, msglen
3201 INTEGER, DIMENSION(:), ALLOCATABLE :: imsg
3202#endif
3203
3204 CALL mp_timeset(routinen, handle)
3205
3206#if defined(__parallel)
3207
3208 IF (comm%mepos == source) msglen = len_trim(msg)
3209
3210 CALL comm%bcast(msglen, source)
3211 ! this is a workaround to avoid problems on the T3E
3212 ! at the moment we have a data alignment error when trying to
3213 ! broadcast characters on the T3E (not always!)
3214 ! JH 19/3/99 on galileo
3215 ! CALL mpi_bcast(msg,msglen,MPI_CHARACTER,source,gid%handle,ierr)
3216 ALLOCATE (imsg(1:msglen))
3217 DO i = 1, msglen
3218 imsg(i) = ichar(msg(i:i))
3219 END DO
3220 CALL mpi_bcast(imsg, msglen, mpi_integer, source, comm%handle, ierr)
3221 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3222 msg = ""
3223 DO i = 1, msglen
3224 msg(i:i) = char(imsg(i))
3225 END DO
3226 DEALLOCATE (imsg)
3227 CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen)
3228#else
3229 mark_used(msg)
3230 mark_used(source)
3231 mark_used(comm)
3232#endif
3233 CALL mp_timestop(handle)
3234 END SUBROUTINE mp_bcast_av
3235
3236! **************************************************************************************************
3237!> \brief ...
3238!> \param msg ...
3239!> \param comm ...
3240! **************************************************************************************************
3241 SUBROUTINE mp_bcast_av_src(msg, comm)
3242 CHARACTER(LEN=*), INTENT(INOUT) :: msg
3243 CLASS(mp_comm_type), INTENT(IN) :: comm
3244
3245 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_av_src'
3246
3247 INTEGER :: handle
3248#if defined(__parallel)
3249 INTEGER :: i, ierr, msglen
3250 INTEGER, DIMENSION(:), ALLOCATABLE :: imsg
3251#endif
3252
3253 CALL mp_timeset(routinen, handle)
3254
3255#if defined(__parallel)
3256
3257 IF (comm%is_source()) msglen = len_trim(msg)
3258
3259 CALL comm%bcast(msglen, comm%source)
3260 ! this is a workaround to avoid problems on the T3E
3261 ! at the moment we have a data alignment error when trying to
3262 ! broadcast characters on the T3E (not always!)
3263 ! JH 19/3/99 on galileo
3264 ! CALL mpi_bcast(msg,msglen,MPI_CHARACTER,source,gid%handle,ierr)
3265 ALLOCATE (imsg(1:msglen))
3266 DO i = 1, msglen
3267 imsg(i) = ichar(msg(i:i))
3268 END DO
3269 CALL mpi_bcast(imsg, msglen, mpi_integer, comm%source, comm%handle, ierr)
3270 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3271 msg = ""
3272 DO i = 1, msglen
3273 msg(i:i) = char(imsg(i))
3274 END DO
3275 DEALLOCATE (imsg)
3276 CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen)
3277#else
3278 mark_used(msg)
3279 mark_used(comm)
3280#endif
3281 CALL mp_timestop(handle)
3282 END SUBROUTINE mp_bcast_av_src
3283
3284! **************************************************************************************************
3285!> \brief ...
3286!> \param msg ...
3287!> \param source ...
3288!> \param comm ...
3289! **************************************************************************************************
3290 SUBROUTINE mp_bcast_am(msg, source, comm)
3291 CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3292 INTEGER, INTENT(IN) :: source
3293 CLASS(mp_comm_type), INTENT(IN) :: comm
3294
3295 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_am'
3296
3297 INTEGER :: handle
3298#if defined(__parallel)
3299 INTEGER :: i, ierr, j, k, msglen, msgsiz
3300 INTEGER, ALLOCATABLE :: imsg(:), imsglen(:)
3301#endif
3302
3303 CALL mp_timeset(routinen, handle)
3304
3305#if defined(__parallel)
3306 msgsiz = SIZE(msg)
3307 ! Determine size of the minimum array of integers to broadcast the string
3308 ALLOCATE (imsglen(1:msgsiz))
3309 IF (comm%mepos == source) THEN
3310 DO j = 1, msgsiz
3311 imsglen(j) = len_trim(msg(j))
3312 END DO
3313 END IF
3314 CALL comm%bcast(imsglen, source)
3315 msglen = sum(imsglen)
3316 ! this is a workaround to avoid problems on the T3E
3317 ! at the moment we have a data alignment error when trying to
3318 ! broadcast characters on the T3E (not always!)
3319 ! JH 19/3/99 on galileo
3320 ALLOCATE (imsg(1:msglen))
3321 k = 0
3322 DO j = 1, msgsiz
3323 DO i = 1, imsglen(j)
3324 k = k + 1
3325 imsg(k) = ichar(msg(j) (i:i))
3326 END DO
3327 END DO
3328 CALL mpi_bcast(imsg, msglen, mpi_integer, source, comm%handle, ierr)
3329 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3330 msg = ""
3331 k = 0
3332 DO j = 1, msgsiz
3333 DO i = 1, imsglen(j)
3334 k = k + 1
3335 msg(j) (i:i) = char(imsg(k))
3336 END DO
3337 END DO
3338 DEALLOCATE (imsg)
3339 DEALLOCATE (imsglen)
3340 CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen*msgsiz)
3341#else
3342 mark_used(msg)
3343 mark_used(source)
3344 mark_used(comm)
3345#endif
3346 CALL mp_timestop(handle)
3347 END SUBROUTINE mp_bcast_am
3348
3349 SUBROUTINE mp_bcast_am_src(msg, comm)
3350 CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3351 CLASS(mp_comm_type), INTENT(IN) :: comm
3352
3353 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_am_src'
3354
3355 INTEGER :: handle
3356#if defined(__parallel)
3357 INTEGER :: i, ierr, j, k, msglen, msgsiz
3358 INTEGER, ALLOCATABLE :: imsg(:), imsglen(:)
3359#endif
3360
3361 CALL mp_timeset(routinen, handle)
3362
3363#if defined(__parallel)
3364 msgsiz = SIZE(msg)
3365 ! Determine size of the minimum array of integers to broadcast the string
3366 ALLOCATE (imsglen(1:msgsiz))
3367 DO j = 1, msgsiz
3368 imsglen(j) = len_trim(msg(j))
3369 END DO
3370 CALL comm%bcast(imsglen, comm%source)
3371 msglen = sum(imsglen)
3372 ! this is a workaround to avoid problems on the T3E
3373 ! at the moment we have a data alignment error when trying to
3374 ! broadcast characters on the T3E (not always!)
3375 ! JH 19/3/99 on galileo
3376 ALLOCATE (imsg(1:msglen))
3377 k = 0
3378 DO j = 1, msgsiz
3379 DO i = 1, imsglen(j)
3380 k = k + 1
3381 imsg(k) = ichar(msg(j) (i:i))
3382 END DO
3383 END DO
3384 CALL mpi_bcast(imsg, msglen, mpi_integer, comm%source, comm%handle, ierr)
3385 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
3386 msg = ""
3387 k = 0
3388 DO j = 1, msgsiz
3389 DO i = 1, imsglen(j)
3390 k = k + 1
3391 msg(j) (i:i) = char(imsg(k))
3392 END DO
3393 END DO
3394 DEALLOCATE (imsg)
3395 DEALLOCATE (imsglen)
3396 CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen*msgsiz)
3397#else
3398 mark_used(msg)
3399 mark_used(comm)
3400#endif
3401 CALL mp_timestop(handle)
3402 END SUBROUTINE mp_bcast_am_src
3403
3404! **************************************************************************************************
3405!> \brief Finds the location of the minimal element in a vector.
3406!> \param[in,out] msg Find location of maximum element among these
3407!> data (input).
3408!> \param[in] comm Message passing environment identifier
3409!> \par MPI mapping
3410!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3411!> \par Invalid data types
3412!> This routine is invalid for (int_8) data!
3413! **************************************************************************************************
3414 SUBROUTINE mp_minloc_dv(msg, comm)
3415 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3416 CLASS(mp_comm_type), INTENT(IN) :: comm
3417
3418 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_dv'
3419
3420 INTEGER :: handle
3421#if defined(__parallel)
3422 INTEGER :: ierr, msglen
3423 REAL(kind=real_8), ALLOCATABLE :: res(:)
3424#endif
3425
3426 IF ("d" .EQ. "l" .AND. real_8 .EQ. int_8) THEN
3427 cpabort("Minimal location not available with long integers @ "//routinen)
3428 END IF
3429 CALL mp_timeset(routinen, handle)
3430
3431#if defined(__parallel)
3432 msglen = SIZE(msg)
3433 ALLOCATE (res(1:msglen), stat=ierr)
3434 IF (ierr /= 0) &
3435 cpabort("allocate @ "//routinen)
3436 CALL mpi_allreduce(msg, res, msglen/2, mpi_2double_precision, mpi_minloc, comm%handle, ierr)
3437 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3438 msg = res
3439 DEALLOCATE (res)
3440 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3441#else
3442 mark_used(msg)
3443 mark_used(comm)
3444#endif
3445 CALL mp_timestop(handle)
3446 END SUBROUTINE mp_minloc_dv
3447
3448! **************************************************************************************************
3449!> \brief Finds the location of the minimal element in a vector.
3450!> \param[in,out] msg Find location of maximum element among these
3451!> data (input).
3452!> \param[in] comm Message passing environment identifier
3453!> \par MPI mapping
3454!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3455!> \par Invalid data types
3456!> This routine is invalid for (int_8) data!
3457! **************************************************************************************************
3458 SUBROUTINE mp_minloc_iv(msg, comm)
3459 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3460 CLASS(mp_comm_type), INTENT(IN) :: comm
3461
3462 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_iv'
3463
3464 INTEGER :: handle
3465#if defined(__parallel)
3466 INTEGER :: ierr, msglen
3467 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3468#endif
3469
3470 IF ("i" .EQ. "l" .AND. int_4 .EQ. int_8) THEN
3471 cpabort("Minimal location not available with long integers @ "//routinen)
3472 END IF
3473 CALL mp_timeset(routinen, handle)
3474
3475#if defined(__parallel)
3476 msglen = SIZE(msg)
3477 ALLOCATE (res(1:msglen))
3478 CALL mpi_allreduce(msg, res, msglen/2, mpi_2integer, mpi_minloc, comm%handle, ierr)
3479 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3480 msg = res
3481 DEALLOCATE (res)
3482 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3483#else
3484 mark_used(msg)
3485 mark_used(comm)
3486#endif
3487 CALL mp_timestop(handle)
3488 END SUBROUTINE mp_minloc_iv
3489
3490! **************************************************************************************************
3491!> \brief Finds the location of the minimal element in a vector.
3492!> \param[in,out] msg Find location of maximum element among these
3493!> data (input).
3494!> \param[in] comm Message passing environment identifier
3495!> \par MPI mapping
3496!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3497!> \par Invalid data types
3498!> This routine is invalid for (int_8) data!
3499! **************************************************************************************************
3500 SUBROUTINE mp_minloc_lv(msg, comm)
3501 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3502 CLASS(mp_comm_type), INTENT(IN) :: comm
3503
3504 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_lv'
3505
3506 INTEGER :: handle
3507#if defined(__parallel)
3508 INTEGER :: ierr, msglen
3509 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3510#endif
3511
3512 IF ("l" .EQ. "l" .AND. int_8 .EQ. int_8) THEN
3513 cpabort("Minimal location not available with long integers @ "//routinen)
3514 END IF
3515 CALL mp_timeset(routinen, handle)
3516
3517#if defined(__parallel)
3518 msglen = SIZE(msg)
3519 ALLOCATE (res(1:msglen))
3520 CALL mpi_allreduce(msg, res, msglen/2, mpi_integer8, mpi_minloc, comm%handle, ierr)
3521 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3522 msg = res
3523 DEALLOCATE (res)
3524 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3525#else
3526 mark_used(msg)
3527 mark_used(comm)
3528#endif
3529 CALL mp_timestop(handle)
3530 END SUBROUTINE mp_minloc_lv
3531
3532! **************************************************************************************************
3533!> \brief Finds the location of the minimal element in a vector.
3534!> \param[in,out] msg Find location of maximum element among these
3535!> data (input).
3536!> \param[in] comm Message passing environment identifier
3537!> \par MPI mapping
3538!> mpi_allreduce with the MPI_MINLOC reduction function identifier
3539!> \par Invalid data types
3540!> This routine is invalid for (int_8) data!
3541! **************************************************************************************************
3542 SUBROUTINE mp_minloc_rv(msg, comm)
3543 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3544 CLASS(mp_comm_type), INTENT(IN) :: comm
3545
3546 CHARACTER(len=*), PARAMETER :: routinen = 'mp_minloc_rv'
3547
3548 INTEGER :: handle
3549#if defined(__parallel)
3550 INTEGER :: ierr, msglen
3551 REAL(kind=real_4), ALLOCATABLE :: res(:)
3552#endif
3553
3554 IF ("r" .EQ. "l" .AND. real_4 .EQ. int_8) THEN
3555 cpabort("Minimal location not available with long integers @ "//routinen)
3556 END IF
3557 CALL mp_timeset(routinen, handle)
3558
3559#if defined(__parallel)
3560 msglen = SIZE(msg)
3561 ALLOCATE (res(1:msglen))
3562 CALL mpi_allreduce(msg, res, msglen/2, mpi_2real, mpi_minloc, comm%handle, ierr)
3563 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3564 msg = res
3565 DEALLOCATE (res)
3566 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3567#else
3568 mark_used(msg)
3569 mark_used(comm)
3570#endif
3571 CALL mp_timestop(handle)
3572 END SUBROUTINE mp_minloc_rv
3573
3574! **************************************************************************************************
3575!> \brief Finds the location of the maximal element in a vector.
3576!> \param[in,out] msg Find location of maximum element among these
3577!> data (input).
3578!> \param[in] comm Message passing environment identifier
3579!> \par MPI mapping
3580!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3581!> \par Invalid data types
3582!> This routine is invalid for (int_8) data!
3583! **************************************************************************************************
3584 SUBROUTINE mp_maxloc_dv(msg, comm)
3585 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3586 CLASS(mp_comm_type), INTENT(IN) :: comm
3587
3588 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_dv'
3589
3590 INTEGER :: handle
3591#if defined(__parallel)
3592 INTEGER :: ierr, msglen
3593 REAL(kind=real_8), ALLOCATABLE :: res(:)
3594#endif
3595
3596 IF ("d" .EQ. "l" .AND. real_8 .EQ. int_8) THEN
3597 cpabort("Maximal location not available with long integers @ "//routinen)
3598 END IF
3599 CALL mp_timeset(routinen, handle)
3600
3601#if defined(__parallel)
3602 msglen = SIZE(msg)
3603 ALLOCATE (res(1:msglen))
3604 CALL mpi_allreduce(msg, res, msglen/2, mpi_2double_precision, mpi_maxloc, comm%handle, ierr)
3605 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3606 msg = res
3607 DEALLOCATE (res)
3608 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3609#else
3610 mark_used(msg)
3611 mark_used(comm)
3612#endif
3613 CALL mp_timestop(handle)
3614 END SUBROUTINE mp_maxloc_dv
3615
3616! **************************************************************************************************
3617!> \brief Finds the location of the maximal element in a vector.
3618!> \param[in,out] msg Find location of maximum element among these
3619!> data (input).
3620!> \param[in] comm Message passing environment identifier
3621!> \par MPI mapping
3622!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3623!> \par Invalid data types
3624!> This routine is invalid for (int_8) data!
3625! **************************************************************************************************
3626 SUBROUTINE mp_maxloc_iv(msg, comm)
3627 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3628 CLASS(mp_comm_type), INTENT(IN) :: comm
3629
3630 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_iv'
3631
3632 INTEGER :: handle
3633#if defined(__parallel)
3634 INTEGER :: ierr, msglen
3635 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3636#endif
3637
3638 IF ("i" .EQ. "l" .AND. int_4 .EQ. int_8) THEN
3639 cpabort("Maximal location not available with long integers @ "//routinen)
3640 END IF
3641 CALL mp_timeset(routinen, handle)
3642
3643#if defined(__parallel)
3644 msglen = SIZE(msg)
3645 ALLOCATE (res(1:msglen))
3646 CALL mpi_allreduce(msg, res, msglen/2, mpi_2integer, mpi_maxloc, comm%handle, ierr)
3647 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3648 msg = res
3649 DEALLOCATE (res)
3650 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3651#else
3652 mark_used(msg)
3653 mark_used(comm)
3654#endif
3655 CALL mp_timestop(handle)
3656 END SUBROUTINE mp_maxloc_iv
3657
3658! **************************************************************************************************
3659!> \brief Finds the location of the maximal element in a vector.
3660!> \param[in,out] msg Find location of maximum element among these
3661!> data (input).
3662!> \param[in] comm Message passing environment identifier
3663!> \par MPI mapping
3664!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3665!> \par Invalid data types
3666!> This routine is invalid for (int_8) data!
3667! **************************************************************************************************
3668 SUBROUTINE mp_maxloc_lv(msg, comm)
3669 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3670 CLASS(mp_comm_type), INTENT(IN) :: comm
3671
3672 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_lv'
3673
3674 INTEGER :: handle
3675#if defined(__parallel)
3676 INTEGER :: ierr, msglen
3677 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3678#endif
3679
3680 IF ("l" .EQ. "l" .AND. int_8 .EQ. int_8) THEN
3681 cpabort("Maximal location not available with long integers @ "//routinen)
3682 END IF
3683 CALL mp_timeset(routinen, handle)
3684
3685#if defined(__parallel)
3686 msglen = SIZE(msg)
3687 ALLOCATE (res(1:msglen))
3688 CALL mpi_allreduce(msg, res, msglen/2, mpi_integer8, mpi_maxloc, comm%handle, ierr)
3689 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3690 msg = res
3691 DEALLOCATE (res)
3692 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3693#else
3694 mark_used(msg)
3695 mark_used(comm)
3696#endif
3697 CALL mp_timestop(handle)
3698 END SUBROUTINE mp_maxloc_lv
3699
3700! **************************************************************************************************
3701!> \brief Finds the location of the maximal element in a vector.
3702!> \param[in,out] msg Find location of maximum element among these
3703!> data (input).
3704!> \param[in] comm Message passing environment identifier
3705!> \par MPI mapping
3706!> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3707!> \par Invalid data types
3708!> This routine is invalid for (int_8) data!
3709! **************************************************************************************************
3710 SUBROUTINE mp_maxloc_rv(msg, comm)
3711 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3712 CLASS(mp_comm_type), INTENT(IN) :: comm
3713
3714 CHARACTER(len=*), PARAMETER :: routinen = 'mp_maxloc_rv'
3715
3716 INTEGER :: handle
3717#if defined(__parallel)
3718 INTEGER :: ierr, msglen
3719 REAL(kind=real_4), ALLOCATABLE :: res(:)
3720#endif
3721
3722 IF ("r" .EQ. "l" .AND. real_4 .EQ. int_8) THEN
3723 cpabort("Maximal location not available with long integers @ "//routinen)
3724 END IF
3725 CALL mp_timeset(routinen, handle)
3726
3727#if defined(__parallel)
3728 msglen = SIZE(msg)
3729 ALLOCATE (res(1:msglen))
3730 CALL mpi_allreduce(msg, res, msglen/2, mpi_2real, mpi_maxloc, comm%handle, ierr)
3731 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3732 msg = res
3733 DEALLOCATE (res)
3734 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3735#else
3736 mark_used(msg)
3737 mark_used(comm)
3738#endif
3739 CALL mp_timestop(handle)
3740 END SUBROUTINE mp_maxloc_rv
3741
3742! **************************************************************************************************
3743!> \brief Logical OR reduction
3744!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3745!> and resultant inclusive disjunction (output)
3746!> \param[in] comm Message passing environment identifier
3747!> \par MPI mapping
3748!> mpi_allreduce
3749! **************************************************************************************************
3750 SUBROUTINE mp_sum_b(msg, comm)
3751 LOGICAL, INTENT(INOUT) :: msg
3752 CLASS(mp_comm_type), INTENT(IN) :: comm
3753
3754 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_b'
3755
3756 INTEGER :: handle
3757#if defined(__parallel)
3758 INTEGER :: ierr, msglen
3759#endif
3760
3761 CALL mp_timeset(routinen, handle)
3762#if defined(__parallel)
3763 msglen = 1
3764 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, ierr)
3765 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3766#else
3767 mark_used(msg)
3768 mark_used(comm)
3769#endif
3770 CALL mp_timestop(handle)
3771 END SUBROUTINE mp_sum_b
3772
3773! **************************************************************************************************
3774!> \brief Logical OR reduction
3775!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3776!> and resultant inclusive disjunction (output)
3777!> \param[in] comm Message passing environment identifier
3778!> \par MPI mapping
3779!> mpi_allreduce
3780! **************************************************************************************************
3781 SUBROUTINE mp_sum_bv(msg, comm)
3782 LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: msg
3783 CLASS(mp_comm_type), INTENT(IN) :: comm
3784
3785 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_bv'
3786
3787 INTEGER :: handle
3788#if defined(__parallel)
3789 INTEGER :: ierr, msglen
3790#endif
3791
3792 CALL mp_timeset(routinen, handle)
3793#if defined(__parallel)
3794 msglen = SIZE(msg)
3795 IF (msglen .GT. 0) THEN
3796 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, ierr)
3797 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3798 END IF
3799#else
3800 mark_used(msg)
3801 mark_used(comm)
3802#endif
3803 CALL mp_timestop(handle)
3804 END SUBROUTINE mp_sum_bv
3805
3806! **************************************************************************************************
3807!> \brief Logical OR reduction
3808!> \param[in,out] msg Datum to perform inclusive disjunction (input)
3809!> and resultant inclusive disjunction (output)
3810!> \param[in] comm Message passing environment identifier
3811!> \param request ...
3812!> \par MPI mapping
3813!> mpi_allreduce
3814! **************************************************************************************************
3815 SUBROUTINE mp_isum_bv(msg, comm, request)
3816 LOGICAL, DIMENSION(:), INTENT(INOUT) :: msg
3817 CLASS(mp_comm_type), INTENT(IN) :: comm
3818 TYPE(mp_request_type), INTENT(INOUT) :: request
3819
3820 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_bv'
3821
3822 INTEGER :: handle
3823#if defined(__parallel)
3824 INTEGER :: ierr, msglen
3825#endif
3826
3827 CALL mp_timeset(routinen, handle)
3828#if defined(__parallel)
3829 msglen = SIZE(msg)
3830#if !defined(__GNUC__) || __GNUC__ >= 9
3831 cpassert(is_contiguous(msg))
3832#endif
3833
3834 IF (msglen .GT. 0) THEN
3835 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_logical, mpi_lor, comm%handle, request%handle, ierr)
3836 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
3837 ELSE
3838 request = mp_request_null
3839 END IF
3840#else
3841 mark_used(msg)
3842 mark_used(comm)
3843 request = mp_request_null
3844#endif
3845 CALL mp_timestop(handle)
3846 END SUBROUTINE mp_isum_bv
3847
3848! **************************************************************************************************
3849!> \brief Get Version of the MPI Library (MPI 3)
3850!> \param[out] version Version of the library,
3851!> declared as CHARACTER(LEN=mp_max_library_version_string)
3852!> \param[out] resultlen Length (in printable characters) of
3853!> the result returned in version (integer)
3854! **************************************************************************************************
3855 SUBROUTINE mp_get_library_version(version, resultlen)
3856 CHARACTER(len=*), INTENT(OUT) :: version
3857 INTEGER, INTENT(OUT) :: resultlen
3858
3859#if defined(__parallel)
3860 INTEGER :: ierr
3861#endif
3862
3863 version = ''
3864
3865#if defined(__parallel)
3866 ierr = 0
3867 CALL mpi_get_library_version(version, resultlen, ierr)
3868 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_get_library_version @ mp_get_library_version")
3869#else
3870 resultlen = 0
3871#endif
3872 END SUBROUTINE mp_get_library_version
3873
3874! **************************************************************************************************
3875!> \brief Opens a file
3876!> \param[in] groupid message passing environment identifier
3877!> \param[out] fh file handle (file storage unit)
3878!> \param[in] filepath path to the file
3879!> \param amode_status access mode
3880!> \param info ...
3881!> \par MPI-I/O mapping mpi_file_open
3882!> \par STREAM-I/O mapping OPEN
3883!>
3884!> \param[in](optional) info info object
3885!> \par History
3886!> 11.2012 created [Hossein Bani-Hashemian]
3887! **************************************************************************************************
3888 SUBROUTINE mp_file_open(groupid, fh, filepath, amode_status, info)
3889 CLASS(mp_comm_type), INTENT(IN) :: groupid
3890 CLASS(mp_file_type), INTENT(OUT) :: fh
3891 CHARACTER(len=*), INTENT(IN) :: filepath
3892 INTEGER, INTENT(IN) :: amode_status
3893 TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3894
3895#if defined(__parallel)
3896 INTEGER :: ierr
3897 mpi_info_type :: my_info
3898#else
3899 CHARACTER(LEN=10) :: fstatus, fposition
3900 INTEGER :: amode, handle, istat
3901 LOGICAL :: exists, is_open
3902#endif
3903
3904#if defined(__parallel)
3905 ierr = 0
3906 my_info = mpi_info_null
3907 IF (PRESENT(info)) my_info = info%handle
3908 CALL mpi_file_open(groupid%handle, filepath, amode_status, my_info, fh%handle, ierr)
3909 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3910 IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open")
3911#else
3912 mark_used(groupid)
3913 mark_used(info)
3914 amode = amode_status
3915 IF (amode .GT. file_amode_append) THEN
3916 fposition = "APPEND"
3917 amode = amode - file_amode_append
3918 ELSE
3919 fposition = "REWIND"
3920 END IF
3921 IF ((amode .EQ. file_amode_create) .OR. &
3922 (amode .EQ. file_amode_create + file_amode_wronly) .OR. &
3923 (amode .EQ. file_amode_create + file_amode_wronly + file_amode_excl)) THEN
3924 fstatus = "UNKNOWN"
3925 ELSE
3926 fstatus = "OLD"
3927 END IF
3928 ! Get a new unit number
3929 DO handle = 1, 999
3930 INQUIRE (unit=handle, exist=exists, opened=is_open, iostat=istat)
3931 IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) EXIT
3932 END DO
3933 OPEN (unit=handle, file=filepath, status=fstatus, access="STREAM", position=fposition)
3934 fh%handle = handle
3935#endif
3936 END SUBROUTINE mp_file_open
3937
3938! **************************************************************************************************
3939!> \brief Deletes a file. Auxiliary routine to emulate 'replace' action for mp_file_open.
3940!> Only the master processor should call this routine.
3941!> \param[in] filepath path to the file
3942!> \param[in](optional) info info object
3943!> \par History
3944!> 11.2017 created [Nico Holmberg]
3945! **************************************************************************************************
3946 SUBROUTINE mp_file_delete(filepath, info)
3947 CHARACTER(len=*), INTENT(IN) :: filepath
3948 TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3949
3950#if defined(__parallel)
3951 INTEGER :: ierr
3952 mpi_info_type :: my_info
3953 LOGICAL :: exists
3954
3955 ierr = 0
3956 my_info = mpi_info_null
3957 IF (PRESENT(info)) my_info = info%handle
3958 INQUIRE (file=filepath, exist=exists)
3959 IF (exists) CALL mpi_file_delete(filepath, my_info, ierr)
3960 IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete")
3961#else
3962 mark_used(filepath)
3963 mark_used(info)
3964 ! Explicit file delete not necessary, handled by subsequent call to open_file with action 'replace'
3965#endif
3966
3967 END SUBROUTINE mp_file_delete
3968
3969! **************************************************************************************************
3970!> \brief Closes a file
3971!> \param[in] fh file handle (file storage unit)
3972!> \par MPI-I/O mapping mpi_file_close
3973!> \par STREAM-I/O mapping CLOSE
3974!>
3975!> \par History
3976!> 11.2012 created [Hossein Bani-Hashemian]
3977! **************************************************************************************************
3978 SUBROUTINE mp_file_close(fh)
3979 CLASS(mp_file_type), INTENT(INOUT) :: fh
3980
3981#if defined(__parallel)
3982 INTEGER :: ierr
3983
3984 ierr = 0
3985 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
3986 CALL mpi_file_close(fh%handle, ierr)
3987 IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close")
3988#else
3989 CLOSE (fh%handle)
3990 fh%handle = mp_file_null_handle
3991#endif
3992 END SUBROUTINE mp_file_close
3993
3994 SUBROUTINE mp_file_assign(fh_new, fh_old)
3995 CLASS(mp_file_type), INTENT(OUT) :: fh_new
3996 CLASS(mp_file_type), INTENT(IN) :: fh_old
3997
3998 fh_new%handle = fh_old%handle
3999
4000 END SUBROUTINE
4001
4002! **************************************************************************************************
4003!> \brief Returns the file size
4004!> \param[in] fh file handle (file storage unit)
4005!> \param[out] file_size the file size
4006!> \par MPI-I/O mapping mpi_file_get_size
4007!> \par STREAM-I/O mapping INQUIRE
4008!>
4009!> \par History
4010!> 12.2012 created [Hossein Bani-Hashemian]
4011! **************************************************************************************************
4012 SUBROUTINE mp_file_get_size(fh, file_size)
4013 CLASS(mp_file_type), INTENT(IN) :: fh
4014 INTEGER(kind=file_offset), INTENT(OUT) :: file_size
4015
4016#if defined(__parallel)
4017 INTEGER :: ierr
4018#endif
4019
4020#if defined(__parallel)
4021 ierr = 0
4022 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4023 CALL mpi_file_get_size(fh%handle, file_size, ierr)
4024 IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size")
4025#else
4026 INQUIRE (unit=fh%handle, size=file_size)
4027#endif
4028 END SUBROUTINE mp_file_get_size
4029
4030! **************************************************************************************************
4031!> \brief Returns the file position
4032!> \param[in] fh file handle (file storage unit)
4033!> \param[out] file_size the file position
4034!> \par MPI-I/O mapping mpi_file_get_position
4035!> \par STREAM-I/O mapping INQUIRE
4036!>
4037!> \par History
4038!> 11.2017 created [Nico Holmberg]
4039! **************************************************************************************************
4040 SUBROUTINE mp_file_get_position(fh, pos)
4041 CLASS(mp_file_type), INTENT(IN) :: fh
4042 INTEGER(kind=file_offset), INTENT(OUT) :: pos
4043
4044#if defined(__parallel)
4045 INTEGER :: ierr
4046#endif
4047
4048#if defined(__parallel)
4049 ierr = 0
4050 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4051 CALL mpi_file_get_position(fh%handle, pos, ierr)
4052 IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position")
4053#else
4054 INQUIRE (unit=fh%handle, pos=pos)
4055#endif
4056 END SUBROUTINE mp_file_get_position
4057
4058! **************************************************************************************************
4059!> \brief (parallel) Blocking individual file write using explicit offsets
4060!> (serial) Unformatted stream write
4061!> \param[in] fh file handle (file storage unit)
4062!> \param[in] offset file offset (position)
4063!> \param[in] msg data to be written to the file
4064!> \param msglen ...
4065!> \par MPI-I/O mapping mpi_file_write_at
4066!> \par STREAM-I/O mapping WRITE
4067!> \param[in](optional) msglen number of the elements of data
4068! **************************************************************************************************
4069 SUBROUTINE mp_file_write_at_chv(fh, offset, msg, msglen)
4070 CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
4071 CLASS(mp_file_type), INTENT(IN) :: fh
4072 INTEGER, INTENT(IN), OPTIONAL :: msglen
4073 INTEGER(kind=file_offset), INTENT(IN) :: offset
4074
4075#if defined(__parallel)
4076 INTEGER :: ierr, msg_len
4077#endif
4078
4079#if defined(__parallel)
4080 msg_len = SIZE(msg)
4081 IF (PRESENT(msglen)) msg_len = msglen
4082 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4083 IF (ierr .NE. 0) &
4084 cpabort("mpi_file_write_at_chv @ mp_file_write_at_chv")
4085#else
4086 mark_used(msglen)
4087 WRITE (unit=fh%handle, pos=offset + 1) msg
4088#endif
4089 END SUBROUTINE mp_file_write_at_chv
4090
4091! **************************************************************************************************
4092!> \brief ...
4093!> \param fh ...
4094!> \param offset ...
4095!> \param msg ...
4096! **************************************************************************************************
4097 SUBROUTINE mp_file_write_at_ch(fh, offset, msg)
4098 CHARACTER(LEN=*), INTENT(IN) :: msg
4099 CLASS(mp_file_type), INTENT(IN) :: fh
4100 INTEGER(kind=file_offset), INTENT(IN) :: offset
4101
4102#if defined(__parallel)
4103 INTEGER :: ierr
4104#endif
4105
4106#if defined(__parallel)
4107 CALL mpi_file_write_at(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4108 IF (ierr .NE. 0) &
4109 cpabort("mpi_file_write_at_ch @ mp_file_write_at_ch")
4110#else
4111 WRITE (unit=fh%handle, pos=offset + 1) msg
4112#endif
4113 END SUBROUTINE mp_file_write_at_ch
4114
4115! **************************************************************************************************
4116!> \brief (parallel) Blocking collective file write using explicit offsets
4117!> (serial) Unformatted stream write
4118!> \param fh ...
4119!> \param offset ...
4120!> \param msg ...
4121!> \param msglen ...
4122!> \par MPI-I/O mapping mpi_file_write_at_all
4123!> \par STREAM-I/O mapping WRITE
4124! **************************************************************************************************
4125 SUBROUTINE mp_file_write_at_all_chv(fh, offset, msg, msglen)
4126 CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
4127 CLASS(mp_file_type), INTENT(IN) :: fh
4128 INTEGER, INTENT(IN), OPTIONAL :: msglen
4129 INTEGER(kind=file_offset), INTENT(IN) :: offset
4130
4131#if defined(__parallel)
4132 INTEGER :: ierr, msg_len
4133#endif
4134
4135#if defined(__parallel)
4136 msg_len = SIZE(msg)
4137 IF (PRESENT(msglen)) msg_len = msglen
4138 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4139 IF (ierr .NE. 0) &
4140 cpabort("mpi_file_write_at_all_chv @ mp_file_write_at_all_chv")
4141#else
4142 mark_used(msglen)
4143 WRITE (unit=fh%handle, pos=offset + 1) msg
4144#endif
4145 END SUBROUTINE mp_file_write_at_all_chv
4146
4147! **************************************************************************************************
4148!> \brief wrapper to MPI_File_write_at_all
4149!> \param fh ...
4150!> \param offset ...
4151!> \param msg ...
4152! **************************************************************************************************
4153 SUBROUTINE mp_file_write_at_all_ch(fh, offset, msg)
4154 CHARACTER(LEN=*), INTENT(IN) :: msg
4155 CLASS(mp_file_type), INTENT(IN) :: fh
4156 INTEGER(kind=file_offset), INTENT(IN) :: offset
4157
4158#if defined(__parallel)
4159 INTEGER :: ierr
4160#endif
4161
4162#if defined(__parallel)
4163 CALL mpi_file_write_at_all(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4164 IF (ierr .NE. 0) &
4165 cpabort("mpi_file_write_at_all_ch @ mp_file_write_at_all_ch")
4166#else
4167 WRITE (unit=fh%handle, pos=offset + 1) msg
4168#endif
4169 END SUBROUTINE mp_file_write_at_all_ch
4170
4171! **************************************************************************************************
4172!> \brief (parallel) Blocking individual file read using explicit offsets
4173!> (serial) Unformatted stream read
4174!> \param[in] fh file handle (file storage unit)
4175!> \param[in] offset file offset (position)
4176!> \param[out] msg data to be read from the file
4177!> \param msglen ...
4178!> \par MPI-I/O mapping mpi_file_read_at
4179!> \par STREAM-I/O mapping READ
4180!> \param[in](optional) msglen number of elements of data
4181! **************************************************************************************************
4182 SUBROUTINE mp_file_read_at_chv(fh, offset, msg, msglen)
4183 CHARACTER, CONTIGUOUS, INTENT(OUT) :: msg(:)
4184 CLASS(mp_file_type), INTENT(IN) :: fh
4185 INTEGER, INTENT(IN), OPTIONAL :: msglen
4186 INTEGER(kind=file_offset), INTENT(IN) :: offset
4187
4188#if defined(__parallel)
4189 INTEGER :: ierr, msg_len
4190#endif
4191
4192#if defined(__parallel)
4193 msg_len = SIZE(msg)
4194 IF (PRESENT(msglen)) msg_len = msglen
4195 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4196 IF (ierr .NE. 0) &
4197 cpabort("mpi_file_read_at_chv @ mp_file_read_at_chv")
4198#else
4199 mark_used(msglen)
4200 READ (unit=fh%handle, pos=offset + 1) msg
4201#endif
4202 END SUBROUTINE mp_file_read_at_chv
4203
4204! **************************************************************************************************
4205!> \brief wrapper to MPI_File_read_at
4206!> \param fh ...
4207!> \param offset ...
4208!> \param msg ...
4209! **************************************************************************************************
4210 SUBROUTINE mp_file_read_at_ch(fh, offset, msg)
4211 CHARACTER(LEN=*), INTENT(OUT) :: msg
4212 CLASS(mp_file_type), INTENT(IN) :: fh
4213 INTEGER(kind=file_offset), INTENT(IN) :: offset
4214
4215#if defined(__parallel)
4216 INTEGER :: ierr
4217#endif
4218
4219#if defined(__parallel)
4220 CALL mpi_file_read_at(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4221 IF (ierr .NE. 0) &
4222 cpabort("mpi_file_read_at_ch @ mp_file_read_at_ch")
4223#else
4224 READ (unit=fh%handle, pos=offset + 1) msg
4225#endif
4226 END SUBROUTINE mp_file_read_at_ch
4227
4228! **************************************************************************************************
4229!> \brief (parallel) Blocking collective file read using explicit offsets
4230!> (serial) Unformatted stream read
4231!> \param fh ...
4232!> \param offset ...
4233!> \param msg ...
4234!> \param msglen ...
4235!> \par MPI-I/O mapping mpi_file_read_at_all
4236!> \par STREAM-I/O mapping READ
4237! **************************************************************************************************
4238 SUBROUTINE mp_file_read_at_all_chv(fh, offset, msg, msglen)
4239 CHARACTER, INTENT(OUT) :: msg(:)
4240 CLASS(mp_file_type), INTENT(IN) :: fh
4241 INTEGER, INTENT(IN), OPTIONAL :: msglen
4242 INTEGER(kind=file_offset), INTENT(IN) :: offset
4243
4244#if defined(__parallel)
4245 INTEGER :: ierr, msg_len
4246#endif
4247
4248#if defined(__parallel)
4249 msg_len = SIZE(msg)
4250 IF (PRESENT(msglen)) msg_len = msglen
4251 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_character, mpi_status_ignore, ierr)
4252 IF (ierr .NE. 0) &
4253 cpabort("mpi_file_read_at_all_chv @ mp_file_read_at_all_chv")
4254#else
4255 mark_used(msglen)
4256 READ (unit=fh%handle, pos=offset + 1) msg
4257#endif
4258 END SUBROUTINE mp_file_read_at_all_chv
4259
4260! **************************************************************************************************
4261!> \brief wrapper to MPI_File_read_at_all
4262!> \param fh ...
4263!> \param offset ...
4264!> \param msg ...
4265! **************************************************************************************************
4266 SUBROUTINE mp_file_read_at_all_ch(fh, offset, msg)
4267 CHARACTER(LEN=*), INTENT(OUT) :: msg
4268 CLASS(mp_file_type), INTENT(IN) :: fh
4269 INTEGER(kind=file_offset), INTENT(IN) :: offset
4270
4271#if defined(__parallel)
4272 INTEGER :: ierr
4273#endif
4274
4275#if defined(__parallel)
4276 CALL mpi_file_read_at_all(fh%handle, offset, msg, len(msg), mpi_character, mpi_status_ignore, ierr)
4277 IF (ierr .NE. 0) &
4278 cpabort("mpi_file_read_at_all_ch @ mp_file_read_at_all_ch")
4279#else
4280 READ (unit=fh%handle, pos=offset + 1) msg
4281#endif
4282 END SUBROUTINE mp_file_read_at_all_ch
4283
4284! **************************************************************************************************
4285!> \brief Returns the size of a data type in bytes
4286!> \param[in] type_descriptor data type
4287!> \param[out] type_size size of the data type
4288!> \par MPI mapping
4289!> mpi_type_size
4290!>
4291! **************************************************************************************************
4292 SUBROUTINE mp_type_size(type_descriptor, type_size)
4293 TYPE(mp_type_descriptor_type), INTENT(IN) :: type_descriptor
4294 INTEGER, INTENT(OUT) :: type_size
4295
4296#if defined(__parallel)
4297 INTEGER :: ierr
4298
4299 ierr = 0
4300 CALL mpi_type_size(type_descriptor%type_handle, type_size, ierr)
4301 IF (ierr .NE. 0) &
4302 cpabort("mpi_type_size failed @ mp_type_size")
4303#else
4304 SELECT CASE (type_descriptor%type_handle)
4305 CASE (1)
4306 type_size = real_4_size
4307 CASE (3)
4308 type_size = real_8_size
4309 CASE (5)
4310 type_size = 2*real_4_size
4311 CASE (7)
4312 type_size = 2*real_8_size
4313 END SELECT
4314#endif
4315 END SUBROUTINE mp_type_size
4316
4317! **************************************************************************************************
4318!> \brief wrapper to MPI_Type_create_struct
4319!> \param subtypes ...
4320!> \param vector_descriptor ...
4321!> \param index_descriptor ...
4322!> \return ...
4323! **************************************************************************************************
4324 FUNCTION mp_type_make_struct(subtypes, &
4325 vector_descriptor, index_descriptor) &
4326 result(type_descriptor)
4327 TYPE(mp_type_descriptor_type), &
4328 DIMENSION(:), INTENT(IN) :: subtypes
4329 INTEGER, DIMENSION(2), INTENT(IN), &
4330 OPTIONAL :: vector_descriptor
4331 TYPE(mp_indexing_meta_type), &
4332 INTENT(IN), OPTIONAL :: index_descriptor
4333 TYPE(mp_type_descriptor_type) :: type_descriptor
4334
4335 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_struct'
4336
4337 INTEGER :: i, n
4338 INTEGER, ALLOCATABLE, DIMENSION(:) :: lengths
4339#if defined(__parallel)
4340 INTEGER :: ierr
4341 INTEGER(kind=mpi_address_kind), &
4342 ALLOCATABLE, DIMENSION(:) :: displacements
4343#endif
4344 mpi_data_type, ALLOCATABLE, DIMENSION(:) :: old_types
4345
4346 n = SIZE(subtypes)
4347 type_descriptor%length = 1
4348#if defined(__parallel)
4349 ierr = 0
4350 CALL mpi_get_address(mpi_bottom, type_descriptor%base, ierr)
4351 IF (ierr /= 0) &
4352 cpabort("MPI_get_address @ "//routinen)
4353 ALLOCATE (displacements(n))
4354#endif
4355 type_descriptor%vector_descriptor(1:2) = 1
4356 type_descriptor%has_indexing = .false.
4357 ALLOCATE (type_descriptor%subtype(n))
4358 type_descriptor%subtype(:) = subtypes(:)
4359 ALLOCATE (lengths(n), old_types(n))
4360 DO i = 1, SIZE(subtypes)
4361#if defined(__parallel)
4362 displacements(i) = subtypes(i)%base
4363#endif
4364 old_types(i) = subtypes(i)%type_handle
4365 lengths(i) = subtypes(i)%length
4366 END DO
4367#if defined(__parallel)
4368 CALL mpi_type_create_struct(n, &
4369 lengths, displacements, old_types, &
4370 type_descriptor%type_handle, ierr)
4371 IF (ierr /= 0) &
4372 cpabort("MPI_Type_create_struct @ "//routinen)
4373 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4374 IF (ierr /= 0) &
4375 cpabort("MPI_Type_commit @ "//routinen)
4376#endif
4377 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
4378 cpabort(routinen//" Vectors and indices NYI")
4379 END IF
4380 END FUNCTION mp_type_make_struct
4381
4382! **************************************************************************************************
4383!> \brief wrapper to MPI_Type_free
4384!> \param type_descriptor ...
4385! **************************************************************************************************
4386 RECURSIVE SUBROUTINE mp_type_free_m(type_descriptor)
4387 TYPE(mp_type_descriptor_type), INTENT(inout) :: type_descriptor
4388
4389 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_free_m'
4390
4391 INTEGER :: handle, i
4392#if defined(__parallel)
4393 INTEGER :: ierr
4394#endif
4395
4396 CALL mp_timeset(routinen, handle)
4397
4398 ! If the subtype is associated, then it's a user-defined data type.
4399
4400 IF (ASSOCIATED(type_descriptor%subtype)) THEN
4401 DO i = 1, SIZE(type_descriptor%subtype)
4402 CALL mp_type_free_m(type_descriptor%subtype(i))
4403 END DO
4404 DEALLOCATE (type_descriptor%subtype)
4405 END IF
4406#if defined(__parallel)
4407 ierr = 0
4408 CALL mpi_type_free(type_descriptor%type_handle, ierr)
4409 IF (ierr /= 0) &
4410 cpabort("MPI_Type_free @ "//routinen)
4411#endif
4412
4413 CALL mp_timestop(handle)
4414
4415 END SUBROUTINE mp_type_free_m
4416
4417! **************************************************************************************************
4418!> \brief ...
4419!> \param type_descriptors ...
4420! **************************************************************************************************
4421 SUBROUTINE mp_type_free_v(type_descriptors)
4422 TYPE(mp_type_descriptor_type), DIMENSION(:), &
4423 INTENT(inout) :: type_descriptors
4424
4425 INTEGER :: i
4426
4427 DO i = 1, SIZE(type_descriptors)
4428 CALL mp_type_free(type_descriptors(i))
4429 END DO
4430
4431 END SUBROUTINE mp_type_free_v
4432
4433! **************************************************************************************************
4434!> \brief Creates an indexed MPI type for arrays of strings using bytes for spacing (hindexed type)
4435!> \param count number of array blocks to read
4436!> \param lengths lengths of each array block
4437!> \param displs byte offsets for array blocks
4438!> \return container holding the created type
4439!> \author Nico Holmberg [05.2017]
4440! **************************************************************************************************
4441 FUNCTION mp_file_type_hindexed_make_chv(count, lengths, displs) &
4442 result(type_descriptor)
4443 INTEGER, INTENT(IN) :: count
4444 INTEGER, DIMENSION(1:count), &
4445 INTENT(IN), TARGET :: lengths
4446 INTEGER(kind=file_offset), &
4447 DIMENSION(1:count), INTENT(in), TARGET :: displs
4448 TYPE(mp_file_descriptor_type) :: type_descriptor
4449
4450 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_hindexed_make_chv'
4451
4452 INTEGER :: ierr, handle
4453
4454 ierr = 0
4455 CALL mp_timeset(routinen, handle)
4456
4457#if defined(__parallel)
4458 CALL mpi_type_create_hindexed(count, lengths, int(displs, kind=address_kind), mpi_character, &
4459 type_descriptor%type_handle, ierr)
4460 IF (ierr /= 0) &
4461 cpabort("MPI_Type_create_hindexed @ "//routinen)
4462 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4463 IF (ierr /= 0) &
4464 cpabort("MPI_Type_commit @ "//routinen)
4465#else
4466 type_descriptor%type_handle = 68
4467#endif
4468 type_descriptor%length = count
4469 type_descriptor%has_indexing = .true.
4470 type_descriptor%index_descriptor%index => lengths
4471 type_descriptor%index_descriptor%chunks => displs
4472
4473 CALL mp_timestop(handle)
4474
4475 END FUNCTION mp_file_type_hindexed_make_chv
4476
4477! **************************************************************************************************
4478!> \brief Uses a previously created indexed MPI character type to tell the MPI processes
4479!> how to partition (set_view) an opened file
4480!> \param fh the file handle associated with the input file
4481!> \param offset global offset determining where the relevant data begins
4482!> \param type_descriptor container for the MPI type
4483!> \author Nico Holmberg [05.2017]
4484! **************************************************************************************************
4485 SUBROUTINE mp_file_type_set_view_chv(fh, offset, type_descriptor)
4486 TYPE(mp_file_type), INTENT(IN) :: fh
4487 INTEGER(kind=file_offset), INTENT(IN) :: offset
4488 TYPE(mp_file_descriptor_type) :: type_descriptor
4489
4490 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_set_view_chv'
4491
4492 INTEGER :: handle
4493#if defined(__parallel)
4494 INTEGER :: ierr
4495#endif
4496
4497 CALL mp_timeset(routinen, handle)
4498
4499#if defined(__parallel)
4500 ierr = 0
4501 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4502 CALL mpi_file_set_view(fh%handle, offset, mpi_character, &
4503 type_descriptor%type_handle, "native", mpi_info_null, ierr)
4504 IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view")
4505#else
4506 ! Uses absolute offsets stored in mp_file_descriptor_type
4507 mark_used(fh)
4508 mark_used(offset)
4509 mark_used(type_descriptor)
4510#endif
4511
4512 CALL mp_timestop(handle)
4513
4514 END SUBROUTINE mp_file_type_set_view_chv
4515
4516! **************************************************************************************************
4517!> \brief (parallel) Collective, blocking read of a character array from a file. File access pattern
4518! determined by a previously set file view.
4519!> (serial) Unformatted stream read using explicit offsets
4520!> \param fh the file handle associated with the input file
4521!> \param msglen the message length of an individual vector component
4522!> \param ndims the number of vector components
4523!> \param buffer the buffer where the data is placed
4524!> \param type_descriptor container for the MPI type
4525!> \author Nico Holmberg [05.2017]
4526! **************************************************************************************************
4527 SUBROUTINE mp_file_read_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4528 CLASS(mp_file_type), INTENT(IN) :: fh
4529 INTEGER, INTENT(IN) :: msglen
4530 INTEGER, INTENT(IN) :: ndims
4531 CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(INOUT) :: buffer
4532 TYPE(mp_file_descriptor_type), &
4533 INTENT(IN), OPTIONAL :: type_descriptor
4534
4535 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_read_all_chv'
4536
4537 INTEGER :: handle
4538#if defined(__parallel)
4539 INTEGER:: ierr
4540#else
4541 INTEGER :: i
4542#endif
4543
4544 CALL mp_timeset(routinen, handle)
4545
4546#if defined(__parallel)
4547 ierr = 0
4548 mark_used(type_descriptor)
4549 CALL mpi_file_read_all(fh%handle, buffer, ndims*msglen, mpi_character, mpi_status_ignore, ierr)
4550 IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all")
4551 CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4552#else
4553 mark_used(msglen)
4554 mark_used(ndims)
4555 IF (.NOT. PRESENT(type_descriptor)) &
4556 CALL cp_abort(__location__, &
4557 "Container for mp_file_descriptor_type must be present in serial call.")
4558 IF (.NOT. type_descriptor%has_indexing) &
4559 CALL cp_abort(__location__, &
4560 "File view has not been set in mp_file_descriptor_type.")
4561 ! Use explicit offsets
4562 DO i = 1, ndims
4563 READ (fh%handle, pos=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4564 END DO
4565#endif
4566
4567 CALL mp_timestop(handle)
4568
4569 END SUBROUTINE mp_file_read_all_chv
4570
4571! **************************************************************************************************
4572!> \brief (parallel) Collective, blocking write of a character array to a file. File access pattern
4573! determined by a previously set file view.
4574!> (serial) Unformatted stream write using explicit offsets
4575!> \param fh the file handle associated with the output file
4576!> \param msglen the message length of an individual vector component
4577!> \param ndims the number of vector components
4578!> \param buffer the buffer where the data is placed
4579!> \param type_descriptor container for the MPI type
4580!> \author Nico Holmberg [05.2017]
4581! **************************************************************************************************
4582 SUBROUTINE mp_file_write_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4583 CLASS(mp_file_type), INTENT(IN) :: fh
4584 INTEGER, INTENT(IN) :: msglen
4585 INTEGER, INTENT(IN) :: ndims
4586 CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(IN) :: buffer
4587 TYPE(mp_file_descriptor_type), &
4588 INTENT(IN), OPTIONAL :: type_descriptor
4589
4590 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_write_all_chv'
4591
4592 INTEGER :: handle
4593#if defined(__parallel)
4594 INTEGER :: ierr
4595#else
4596 INTEGER :: i
4597#endif
4598
4599 CALL mp_timeset(routinen, handle)
4600
4601#if defined(__parallel)
4602 mark_used(type_descriptor)
4603 CALL mpi_file_set_errhandler(fh%handle, mpi_errors_return, ierr)
4604 CALL mpi_file_write_all(fh%handle, buffer, ndims*msglen, mpi_character, mpi_status_ignore, ierr)
4605 IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all")
4606 CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4607#else
4608 mark_used(msglen)
4609 mark_used(ndims)
4610 IF (.NOT. PRESENT(type_descriptor)) &
4611 CALL cp_abort(__location__, &
4612 "Container for mp_file_descriptor_type must be present in serial call.")
4613 IF (.NOT. type_descriptor%has_indexing) &
4614 CALL cp_abort(__location__, &
4615 "File view has not been set in mp_file_descriptor_type.")
4616 ! Use explicit offsets
4617 DO i = 1, ndims
4618 WRITE (fh%handle, pos=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4619 END DO
4620#endif
4621
4622 CALL mp_timestop(handle)
4623
4624 END SUBROUTINE mp_file_write_all_chv
4625
4626! **************************************************************************************************
4627!> \brief Releases the type used for MPI I/O
4628!> \param type_descriptor the container for the MPI type
4629!> \author Nico Holmberg [05.2017]
4630! **************************************************************************************************
4631 SUBROUTINE mp_file_type_free(type_descriptor)
4632 TYPE(mp_file_descriptor_type) :: type_descriptor
4633
4634 CHARACTER(len=*), PARAMETER :: routinen = 'mp_file_type_free'
4635
4636 INTEGER :: handle
4637#if defined(__parallel)
4638 INTEGER :: ierr
4639#endif
4640
4641 CALL mp_timeset(routinen, handle)
4642
4643#if defined(__parallel)
4644 CALL mpi_type_free(type_descriptor%type_handle, ierr)
4645 IF (ierr /= 0) &
4646 cpabort("MPI_Type_free @ "//routinen)
4647#endif
4648#if defined(__parallel) && defined(__MPI_F08)
4649 type_descriptor%type_handle%mpi_val = -1
4650#else
4651 type_descriptor%type_handle = -1
4652#endif
4653 type_descriptor%length = -1
4654 IF (type_descriptor%has_indexing) THEN
4655 NULLIFY (type_descriptor%index_descriptor%index)
4656 NULLIFY (type_descriptor%index_descriptor%chunks)
4657 type_descriptor%has_indexing = .false.
4658 END IF
4659
4660 CALL mp_timestop(handle)
4661
4662 END SUBROUTINE mp_file_type_free
4663
4664! **************************************************************************************************
4665!> \brief (parallel) Utility routine to determine MPI file access mode based on variables
4666! that in the serial case would get passed to the intrinsic OPEN
4667!> (serial) No action
4668!> \param mpi_io flag that determines if MPI I/O will actually be used
4669!> \param replace flag that indicates whether file needs to be deleted prior to opening it
4670!> \param amode the MPI I/O access mode
4671!> \param form formatted or unformatted data?
4672!> \param action the variable that determines what to do with file
4673!> \param status the status flag:
4674!> \param position should the file be appended or rewound
4675!> \author Nico Holmberg [11.2017]
4676! **************************************************************************************************
4677 SUBROUTINE mp_file_get_amode(mpi_io, replace, amode, form, action, status, position)
4678 LOGICAL, INTENT(INOUT) :: mpi_io, replace
4679 INTEGER, INTENT(OUT) :: amode
4680 CHARACTER(len=*), INTENT(IN) :: form, action, status, position
4681
4682 amode = -1
4683#if defined(__parallel)
4684 ! Disable mpi io for unformatted access
4685 SELECT CASE (form)
4686 CASE ("FORMATTED")
4687 ! Do nothing
4688 CASE ("UNFORMATTED")
4689 mpi_io = .false.
4690 CASE DEFAULT
4691 cpabort("Unknown MPI file form requested.")
4692 END SELECT
4693 ! Determine file access mode (limited set of allowed choices)
4694 SELECT CASE (action)
4695 CASE ("WRITE")
4696 amode = file_amode_wronly
4697 SELECT CASE (status)
4698 CASE ("NEW")
4699 ! Try to open new file for writing, crash if file already exists
4700 amode = amode + file_amode_create + file_amode_excl
4701 CASE ("UNKNOWN")
4702 ! Open file for writing and create it if file does not exist
4703 amode = amode + file_amode_create
4704 SELECT CASE (position)
4705 CASE ("APPEND")
4706 ! Append existing file
4707 amode = amode + file_amode_append
4708 CASE ("REWIND", "ASIS")
4709 ! Do nothing
4710 CASE DEFAULT
4711 cpabort("Unknown MPI file position requested.")
4712 END SELECT
4713 CASE ("OLD")
4714 SELECT CASE (position)
4715 CASE ("APPEND")
4716 ! Append existing file
4717 amode = amode + file_amode_append
4718 CASE ("REWIND", "ASIS")
4719 ! Do nothing
4720 CASE DEFAULT
4721 cpabort("Unknown MPI file position requested.")
4722 END SELECT
4723 CASE ("REPLACE")
4724 ! Overwrite existing file. Must delete existing file first
4725 amode = amode + file_amode_create
4726 replace = .true.
4727 CASE ("SCRATCH")
4728 ! Disable
4729 mpi_io = .false.
4730 CASE DEFAULT
4731 cpabort("Unknown MPI file status requested.")
4732 END SELECT
4733 CASE ("READ")
4734 amode = file_amode_rdonly
4735 SELECT CASE (status)
4736 CASE ("NEW")
4737 cpabort("Cannot read from 'NEW' file.")
4738 CASE ("REPLACE")
4739 cpabort("Illegal status 'REPLACE' for read.")
4740 CASE ("UNKNOWN", "OLD")
4741 ! Do nothing
4742 CASE ("SCRATCH")
4743 ! Disable
4744 mpi_io = .false.
4745 CASE DEFAULT
4746 cpabort("Unknown MPI file status requested.")
4747 END SELECT
4748 CASE ("READWRITE")
4749 amode = file_amode_rdwr
4750 SELECT CASE (status)
4751 CASE ("NEW")
4752 ! Try to open new file, crash if file already exists
4753 amode = amode + file_amode_create + file_amode_excl
4754 CASE ("UNKNOWN")
4755 ! Open file and create it if file does not exist
4756 amode = amode + file_amode_create
4757 SELECT CASE (position)
4758 CASE ("APPEND")
4759 ! Append existing file
4760 amode = amode + file_amode_append
4761 CASE ("REWIND", "ASIS")
4762 ! Do nothing
4763 CASE DEFAULT
4764 cpabort("Unknown MPI file position requested.")
4765 END SELECT
4766 CASE ("OLD")
4767 SELECT CASE (position)
4768 CASE ("APPEND")
4769 ! Append existing file
4770 amode = amode + file_amode_append
4771 CASE ("REWIND", "ASIS")
4772 ! Do nothing
4773 CASE DEFAULT
4774 cpabort("Unknown MPI file position requested.")
4775 END SELECT
4776 CASE ("REPLACE")
4777 ! Overwrite existing file. Must delete existing file first
4778 amode = amode + file_amode_create
4779 replace = .true.
4780 CASE ("SCRATCH")
4781 ! Disable
4782 mpi_io = .false.
4783 CASE DEFAULT
4784 cpabort("Unknown MPI file status requested.")
4785 END SELECT
4786 CASE DEFAULT
4787 cpabort("Unknown MPI file action requested.")
4788 END SELECT
4789#else
4790 mark_used(replace)
4791 mark_used(form)
4792 mark_used(position)
4793 mark_used(status)
4794 mark_used(action)
4795 mpi_io = .false.
4796#endif
4797
4798 END SUBROUTINE mp_file_get_amode
4799
4800! **************************************************************************************************
4801!> \brief Non-blocking send of custom type
4802!> \param msgin ...
4803!> \param dest ...
4804!> \param comm ...
4805!> \param request ...
4806!> \param tag ...
4807! **************************************************************************************************
4808 SUBROUTINE mp_isend_custom(msgin, dest, comm, request, tag)
4809 TYPE(mp_type_descriptor_type), INTENT(IN) :: msgin
4810 INTEGER, INTENT(IN) :: dest
4811 CLASS(mp_comm_type), INTENT(IN) :: comm
4812 TYPE(mp_request_type), INTENT(out) :: request
4813 INTEGER, INTENT(in), OPTIONAL :: tag
4814
4815 INTEGER :: ierr, my_tag
4816
4817 ierr = 0
4818 my_tag = 0
4819
4820#if defined(__parallel)
4821 IF (PRESENT(tag)) my_tag = tag
4822
4823 CALL mpi_isend(mpi_bottom, 1, msgin%type_handle, dest, my_tag, &
4824 comm%handle, request%handle, ierr)
4825 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ mp_isend_custom")
4826#else
4827 mark_used(msgin)
4828 mark_used(dest)
4829 mark_used(comm)
4830 mark_used(tag)
4831 ierr = 1
4832 request = mp_request_null
4833 CALL mp_stop(ierr, "mp_isend called in non parallel case")
4834#endif
4835 END SUBROUTINE mp_isend_custom
4836
4837! **************************************************************************************************
4838!> \brief Non-blocking receive of vector data
4839!> \param msgout ...
4840!> \param source ...
4841!> \param comm ...
4842!> \param request ...
4843!> \param tag ...
4844! **************************************************************************************************
4845 SUBROUTINE mp_irecv_custom(msgout, source, comm, request, tag)
4846 TYPE(mp_type_descriptor_type), INTENT(INOUT) :: msgout
4847 INTEGER, INTENT(IN) :: source
4848 CLASS(mp_comm_type), INTENT(IN) :: comm
4849 TYPE(mp_request_type), INTENT(out) :: request
4850 INTEGER, INTENT(in), OPTIONAL :: tag
4851
4852 INTEGER :: ierr, my_tag
4853
4854 ierr = 0
4855 my_tag = 0
4856
4857#if defined(__parallel)
4858 IF (PRESENT(tag)) my_tag = tag
4859
4860 CALL mpi_irecv(mpi_bottom, 1, msgout%type_handle, source, my_tag, &
4861 comm%handle, request%handle, ierr)
4862 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ mp_irecv_custom")
4863#else
4864 mark_used(msgout)
4865 mark_used(source)
4866 mark_used(comm)
4867 mark_used(tag)
4868 ierr = 1
4869 request = mp_request_null
4870 cpabort("mp_irecv called in non parallel case")
4871#endif
4872 END SUBROUTINE mp_irecv_custom
4873
4874! **************************************************************************************************
4875!> \brief Window free
4876!> \param win ...
4877! **************************************************************************************************
4878 SUBROUTINE mp_win_free(win)
4879 CLASS(mp_win_type), INTENT(INOUT) :: win
4880
4881 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_free'
4882
4883 INTEGER :: handle
4884#if defined(__parallel)
4885 INTEGER :: ierr
4886#endif
4887
4888 CALL mp_timeset(routinen, handle)
4889
4890#if defined(__parallel)
4891 ierr = 0
4892 CALL mpi_win_free(win%handle, ierr)
4893 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_free @ "//routinen)
4894
4895 CALL add_perf(perf_id=21, count=1)
4896#else
4897 win%handle = mp_win_null_handle
4898#endif
4899 CALL mp_timestop(handle)
4900 END SUBROUTINE mp_win_free
4901
4902 SUBROUTINE mp_win_assign(win_new, win_old)
4903 CLASS(mp_win_type), INTENT(OUT) :: win_new
4904 CLASS(mp_win_type), INTENT(IN) :: win_old
4905
4906 win_new%handle = win_old%handle
4907
4908 END SUBROUTINE mp_win_assign
4909
4910! **************************************************************************************************
4911!> \brief Window flush
4912!> \param win ...
4913! **************************************************************************************************
4914 SUBROUTINE mp_win_flush_all(win)
4915 CLASS(mp_win_type), INTENT(IN) :: win
4916
4917 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_flush_all'
4918
4919 INTEGER :: handle, ierr
4920
4921 ierr = 0
4922 CALL mp_timeset(routinen, handle)
4923
4924#if defined(__parallel)
4925 CALL mpi_win_flush_all(win%handle, ierr)
4926 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_flush_all @ "//routinen)
4927#else
4928 mark_used(win)
4929#endif
4930 CALL mp_timestop(handle)
4931 END SUBROUTINE mp_win_flush_all
4932
4933! **************************************************************************************************
4934!> \brief Window lock
4935!> \param win ...
4936! **************************************************************************************************
4937 SUBROUTINE mp_win_lock_all(win)
4938 CLASS(mp_win_type), INTENT(IN) :: win
4939
4940 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_lock_all'
4941
4942 INTEGER :: handle, ierr
4943
4944 ierr = 0
4945 CALL mp_timeset(routinen, handle)
4946
4947#if defined(__parallel)
4948
4949 CALL mpi_win_lock_all(mpi_mode_nocheck, win%handle, ierr)
4950 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_lock_all @ "//routinen)
4951
4952 CALL add_perf(perf_id=19, count=1)
4953#else
4954 mark_used(win)
4955#endif
4956 CALL mp_timestop(handle)
4957 END SUBROUTINE mp_win_lock_all
4958
4959! **************************************************************************************************
4960!> \brief Window lock
4961!> \param win ...
4962! **************************************************************************************************
4963 SUBROUTINE mp_win_unlock_all(win)
4964 CLASS(mp_win_type), INTENT(IN) :: win
4965
4966 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_unlock_all'
4967
4968 INTEGER :: handle, ierr
4969
4970 ierr = 0
4971 CALL mp_timeset(routinen, handle)
4972
4973#if defined(__parallel)
4974
4975 CALL mpi_win_unlock_all(win%handle, ierr)
4976 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_unlock_all @ "//routinen)
4977
4978 CALL add_perf(perf_id=19, count=1)
4979#else
4980 mark_used(win)
4981#endif
4982 CALL mp_timestop(handle)
4983 END SUBROUTINE mp_win_unlock_all
4984
4985! **************************************************************************************************
4986!> \brief Starts a timer region
4987!> \param routineN ...
4988!> \param handle ...
4989! **************************************************************************************************
4990 SUBROUTINE mp_timeset(routineN, handle)
4991 CHARACTER(len=*), INTENT(IN) :: routinen
4992 INTEGER, INTENT(OUT) :: handle
4993
4994 IF (mp_collect_timings) &
4995 CALL timeset(routinen, handle)
4996 END SUBROUTINE mp_timeset
4997
4998! **************************************************************************************************
4999!> \brief Ends a timer region
5000!> \param handle ...
5001! **************************************************************************************************
5002 SUBROUTINE mp_timestop(handle)
5003 INTEGER, INTENT(IN) :: handle
5004
5005 IF (mp_collect_timings) &
5006 CALL timestop(handle)
5007 END SUBROUTINE mp_timestop
5008
5009! **************************************************************************************************
5010!> \brief Shift around the data in msg
5011!> \param[in,out] msg Rank-2 data to shift
5012!> \param[in] comm message passing environment identifier
5013!> \param[in] displ_in displacements (?)
5014!> \par Example
5015!> msg will be moved from rank to rank+displ_in (in a circular way)
5016!> \par Limitations
5017!> * displ_in will be 1 by default (others not tested)
5018!> * the message array needs to be the same size on all processes
5019! **************************************************************************************************
5020 SUBROUTINE mp_shift_im(msg, comm, displ_in)
5021
5022 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5023 CLASS(mp_comm_type), INTENT(IN) :: comm
5024 INTEGER, INTENT(IN), OPTIONAL :: displ_in
5025
5026 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_im'
5027
5028 INTEGER :: handle, ierror
5029#if defined(__parallel)
5030 INTEGER :: displ, left, &
5031 msglen, myrank, nprocs, &
5032 right, tag
5033#endif
5034
5035 ierror = 0
5036 CALL mp_timeset(routinen, handle)
5037
5038#if defined(__parallel)
5039 CALL mpi_comm_rank(comm%handle, myrank, ierror)
5040 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
5041 CALL mpi_comm_size(comm%handle, nprocs, ierror)
5042 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
5043 IF (PRESENT(displ_in)) THEN
5044 displ = displ_in
5045 ELSE
5046 displ = 1
5047 END IF
5048 right = modulo(myrank + displ, nprocs)
5049 left = modulo(myrank - displ, nprocs)
5050 tag = 17
5051 msglen = SIZE(msg)
5052 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer, right, tag, left, tag, &
5053 comm%handle, mpi_status_ignore, ierror)
5054 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
5055 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_4_size)
5056#else
5057 mark_used(msg)
5058 mark_used(comm)
5059 mark_used(displ_in)
5060#endif
5061 CALL mp_timestop(handle)
5062
5063 END SUBROUTINE mp_shift_im
5064
5065! **************************************************************************************************
5066!> \brief Shift around the data in msg
5067!> \param[in,out] msg Data to shift
5068!> \param[in] comm message passing environment identifier
5069!> \param[in] displ_in displacements (?)
5070!> \par Example
5071!> msg will be moved from rank to rank+displ_in (in a circular way)
5072!> \par Limitations
5073!> * displ_in will be 1 by default (others not tested)
5074!> * the message array needs to be the same size on all processes
5075! **************************************************************************************************
5076 SUBROUTINE mp_shift_i (msg, comm, displ_in)
5077
5078 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5079 CLASS(mp_comm_type), INTENT(IN) :: comm
5080 INTEGER, INTENT(IN), OPTIONAL :: displ_in
5081
5082 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_i'
5083
5084 INTEGER :: handle, ierror
5085#if defined(__parallel)
5086 INTEGER :: displ, left, &
5087 msglen, myrank, nprocs, &
5088 right, tag
5089#endif
5090
5091 ierror = 0
5092 CALL mp_timeset(routinen, handle)
5093
5094#if defined(__parallel)
5095 CALL mpi_comm_rank(comm%handle, myrank, ierror)
5096 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
5097 CALL mpi_comm_size(comm%handle, nprocs, ierror)
5098 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
5099 IF (PRESENT(displ_in)) THEN
5100 displ = displ_in
5101 ELSE
5102 displ = 1
5103 END IF
5104 right = modulo(myrank + displ, nprocs)
5105 left = modulo(myrank - displ, nprocs)
5106 tag = 19
5107 msglen = SIZE(msg)
5108 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer, right, tag, left, &
5109 tag, comm%handle, mpi_status_ignore, ierror)
5110 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
5111 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_4_size)
5112#else
5113 mark_used(msg)
5114 mark_used(comm)
5115 mark_used(displ_in)
5116#endif
5117 CALL mp_timestop(handle)
5118
5119 END SUBROUTINE mp_shift_i
5120
5121! **************************************************************************************************
5122!> \brief All-to-all data exchange, rank-1 data of different sizes
5123!> \param[in] sb Data to send
5124!> \param[in] scount Data counts for data sent to other processes
5125!> \param[in] sdispl Respective data offsets for data sent to process
5126!> \param[in,out] rb Buffer into which to receive data
5127!> \param[in] rcount Data counts for data received from other
5128!> processes
5129!> \param[in] rdispl Respective data offsets for data received from
5130!> other processes
5131!> \param[in] comm Message passing environment identifier
5132!> \par MPI mapping
5133!> mpi_alltoallv
5134!> \par Array sizes
5135!> The scount, rcount, and the sdispl and rdispl arrays have a
5136!> size equal to the number of processes.
5137!> \par Offsets
5138!> Values in sdispl and rdispl start with 0.
5139! **************************************************************************************************
5140 SUBROUTINE mp_alltoall_i11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
5141
5142 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
5143 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
5144 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
5145 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
5146 CLASS(mp_comm_type), INTENT(IN) :: comm
5147
5148 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i11v'
5149
5150 INTEGER :: handle
5151#if defined(__parallel)
5152 INTEGER :: ierr, msglen
5153#else
5154 INTEGER :: i
5155#endif
5156
5157 CALL mp_timeset(routinen, handle)
5158
5159#if defined(__parallel)
5160 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer, &
5161 rb, rcount, rdispl, mpi_integer, comm%handle, ierr)
5162 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
5163 msglen = sum(scount) + sum(rcount)
5164 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5165#else
5166 mark_used(comm)
5167 mark_used(scount)
5168 mark_used(sdispl)
5169 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
5170 DO i = 1, rcount(1)
5171 rb(rdispl(1) + i) = sb(sdispl(1) + i)
5172 END DO
5173#endif
5174 CALL mp_timestop(handle)
5175
5176 END SUBROUTINE mp_alltoall_i11v
5177
5178! **************************************************************************************************
5179!> \brief All-to-all data exchange, rank-2 data of different sizes
5180!> \param sb ...
5181!> \param scount ...
5182!> \param sdispl ...
5183!> \param rb ...
5184!> \param rcount ...
5185!> \param rdispl ...
5186!> \param comm ...
5187!> \par MPI mapping
5188!> mpi_alltoallv
5189!> \note see mp_alltoall_i11v
5190! **************************************************************************************************
5191 SUBROUTINE mp_alltoall_i22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
5192
5193 INTEGER(KIND=int_4), DIMENSION(:, :), &
5194 INTENT(IN), CONTIGUOUS :: sb
5195 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
5196 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, &
5197 INTENT(INOUT) :: rb
5198 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
5199 CLASS(mp_comm_type), INTENT(IN) :: comm
5200
5201 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i22v'
5202
5203 INTEGER :: handle
5204#if defined(__parallel)
5205 INTEGER :: ierr, msglen
5206#endif
5207
5208 CALL mp_timeset(routinen, handle)
5209
5210#if defined(__parallel)
5211 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer, &
5212 rb, rcount, rdispl, mpi_integer, comm%handle, ierr)
5213 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
5214 msglen = sum(scount) + sum(rcount)
5215 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*int_4_size)
5216#else
5217 mark_used(comm)
5218 mark_used(scount)
5219 mark_used(sdispl)
5220 mark_used(rcount)
5221 mark_used(rdispl)
5222 rb = sb
5223#endif
5224 CALL mp_timestop(handle)
5225
5226 END SUBROUTINE mp_alltoall_i22v
5227
5228! **************************************************************************************************
5229!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
5230!> \param[in] sb array with data to send
5231!> \param[out] rb array into which data is received
5232!> \param[in] count number of elements to send/receive (product of the
5233!> extents of the first two dimensions)
5234!> \param[in] comm Message passing environment identifier
5235!> \par Index meaning
5236!> \par The first two indices specify the data while the last index counts
5237!> the processes
5238!> \par Sizes of ranks
5239!> All processes have the same data size.
5240!> \par MPI mapping
5241!> mpi_alltoall
5242! **************************************************************************************************
5243 SUBROUTINE mp_alltoall_i (sb, rb, count, comm)
5244
5245 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
5246 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
5247 INTEGER, INTENT(IN) :: count
5248 CLASS(mp_comm_type), INTENT(IN) :: comm
5249
5250 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i'
5251
5252 INTEGER :: handle
5253#if defined(__parallel)
5254 INTEGER :: ierr, msglen, np
5255#endif
5256
5257 CALL mp_timeset(routinen, handle)
5258
5259#if defined(__parallel)
5260 CALL mpi_alltoall(sb, count, mpi_integer, &
5261 rb, count, mpi_integer, comm%handle, ierr)
5262 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5263 CALL mpi_comm_size(comm%handle, np, ierr)
5264 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5265 msglen = 2*count*np
5266 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5267#else
5268 mark_used(count)
5269 mark_used(comm)
5270 rb = sb
5271#endif
5272 CALL mp_timestop(handle)
5273
5274 END SUBROUTINE mp_alltoall_i
5275
5276! **************************************************************************************************
5277!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
5278!> \param sb ...
5279!> \param rb ...
5280!> \param count ...
5281!> \param commp ...
5282!> \note see mp_alltoall_i
5283! **************************************************************************************************
5284 SUBROUTINE mp_alltoall_i22(sb, rb, count, comm)
5285
5286 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
5287 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
5288 INTEGER, INTENT(IN) :: count
5289 CLASS(mp_comm_type), INTENT(IN) :: comm
5290
5291 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i22'
5292
5293 INTEGER :: handle
5294#if defined(__parallel)
5295 INTEGER :: ierr, msglen, np
5296#endif
5297
5298 CALL mp_timeset(routinen, handle)
5299
5300#if defined(__parallel)
5301 CALL mpi_alltoall(sb, count, mpi_integer, &
5302 rb, count, mpi_integer, comm%handle, ierr)
5303 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5304 CALL mpi_comm_size(comm%handle, np, ierr)
5305 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5306 msglen = 2*SIZE(sb)*np
5307 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5308#else
5309 mark_used(count)
5310 mark_used(comm)
5311 rb = sb
5312#endif
5313 CALL mp_timestop(handle)
5314
5315 END SUBROUTINE mp_alltoall_i22
5316
5317! **************************************************************************************************
5318!> \brief All-to-all data exchange, rank-3 data with equal sizes
5319!> \param sb ...
5320!> \param rb ...
5321!> \param count ...
5322!> \param comm ...
5323!> \note see mp_alltoall_i
5324! **************************************************************************************************
5325 SUBROUTINE mp_alltoall_i33(sb, rb, count, comm)
5326
5327 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
5328 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
5329 INTEGER, INTENT(IN) :: count
5330 CLASS(mp_comm_type), INTENT(IN) :: comm
5331
5332 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i33'
5333
5334 INTEGER :: handle
5335#if defined(__parallel)
5336 INTEGER :: ierr, msglen, np
5337#endif
5338
5339 CALL mp_timeset(routinen, handle)
5340
5341#if defined(__parallel)
5342 CALL mpi_alltoall(sb, count, mpi_integer, &
5343 rb, count, mpi_integer, comm%handle, ierr)
5344 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5345 CALL mpi_comm_size(comm%handle, np, ierr)
5346 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5347 msglen = 2*count*np
5348 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5349#else
5350 mark_used(count)
5351 mark_used(comm)
5352 rb = sb
5353#endif
5354 CALL mp_timestop(handle)
5355
5356 END SUBROUTINE mp_alltoall_i33
5357
5358! **************************************************************************************************
5359!> \brief All-to-all data exchange, rank 4 data, equal sizes
5360!> \param sb ...
5361!> \param rb ...
5362!> \param count ...
5363!> \param comm ...
5364!> \note see mp_alltoall_i
5365! **************************************************************************************************
5366 SUBROUTINE mp_alltoall_i44(sb, rb, count, comm)
5367
5368 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5369 INTENT(IN) :: sb
5370 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5371 INTENT(OUT) :: rb
5372 INTEGER, INTENT(IN) :: count
5373 CLASS(mp_comm_type), INTENT(IN) :: comm
5374
5375 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i44'
5376
5377 INTEGER :: handle
5378#if defined(__parallel)
5379 INTEGER :: ierr, msglen, np
5380#endif
5381
5382 CALL mp_timeset(routinen, handle)
5383
5384#if defined(__parallel)
5385 CALL mpi_alltoall(sb, count, mpi_integer, &
5386 rb, count, mpi_integer, comm%handle, ierr)
5387 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5388 CALL mpi_comm_size(comm%handle, np, ierr)
5389 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5390 msglen = 2*count*np
5391 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5392#else
5393 mark_used(count)
5394 mark_used(comm)
5395 rb = sb
5396#endif
5397 CALL mp_timestop(handle)
5398
5399 END SUBROUTINE mp_alltoall_i44
5400
5401! **************************************************************************************************
5402!> \brief All-to-all data exchange, rank 5 data, equal sizes
5403!> \param sb ...
5404!> \param rb ...
5405!> \param count ...
5406!> \param comm ...
5407!> \note see mp_alltoall_i
5408! **************************************************************************************************
5409 SUBROUTINE mp_alltoall_i55(sb, rb, count, comm)
5410
5411 INTEGER(KIND=int_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
5412 INTENT(IN) :: sb
5413 INTEGER(KIND=int_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
5414 INTENT(OUT) :: rb
5415 INTEGER, INTENT(IN) :: count
5416 CLASS(mp_comm_type), INTENT(IN) :: comm
5417
5418 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i55'
5419
5420 INTEGER :: handle
5421#if defined(__parallel)
5422 INTEGER :: ierr, msglen, np
5423#endif
5424
5425 CALL mp_timeset(routinen, handle)
5426
5427#if defined(__parallel)
5428 CALL mpi_alltoall(sb, count, mpi_integer, &
5429 rb, count, mpi_integer, comm%handle, ierr)
5430 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5431 CALL mpi_comm_size(comm%handle, np, ierr)
5432 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5433 msglen = 2*count*np
5434 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5435#else
5436 mark_used(count)
5437 mark_used(comm)
5438 rb = sb
5439#endif
5440 CALL mp_timestop(handle)
5441
5442 END SUBROUTINE mp_alltoall_i55
5443
5444! **************************************************************************************************
5445!> \brief All-to-all data exchange, rank-4 data to rank-5 data
5446!> \param sb ...
5447!> \param rb ...
5448!> \param count ...
5449!> \param comm ...
5450!> \note see mp_alltoall_i
5451!> \note User must ensure size consistency.
5452! **************************************************************************************************
5453 SUBROUTINE mp_alltoall_i45(sb, rb, count, comm)
5454
5455 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5456 INTENT(IN) :: sb
5457 INTEGER(KIND=int_4), &
5458 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
5459 INTEGER, INTENT(IN) :: count
5460 CLASS(mp_comm_type), INTENT(IN) :: comm
5461
5462 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i45'
5463
5464 INTEGER :: handle
5465#if defined(__parallel)
5466 INTEGER :: ierr, msglen, np
5467#endif
5468
5469 CALL mp_timeset(routinen, handle)
5470
5471#if defined(__parallel)
5472 CALL mpi_alltoall(sb, count, mpi_integer, &
5473 rb, count, mpi_integer, comm%handle, ierr)
5474 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5475 CALL mpi_comm_size(comm%handle, np, ierr)
5476 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5477 msglen = 2*count*np
5478 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5479#else
5480 mark_used(count)
5481 mark_used(comm)
5482 rb = reshape(sb, shape(rb))
5483#endif
5484 CALL mp_timestop(handle)
5485
5486 END SUBROUTINE mp_alltoall_i45
5487
5488! **************************************************************************************************
5489!> \brief All-to-all data exchange, rank-3 data to rank-4 data
5490!> \param sb ...
5491!> \param rb ...
5492!> \param count ...
5493!> \param comm ...
5494!> \note see mp_alltoall_i
5495!> \note User must ensure size consistency.
5496! **************************************************************************************************
5497 SUBROUTINE mp_alltoall_i34(sb, rb, count, comm)
5498
5499 INTEGER(KIND=int_4), DIMENSION(:, :, :), CONTIGUOUS, &
5500 INTENT(IN) :: sb
5501 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5502 INTENT(OUT) :: rb
5503 INTEGER, INTENT(IN) :: count
5504 CLASS(mp_comm_type), INTENT(IN) :: comm
5505
5506 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i34'
5507
5508 INTEGER :: handle
5509#if defined(__parallel)
5510 INTEGER :: ierr, msglen, np
5511#endif
5512
5513 CALL mp_timeset(routinen, handle)
5514
5515#if defined(__parallel)
5516 CALL mpi_alltoall(sb, count, mpi_integer, &
5517 rb, count, mpi_integer, comm%handle, ierr)
5518 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5519 CALL mpi_comm_size(comm%handle, np, ierr)
5520 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5521 msglen = 2*count*np
5522 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5523#else
5524 mark_used(count)
5525 mark_used(comm)
5526 rb = reshape(sb, shape(rb))
5527#endif
5528 CALL mp_timestop(handle)
5529
5530 END SUBROUTINE mp_alltoall_i34
5531
5532! **************************************************************************************************
5533!> \brief All-to-all data exchange, rank-5 data to rank-4 data
5534!> \param sb ...
5535!> \param rb ...
5536!> \param count ...
5537!> \param comm ...
5538!> \note see mp_alltoall_i
5539!> \note User must ensure size consistency.
5540! **************************************************************************************************
5541 SUBROUTINE mp_alltoall_i54(sb, rb, count, comm)
5542
5543 INTEGER(KIND=int_4), &
5544 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
5545 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
5546 INTENT(OUT) :: rb
5547 INTEGER, INTENT(IN) :: count
5548 CLASS(mp_comm_type), INTENT(IN) :: comm
5549
5550 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_i54'
5551
5552 INTEGER :: handle
5553#if defined(__parallel)
5554 INTEGER :: ierr, msglen, np
5555#endif
5556
5557 CALL mp_timeset(routinen, handle)
5558
5559#if defined(__parallel)
5560 CALL mpi_alltoall(sb, count, mpi_integer, &
5561 rb, count, mpi_integer, comm%handle, ierr)
5562 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
5563 CALL mpi_comm_size(comm%handle, np, ierr)
5564 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
5565 msglen = 2*count*np
5566 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_4_size)
5567#else
5568 mark_used(count)
5569 mark_used(comm)
5570 rb = reshape(sb, shape(rb))
5571#endif
5572 CALL mp_timestop(handle)
5573
5574 END SUBROUTINE mp_alltoall_i54
5575
5576! **************************************************************************************************
5577!> \brief Send one datum to another process
5578!> \param[in] msg Scalar to send
5579!> \param[in] dest Destination process
5580!> \param[in] tag Transfer identifier
5581!> \param[in] comm Message passing environment identifier
5582!> \par MPI mapping
5583!> mpi_send
5584! **************************************************************************************************
5585 SUBROUTINE mp_send_i (msg, dest, tag, comm)
5586 INTEGER(KIND=int_4), INTENT(IN) :: msg
5587 INTEGER, INTENT(IN) :: dest, tag
5588 CLASS(mp_comm_type), INTENT(IN) :: comm
5589
5590 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_i'
5591
5592 INTEGER :: handle
5593#if defined(__parallel)
5594 INTEGER :: ierr, msglen
5595#endif
5596
5597 CALL mp_timeset(routinen, handle)
5598
5599#if defined(__parallel)
5600 msglen = 1
5601 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5602 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5603 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5604#else
5605 mark_used(msg)
5606 mark_used(dest)
5607 mark_used(tag)
5608 mark_used(comm)
5609 ! only defined in parallel
5610 cpabort("not in parallel mode")
5611#endif
5612 CALL mp_timestop(handle)
5613 END SUBROUTINE mp_send_i
5614
5615! **************************************************************************************************
5616!> \brief Send rank-1 data to another process
5617!> \param[in] msg Rank-1 data to send
5618!> \param dest ...
5619!> \param tag ...
5620!> \param comm ...
5621!> \note see mp_send_i
5622! **************************************************************************************************
5623 SUBROUTINE mp_send_iv(msg, dest, tag, comm)
5624 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
5625 INTEGER, INTENT(IN) :: dest, tag
5626 CLASS(mp_comm_type), INTENT(IN) :: comm
5627
5628 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_iv'
5629
5630 INTEGER :: handle
5631#if defined(__parallel)
5632 INTEGER :: ierr, msglen
5633#endif
5634
5635 CALL mp_timeset(routinen, handle)
5636
5637#if defined(__parallel)
5638 msglen = SIZE(msg)
5639 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5640 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5641 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5642#else
5643 mark_used(msg)
5644 mark_used(dest)
5645 mark_used(tag)
5646 mark_used(comm)
5647 ! only defined in parallel
5648 cpabort("not in parallel mode")
5649#endif
5650 CALL mp_timestop(handle)
5651 END SUBROUTINE mp_send_iv
5652
5653! **************************************************************************************************
5654!> \brief Send rank-2 data to another process
5655!> \param[in] msg Rank-2 data to send
5656!> \param dest ...
5657!> \param tag ...
5658!> \param comm ...
5659!> \note see mp_send_i
5660! **************************************************************************************************
5661 SUBROUTINE mp_send_im2(msg, dest, tag, comm)
5662 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
5663 INTEGER, INTENT(IN) :: dest, tag
5664 CLASS(mp_comm_type), INTENT(IN) :: comm
5665
5666 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_im2'
5667
5668 INTEGER :: handle
5669#if defined(__parallel)
5670 INTEGER :: ierr, msglen
5671#endif
5672
5673 CALL mp_timeset(routinen, handle)
5674
5675#if defined(__parallel)
5676 msglen = SIZE(msg)
5677 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5678 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5679 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5680#else
5681 mark_used(msg)
5682 mark_used(dest)
5683 mark_used(tag)
5684 mark_used(comm)
5685 ! only defined in parallel
5686 cpabort("not in parallel mode")
5687#endif
5688 CALL mp_timestop(handle)
5689 END SUBROUTINE mp_send_im2
5690
5691! **************************************************************************************************
5692!> \brief Send rank-3 data to another process
5693!> \param[in] msg Rank-3 data to send
5694!> \param dest ...
5695!> \param tag ...
5696!> \param comm ...
5697!> \note see mp_send_i
5698! **************************************************************************************************
5699 SUBROUTINE mp_send_im3(msg, dest, tag, comm)
5700 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
5701 INTEGER, INTENT(IN) :: dest, tag
5702 CLASS(mp_comm_type), INTENT(IN) :: comm
5703
5704 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
5705
5706 INTEGER :: handle
5707#if defined(__parallel)
5708 INTEGER :: ierr, msglen
5709#endif
5710
5711 CALL mp_timeset(routinen, handle)
5712
5713#if defined(__parallel)
5714 msglen = SIZE(msg)
5715 CALL mpi_send(msg, msglen, mpi_integer, dest, tag, comm%handle, ierr)
5716 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
5717 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_4_size)
5718#else
5719 mark_used(msg)
5720 mark_used(dest)
5721 mark_used(tag)
5722 mark_used(comm)
5723 ! only defined in parallel
5724 cpabort("not in parallel mode")
5725#endif
5726 CALL mp_timestop(handle)
5727 END SUBROUTINE mp_send_im3
5728
5729! **************************************************************************************************
5730!> \brief Receive one datum from another process
5731!> \param[in,out] msg Place received data into this variable
5732!> \param[in,out] source Process to receive from
5733!> \param[in,out] tag Transfer identifier
5734!> \param[in] comm Message passing environment identifier
5735!> \par MPI mapping
5736!> mpi_send
5737! **************************************************************************************************
5738 SUBROUTINE mp_recv_i (msg, source, tag, comm)
5739 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5740 INTEGER, INTENT(INOUT) :: source, tag
5741 CLASS(mp_comm_type), INTENT(IN) :: comm
5742
5743 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_i'
5744
5745 INTEGER :: handle
5746#if defined(__parallel)
5747 INTEGER :: ierr, msglen
5748 mpi_status_type :: status
5749#endif
5750
5751 CALL mp_timeset(routinen, handle)
5752
5753#if defined(__parallel)
5754 msglen = 1
5755 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5756 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5757 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5758 ELSE
5759 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5760 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5761 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5762 source = status mpi_status_extract(mpi_source)
5763 tag = status mpi_status_extract(mpi_tag)
5764 END IF
5765#else
5766 mark_used(msg)
5767 mark_used(source)
5768 mark_used(tag)
5769 mark_used(comm)
5770 ! only defined in parallel
5771 cpabort("not in parallel mode")
5772#endif
5773 CALL mp_timestop(handle)
5774 END SUBROUTINE mp_recv_i
5775
5776! **************************************************************************************************
5777!> \brief Receive rank-1 data from another process
5778!> \param[in,out] msg Place received data into this rank-1 array
5779!> \param source ...
5780!> \param tag ...
5781!> \param comm ...
5782!> \note see mp_recv_i
5783! **************************************************************************************************
5784 SUBROUTINE mp_recv_iv(msg, source, tag, comm)
5785 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
5786 INTEGER, INTENT(INOUT) :: source, tag
5787 CLASS(mp_comm_type), INTENT(IN) :: comm
5788
5789 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_iv'
5790
5791 INTEGER :: handle
5792#if defined(__parallel)
5793 INTEGER :: ierr, msglen
5794 mpi_status_type :: status
5795#endif
5796
5797 CALL mp_timeset(routinen, handle)
5798
5799#if defined(__parallel)
5800 msglen = SIZE(msg)
5801 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5802 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5803 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5804 ELSE
5805 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5806 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5807 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5808 source = status mpi_status_extract(mpi_source)
5809 tag = status mpi_status_extract(mpi_tag)
5810 END IF
5811#else
5812 mark_used(msg)
5813 mark_used(source)
5814 mark_used(tag)
5815 mark_used(comm)
5816 ! only defined in parallel
5817 cpabort("not in parallel mode")
5818#endif
5819 CALL mp_timestop(handle)
5820 END SUBROUTINE mp_recv_iv
5821
5822! **************************************************************************************************
5823!> \brief Receive rank-2 data from another process
5824!> \param[in,out] msg Place received data into this rank-2 array
5825!> \param source ...
5826!> \param tag ...
5827!> \param comm ...
5828!> \note see mp_recv_i
5829! **************************************************************************************************
5830 SUBROUTINE mp_recv_im2(msg, source, tag, comm)
5831 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
5832 INTEGER, INTENT(INOUT) :: source, tag
5833 CLASS(mp_comm_type), INTENT(IN) :: comm
5834
5835 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_im2'
5836
5837 INTEGER :: handle
5838#if defined(__parallel)
5839 INTEGER :: ierr, msglen
5840 mpi_status_type :: status
5841#endif
5842
5843 CALL mp_timeset(routinen, handle)
5844
5845#if defined(__parallel)
5846 msglen = SIZE(msg)
5847 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5848 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5849 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5850 ELSE
5851 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5852 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5853 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5854 source = status mpi_status_extract(mpi_source)
5855 tag = status mpi_status_extract(mpi_tag)
5856 END IF
5857#else
5858 mark_used(msg)
5859 mark_used(source)
5860 mark_used(tag)
5861 mark_used(comm)
5862 ! only defined in parallel
5863 cpabort("not in parallel mode")
5864#endif
5865 CALL mp_timestop(handle)
5866 END SUBROUTINE mp_recv_im2
5867
5868! **************************************************************************************************
5869!> \brief Receive rank-3 data from another process
5870!> \param[in,out] msg Place received data into this rank-3 array
5871!> \param source ...
5872!> \param tag ...
5873!> \param comm ...
5874!> \note see mp_recv_i
5875! **************************************************************************************************
5876 SUBROUTINE mp_recv_im3(msg, source, tag, comm)
5877 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
5878 INTEGER, INTENT(INOUT) :: source, tag
5879 CLASS(mp_comm_type), INTENT(IN) :: comm
5880
5881 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_im3'
5882
5883 INTEGER :: handle
5884#if defined(__parallel)
5885 INTEGER :: ierr, msglen
5886 mpi_status_type :: status
5887#endif
5888
5889 CALL mp_timeset(routinen, handle)
5890
5891#if defined(__parallel)
5892 msglen = SIZE(msg)
5893 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
5894 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, mpi_status_ignore, ierr)
5895 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5896 ELSE
5897 CALL mpi_recv(msg, msglen, mpi_integer, source, tag, comm%handle, status, ierr)
5898 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
5899 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_4_size)
5900 source = status mpi_status_extract(mpi_source)
5901 tag = status mpi_status_extract(mpi_tag)
5902 END IF
5903#else
5904 mark_used(msg)
5905 mark_used(source)
5906 mark_used(tag)
5907 mark_used(comm)
5908 ! only defined in parallel
5909 cpabort("not in parallel mode")
5910#endif
5911 CALL mp_timestop(handle)
5912 END SUBROUTINE mp_recv_im3
5913
5914! **************************************************************************************************
5915!> \brief Broadcasts a datum to all processes.
5916!> \param[in] msg Datum to broadcast
5917!> \param[in] source Processes which broadcasts
5918!> \param[in] comm Message passing environment identifier
5919!> \par MPI mapping
5920!> mpi_bcast
5921! **************************************************************************************************
5922 SUBROUTINE mp_bcast_i (msg, source, comm)
5923 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5924 INTEGER, INTENT(IN) :: source
5925 CLASS(mp_comm_type), INTENT(IN) :: comm
5926
5927 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i'
5928
5929 INTEGER :: handle
5930#if defined(__parallel)
5931 INTEGER :: ierr, msglen
5932#endif
5933
5934 CALL mp_timeset(routinen, handle)
5935
5936#if defined(__parallel)
5937 msglen = 1
5938 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
5939 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5940 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5941#else
5942 mark_used(msg)
5943 mark_used(source)
5944 mark_used(comm)
5945#endif
5946 CALL mp_timestop(handle)
5947 END SUBROUTINE mp_bcast_i
5948
5949! **************************************************************************************************
5950!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
5951!> \param[in] msg Datum to broadcast
5952!> \param[in] comm Message passing environment identifier
5953!> \par MPI mapping
5954!> mpi_bcast
5955! **************************************************************************************************
5956 SUBROUTINE mp_bcast_i_src(msg, comm)
5957 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5958 CLASS(mp_comm_type), INTENT(IN) :: comm
5959
5960 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i_src'
5961
5962 INTEGER :: handle
5963#if defined(__parallel)
5964 INTEGER :: ierr, msglen
5965#endif
5966
5967 CALL mp_timeset(routinen, handle)
5968
5969#if defined(__parallel)
5970 msglen = 1
5971 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
5972 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
5973 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
5974#else
5975 mark_used(msg)
5976 mark_used(comm)
5977#endif
5978 CALL mp_timestop(handle)
5979 END SUBROUTINE mp_bcast_i_src
5980
5981! **************************************************************************************************
5982!> \brief Broadcasts a datum to all processes.
5983!> \param[in] msg Datum to broadcast
5984!> \param[in] source Processes which broadcasts
5985!> \param[in] comm Message passing environment identifier
5986!> \par MPI mapping
5987!> mpi_bcast
5988! **************************************************************************************************
5989 SUBROUTINE mp_ibcast_i (msg, source, comm, request)
5990 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
5991 INTEGER, INTENT(IN) :: source
5992 CLASS(mp_comm_type), INTENT(IN) :: comm
5993 TYPE(mp_request_type), INTENT(OUT) :: request
5994
5995 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_i'
5996
5997 INTEGER :: handle
5998#if defined(__parallel)
5999 INTEGER :: ierr, msglen
6000#endif
6001
6002 CALL mp_timeset(routinen, handle)
6003
6004#if defined(__parallel)
6005 msglen = 1
6006 CALL mpi_ibcast(msg, msglen, mpi_integer, source, comm%handle, request%handle, ierr)
6007 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
6008 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_4_size)
6009#else
6010 mark_used(msg)
6011 mark_used(source)
6012 mark_used(comm)
6013 request = mp_request_null
6014#endif
6015 CALL mp_timestop(handle)
6016 END SUBROUTINE mp_ibcast_i
6017
6018! **************************************************************************************************
6019!> \brief Broadcasts rank-1 data to all processes
6020!> \param[in] msg Data to broadcast
6021!> \param source ...
6022!> \param comm ...
6023!> \note see mp_bcast_i1
6024! **************************************************************************************************
6025 SUBROUTINE mp_bcast_iv(msg, source, comm)
6026 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6027 INTEGER, INTENT(IN) :: source
6028 CLASS(mp_comm_type), INTENT(IN) :: comm
6029
6030 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_iv'
6031
6032 INTEGER :: handle
6033#if defined(__parallel)
6034 INTEGER :: ierr, msglen
6035#endif
6036
6037 CALL mp_timeset(routinen, handle)
6038
6039#if defined(__parallel)
6040 msglen = SIZE(msg)
6041 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
6042 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6043 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6044#else
6045 mark_used(msg)
6046 mark_used(source)
6047 mark_used(comm)
6048#endif
6049 CALL mp_timestop(handle)
6050 END SUBROUTINE mp_bcast_iv
6051
6052! **************************************************************************************************
6053!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
6054!> \param[in] msg Data to broadcast
6055!> \param comm ...
6056!> \note see mp_bcast_i1
6057! **************************************************************************************************
6058 SUBROUTINE mp_bcast_iv_src(msg, comm)
6059 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6060 CLASS(mp_comm_type), INTENT(IN) :: comm
6061
6062 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_iv_src'
6063
6064 INTEGER :: handle
6065#if defined(__parallel)
6066 INTEGER :: ierr, msglen
6067#endif
6068
6069 CALL mp_timeset(routinen, handle)
6070
6071#if defined(__parallel)
6072 msglen = SIZE(msg)
6073 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
6074 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6075 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6076#else
6077 mark_used(msg)
6078 mark_used(comm)
6079#endif
6080 CALL mp_timestop(handle)
6081 END SUBROUTINE mp_bcast_iv_src
6082
6083! **************************************************************************************************
6084!> \brief Broadcasts rank-1 data to all processes
6085!> \param[in] msg Data to broadcast
6086!> \param source ...
6087!> \param comm ...
6088!> \note see mp_bcast_i1
6089! **************************************************************************************************
6090 SUBROUTINE mp_ibcast_iv(msg, source, comm, request)
6091 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6092 INTEGER, INTENT(IN) :: source
6093 CLASS(mp_comm_type), INTENT(IN) :: comm
6094 TYPE(mp_request_type) :: request
6095
6096 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_iv'
6097
6098 INTEGER :: handle
6099#if defined(__parallel)
6100 INTEGER :: ierr, msglen
6101#endif
6102
6103 CALL mp_timeset(routinen, handle)
6104
6105#if defined(__parallel)
6106#if !defined(__GNUC__) || __GNUC__ >= 9
6107 cpassert(is_contiguous(msg))
6108#endif
6109 msglen = SIZE(msg)
6110 CALL mpi_ibcast(msg, msglen, mpi_integer, source, comm%handle, request%handle, ierr)
6111 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
6112 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_4_size)
6113#else
6114 mark_used(msg)
6115 mark_used(source)
6116 mark_used(comm)
6117 request = mp_request_null
6118#endif
6119 CALL mp_timestop(handle)
6120 END SUBROUTINE mp_ibcast_iv
6121
6122! **************************************************************************************************
6123!> \brief Broadcasts rank-2 data to all processes
6124!> \param[in] msg Data to broadcast
6125!> \param source ...
6126!> \param comm ...
6127!> \note see mp_bcast_i1
6128! **************************************************************************************************
6129 SUBROUTINE mp_bcast_im(msg, source, comm)
6130 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6131 INTEGER, INTENT(IN) :: source
6132 CLASS(mp_comm_type), INTENT(IN) :: comm
6133
6134 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_im'
6135
6136 INTEGER :: handle
6137#if defined(__parallel)
6138 INTEGER :: ierr, msglen
6139#endif
6140
6141 CALL mp_timeset(routinen, handle)
6142
6143#if defined(__parallel)
6144 msglen = SIZE(msg)
6145 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
6146 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6147 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6148#else
6149 mark_used(msg)
6150 mark_used(source)
6151 mark_used(comm)
6152#endif
6153 CALL mp_timestop(handle)
6154 END SUBROUTINE mp_bcast_im
6155
6156! **************************************************************************************************
6157!> \brief Broadcasts rank-2 data to all processes
6158!> \param[in] msg Data to broadcast
6159!> \param source ...
6160!> \param comm ...
6161!> \note see mp_bcast_i1
6162! **************************************************************************************************
6163 SUBROUTINE mp_bcast_im_src(msg, comm)
6164 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6165 CLASS(mp_comm_type), INTENT(IN) :: comm
6166
6167 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_im_src'
6168
6169 INTEGER :: handle
6170#if defined(__parallel)
6171 INTEGER :: ierr, msglen
6172#endif
6173
6174 CALL mp_timeset(routinen, handle)
6175
6176#if defined(__parallel)
6177 msglen = SIZE(msg)
6178 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
6179 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6180 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6181#else
6182 mark_used(msg)
6183 mark_used(comm)
6184#endif
6185 CALL mp_timestop(handle)
6186 END SUBROUTINE mp_bcast_im_src
6187
6188! **************************************************************************************************
6189!> \brief Broadcasts rank-3 data to all processes
6190!> \param[in] msg Data to broadcast
6191!> \param source ...
6192!> \param comm ...
6193!> \note see mp_bcast_i1
6194! **************************************************************************************************
6195 SUBROUTINE mp_bcast_i3(msg, source, comm)
6196 INTEGER(KIND=int_4), CONTIGUOUS :: msg(:, :, :)
6197 INTEGER, INTENT(IN) :: source
6198 CLASS(mp_comm_type), INTENT(IN) :: comm
6199
6200 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i3'
6201
6202 INTEGER :: handle
6203#if defined(__parallel)
6204 INTEGER :: ierr, msglen
6205#endif
6206
6207 CALL mp_timeset(routinen, handle)
6208
6209#if defined(__parallel)
6210 msglen = SIZE(msg)
6211 CALL mpi_bcast(msg, msglen, mpi_integer, source, comm%handle, ierr)
6212 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6213 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6214#else
6215 mark_used(msg)
6216 mark_used(source)
6217 mark_used(comm)
6218#endif
6219 CALL mp_timestop(handle)
6220 END SUBROUTINE mp_bcast_i3
6221
6222! **************************************************************************************************
6223!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
6224!> \param[in] msg Data to broadcast
6225!> \param source ...
6226!> \param comm ...
6227!> \note see mp_bcast_i1
6228! **************************************************************************************************
6229 SUBROUTINE mp_bcast_i3_src(msg, comm)
6230 INTEGER(KIND=int_4), CONTIGUOUS :: msg(:, :, :)
6231 CLASS(mp_comm_type), INTENT(IN) :: comm
6232
6233 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_i3_src'
6234
6235 INTEGER :: handle
6236#if defined(__parallel)
6237 INTEGER :: ierr, msglen
6238#endif
6239
6240 CALL mp_timeset(routinen, handle)
6241
6242#if defined(__parallel)
6243 msglen = SIZE(msg)
6244 CALL mpi_bcast(msg, msglen, mpi_integer, comm%source, comm%handle, ierr)
6245 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
6246 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_4_size)
6247#else
6248 mark_used(msg)
6249 mark_used(comm)
6250#endif
6251 CALL mp_timestop(handle)
6252 END SUBROUTINE mp_bcast_i3_src
6253
6254! **************************************************************************************************
6255!> \brief Sums a datum from all processes with result left on all processes.
6256!> \param[in,out] msg Datum to sum (input) and result (output)
6257!> \param[in] comm Message passing environment identifier
6258!> \par MPI mapping
6259!> mpi_allreduce
6260! **************************************************************************************************
6261 SUBROUTINE mp_sum_i (msg, comm)
6262 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6263 CLASS(mp_comm_type), INTENT(IN) :: comm
6264
6265 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_i'
6266
6267 INTEGER :: handle
6268#if defined(__parallel)
6269 INTEGER :: ierr, msglen
6270#endif
6271
6272 CALL mp_timeset(routinen, handle)
6273
6274#if defined(__parallel)
6275 msglen = 1
6276 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6277 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6278 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6279#else
6280 mark_used(msg)
6281 mark_used(comm)
6282#endif
6283 CALL mp_timestop(handle)
6284 END SUBROUTINE mp_sum_i
6285
6286! **************************************************************************************************
6287!> \brief Element-wise sum of a rank-1 array on all processes.
6288!> \param[in,out] msg Vector to sum and result
6289!> \param comm ...
6290!> \note see mp_sum_i
6291! **************************************************************************************************
6292 SUBROUTINE mp_sum_iv(msg, comm)
6293 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6294 CLASS(mp_comm_type), INTENT(IN) :: comm
6295
6296 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_iv'
6297
6298 INTEGER :: handle
6299#if defined(__parallel)
6300 INTEGER :: ierr, msglen
6301#endif
6302
6303 CALL mp_timeset(routinen, handle)
6304
6305#if defined(__parallel)
6306 msglen = SIZE(msg)
6307 IF (msglen > 0) THEN
6308 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6309 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6310 END IF
6311 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6312#else
6313 mark_used(msg)
6314 mark_used(comm)
6315#endif
6316 CALL mp_timestop(handle)
6317 END SUBROUTINE mp_sum_iv
6318
6319! **************************************************************************************************
6320!> \brief Element-wise sum of a rank-1 array on all processes.
6321!> \param[in,out] msg Vector to sum and result
6322!> \param comm ...
6323!> \note see mp_sum_i
6324! **************************************************************************************************
6325 SUBROUTINE mp_isum_iv(msg, comm, request)
6326 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6327 CLASS(mp_comm_type), INTENT(IN) :: comm
6328 TYPE(mp_request_type), INTENT(OUT) :: request
6329
6330 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_iv'
6331
6332 INTEGER :: handle
6333#if defined(__parallel)
6334 INTEGER :: ierr, msglen
6335#endif
6336
6337 CALL mp_timeset(routinen, handle)
6338
6339#if defined(__parallel)
6340#if !defined(__GNUC__) || __GNUC__ >= 9
6341 cpassert(is_contiguous(msg))
6342#endif
6343 msglen = SIZE(msg)
6344 IF (msglen > 0) THEN
6345 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, request%handle, ierr)
6346 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
6347 ELSE
6348 request = mp_request_null
6349 END IF
6350 CALL add_perf(perf_id=23, count=1, msg_size=msglen*int_4_size)
6351#else
6352 mark_used(msg)
6353 mark_used(comm)
6354 request = mp_request_null
6355#endif
6356 CALL mp_timestop(handle)
6357 END SUBROUTINE mp_isum_iv
6358
6359! **************************************************************************************************
6360!> \brief Element-wise sum of a rank-2 array on all processes.
6361!> \param[in] msg Matrix to sum and result
6362!> \param comm ...
6363!> \note see mp_sum_i
6364! **************************************************************************************************
6365 SUBROUTINE mp_sum_im(msg, comm)
6366 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6367 CLASS(mp_comm_type), INTENT(IN) :: comm
6368
6369 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im'
6370
6371 INTEGER :: handle
6372#if defined(__parallel)
6373 INTEGER, PARAMETER :: max_msg = 2**25
6374 INTEGER :: ierr, m1, msglen, step, msglensum
6375#endif
6376
6377 CALL mp_timeset(routinen, handle)
6378
6379#if defined(__parallel)
6380 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
6381 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
6382 msglensum = 0
6383 DO m1 = lbound(msg, 2), ubound(msg, 2), step
6384 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
6385 msglensum = msglensum + msglen
6386 IF (msglen > 0) THEN
6387 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6388 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6389 END IF
6390 END DO
6391 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_4_size)
6392#else
6393 mark_used(msg)
6394 mark_used(comm)
6395#endif
6396 CALL mp_timestop(handle)
6397 END SUBROUTINE mp_sum_im
6398
6399! **************************************************************************************************
6400!> \brief Element-wise sum of a rank-3 array on all processes.
6401!> \param[in] msg Array to sum and result
6402!> \param comm ...
6403!> \note see mp_sum_i
6404! **************************************************************************************************
6405 SUBROUTINE mp_sum_im3(msg, comm)
6406 INTEGER(KIND=int_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
6407 CLASS(mp_comm_type), INTENT(IN) :: comm
6408
6409 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im3'
6410
6411 INTEGER :: handle
6412#if defined(__parallel)
6413 INTEGER :: ierr, msglen
6414#endif
6415
6416 CALL mp_timeset(routinen, handle)
6417
6418#if defined(__parallel)
6419 msglen = SIZE(msg)
6420 IF (msglen > 0) THEN
6421 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6422 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6423 END IF
6424 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6425#else
6426 mark_used(msg)
6427 mark_used(comm)
6428#endif
6429 CALL mp_timestop(handle)
6430 END SUBROUTINE mp_sum_im3
6431
6432! **************************************************************************************************
6433!> \brief Element-wise sum of a rank-4 array on all processes.
6434!> \param[in] msg Array to sum and result
6435!> \param comm ...
6436!> \note see mp_sum_i
6437! **************************************************************************************************
6438 SUBROUTINE mp_sum_im4(msg, comm)
6439 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
6440 CLASS(mp_comm_type), INTENT(IN) :: comm
6441
6442 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_im4'
6443
6444 INTEGER :: handle
6445#if defined(__parallel)
6446 INTEGER :: ierr, msglen
6447#endif
6448
6449 CALL mp_timeset(routinen, handle)
6450
6451#if defined(__parallel)
6452 msglen = SIZE(msg)
6453 IF (msglen > 0) THEN
6454 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6455 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6456 END IF
6457 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6458#else
6459 mark_used(msg)
6460 mark_used(comm)
6461#endif
6462 CALL mp_timestop(handle)
6463 END SUBROUTINE mp_sum_im4
6464
6465! **************************************************************************************************
6466!> \brief Element-wise sum of data from all processes with result left only on
6467!> one.
6468!> \param[in,out] msg Vector to sum (input) and (only on process root)
6469!> result (output)
6470!> \param root ...
6471!> \param[in] comm Message passing environment identifier
6472!> \par MPI mapping
6473!> mpi_reduce
6474! **************************************************************************************************
6475 SUBROUTINE mp_sum_root_iv(msg, root, comm)
6476 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6477 INTEGER, INTENT(IN) :: root
6478 CLASS(mp_comm_type), INTENT(IN) :: comm
6479
6480 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_iv'
6481
6482 INTEGER :: handle
6483#if defined(__parallel)
6484 INTEGER :: ierr, m1, msglen, taskid
6485 INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
6486#endif
6487
6488 CALL mp_timeset(routinen, handle)
6489
6490#if defined(__parallel)
6491 msglen = SIZE(msg)
6492 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6493 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6494 IF (msglen > 0) THEN
6495 m1 = SIZE(msg, 1)
6496 ALLOCATE (res(m1))
6497 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_sum, &
6498 root, comm%handle, ierr)
6499 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6500 IF (taskid == root) THEN
6501 msg = res
6502 END IF
6503 DEALLOCATE (res)
6504 END IF
6505 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6506#else
6507 mark_used(msg)
6508 mark_used(root)
6509 mark_used(comm)
6510#endif
6511 CALL mp_timestop(handle)
6512 END SUBROUTINE mp_sum_root_iv
6513
6514! **************************************************************************************************
6515!> \brief Element-wise sum of data from all processes with result left only on
6516!> one.
6517!> \param[in,out] msg Matrix to sum (input) and (only on process root)
6518!> result (output)
6519!> \param root ...
6520!> \param comm ...
6521!> \note see mp_sum_root_iv
6522! **************************************************************************************************
6523 SUBROUTINE mp_sum_root_im(msg, root, comm)
6524 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6525 INTEGER, INTENT(IN) :: root
6526 CLASS(mp_comm_type), INTENT(IN) :: comm
6527
6528 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
6529
6530 INTEGER :: handle
6531#if defined(__parallel)
6532 INTEGER :: ierr, m1, m2, msglen, taskid
6533 INTEGER(KIND=int_4), ALLOCATABLE :: res(:, :)
6534#endif
6535
6536 CALL mp_timeset(routinen, handle)
6537
6538#if defined(__parallel)
6539 msglen = SIZE(msg)
6540 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6541 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6542 IF (msglen > 0) THEN
6543 m1 = SIZE(msg, 1)
6544 m2 = SIZE(msg, 2)
6545 ALLOCATE (res(m1, m2))
6546 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_sum, root, comm%handle, ierr)
6547 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6548 IF (taskid == root) THEN
6549 msg = res
6550 END IF
6551 DEALLOCATE (res)
6552 END IF
6553 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6554#else
6555 mark_used(root)
6556 mark_used(msg)
6557 mark_used(comm)
6558#endif
6559 CALL mp_timestop(handle)
6560 END SUBROUTINE mp_sum_root_im
6561
6562! **************************************************************************************************
6563!> \brief Partial sum of data from all processes with result on each process.
6564!> \param[in] msg Matrix to sum (input)
6565!> \param[out] res Matrix containing result (output)
6566!> \param[in] comm Message passing environment identifier
6567! **************************************************************************************************
6568 SUBROUTINE mp_sum_partial_im(msg, res, comm)
6569 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
6570 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
6571 CLASS(mp_comm_type), INTENT(IN) :: comm
6572
6573 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_im'
6574
6575 INTEGER :: handle
6576#if defined(__parallel)
6577 INTEGER :: ierr, msglen, taskid
6578#endif
6579
6580 CALL mp_timeset(routinen, handle)
6581
6582#if defined(__parallel)
6583 msglen = SIZE(msg)
6584 CALL mpi_comm_rank(comm%handle, taskid, ierr)
6585 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
6586 IF (msglen > 0) THEN
6587 CALL mpi_scan(msg, res, msglen, mpi_integer, mpi_sum, comm%handle, ierr)
6588 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
6589 END IF
6590 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6591 ! perf_id is same as for other summation routines
6592#else
6593 res = msg
6594 mark_used(comm)
6595#endif
6596 CALL mp_timestop(handle)
6597 END SUBROUTINE mp_sum_partial_im
6598
6599! **************************************************************************************************
6600!> \brief Finds the maximum of a datum with the result left on all processes.
6601!> \param[in,out] msg Find maximum among these data (input) and
6602!> maximum (output)
6603!> \param[in] comm Message passing environment identifier
6604!> \par MPI mapping
6605!> mpi_allreduce
6606! **************************************************************************************************
6607 SUBROUTINE mp_max_i (msg, comm)
6608 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6609 CLASS(mp_comm_type), INTENT(IN) :: comm
6610
6611 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_i'
6612
6613 INTEGER :: handle
6614#if defined(__parallel)
6615 INTEGER :: ierr, msglen
6616#endif
6617
6618 CALL mp_timeset(routinen, handle)
6619
6620#if defined(__parallel)
6621 msglen = 1
6622 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6623 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
6629 CALL mp_timestop(handle)
6630 END SUBROUTINE mp_max_i
6631
6632! **************************************************************************************************
6633!> \brief Finds the maximum of a datum with the result left on all processes.
6634!> \param[in,out] msg Find maximum among these data (input) and
6635!> maximum (output)
6636!> \param[in] comm Message passing environment identifier
6637!> \par MPI mapping
6638!> mpi_allreduce
6639! **************************************************************************************************
6640 SUBROUTINE mp_max_root_i (msg, root, comm)
6641 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6642 INTEGER, INTENT(IN) :: root
6643 CLASS(mp_comm_type), INTENT(IN) :: comm
6644
6645 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_i'
6646
6647 INTEGER :: handle
6648#if defined(__parallel)
6649 INTEGER :: ierr, msglen
6650 INTEGER(KIND=int_4) :: res
6651#endif
6652
6653 CALL mp_timeset(routinen, handle)
6654
6655#if defined(__parallel)
6656 msglen = 1
6657 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_max, root, comm%handle, ierr)
6658 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
6659 IF (root == comm%mepos) msg = res
6660 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6661#else
6662 mark_used(msg)
6663 mark_used(comm)
6664 mark_used(root)
6665#endif
6666 CALL mp_timestop(handle)
6667 END SUBROUTINE mp_max_root_i
6668
6669! **************************************************************************************************
6670!> \brief Finds the element-wise maximum of a vector with the result left on
6671!> all processes.
6672!> \param[in,out] msg Find maximum among these data (input) and
6673!> maximum (output)
6674!> \param comm ...
6675!> \note see mp_max_i
6676! **************************************************************************************************
6677 SUBROUTINE mp_max_iv(msg, comm)
6678 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
6679 CLASS(mp_comm_type), INTENT(IN) :: comm
6680
6681 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_iv'
6682
6683 INTEGER :: handle
6684#if defined(__parallel)
6685 INTEGER :: ierr, msglen
6686#endif
6687
6688 CALL mp_timeset(routinen, handle)
6689
6690#if defined(__parallel)
6691 msglen = SIZE(msg)
6692 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_max, comm%handle, ierr)
6693 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6694 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6695#else
6696 mark_used(msg)
6697 mark_used(comm)
6698#endif
6699 CALL mp_timestop(handle)
6700 END SUBROUTINE mp_max_iv
6701
6702! **************************************************************************************************
6703!> \brief Finds the element-wise maximum of a vector with the result left on
6704!> all processes.
6705!> \param[in,out] msg Find maximum among these data (input) and
6706!> maximum (output)
6707!> \param comm ...
6708!> \note see mp_max_i
6709! **************************************************************************************************
6710 SUBROUTINE mp_max_root_im(msg, root, comm)
6711 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
6712 INTEGER :: root
6713 CLASS(mp_comm_type), INTENT(IN) :: comm
6714
6715 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_im'
6716
6717 INTEGER :: handle
6718#if defined(__parallel)
6719 INTEGER :: ierr, msglen
6720 INTEGER(KIND=int_4) :: res(size(msg, 1), size(msg, 2))
6721#endif
6722
6723 CALL mp_timeset(routinen, handle)
6724
6725#if defined(__parallel)
6726 msglen = SIZE(msg)
6727 CALL mpi_reduce(msg, res, msglen, mpi_integer, mpi_max, root, comm%handle, ierr)
6728 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6729 IF (root == comm%mepos) msg = res
6730 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6731#else
6732 mark_used(msg)
6733 mark_used(comm)
6734 mark_used(root)
6735#endif
6736 CALL mp_timestop(handle)
6737 END SUBROUTINE mp_max_root_im
6738
6739! **************************************************************************************************
6740!> \brief Finds the minimum of a datum with the result left on all processes.
6741!> \param[in,out] msg Find minimum among these data (input) and
6742!> maximum (output)
6743!> \param[in] comm Message passing environment identifier
6744!> \par MPI mapping
6745!> mpi_allreduce
6746! **************************************************************************************************
6747 SUBROUTINE mp_min_i (msg, comm)
6748 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6749 CLASS(mp_comm_type), INTENT(IN) :: comm
6750
6751 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_i'
6752
6753 INTEGER :: handle
6754#if defined(__parallel)
6755 INTEGER :: ierr, msglen
6756#endif
6757
6758 CALL mp_timeset(routinen, handle)
6759
6760#if defined(__parallel)
6761 msglen = 1
6762 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6763 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6764 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6765#else
6766 mark_used(msg)
6767 mark_used(comm)
6768#endif
6769 CALL mp_timestop(handle)
6770 END SUBROUTINE mp_min_i
6771
6772! **************************************************************************************************
6773!> \brief Finds the element-wise minimum of vector with the result left on
6774!> all processes.
6775!> \param[in,out] msg Find minimum among these data (input) and
6776!> maximum (output)
6777!> \param comm ...
6778!> \par MPI mapping
6779!> mpi_allreduce
6780!> \note see mp_min_i
6781! **************************************************************************************************
6782 SUBROUTINE mp_min_iv(msg, comm)
6783 INTEGER(KIND=int_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
6784 CLASS(mp_comm_type), INTENT(IN) :: comm
6785
6786 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_iv'
6787
6788 INTEGER :: handle
6789#if defined(__parallel)
6790 INTEGER :: ierr, msglen
6791#endif
6792
6793 CALL mp_timeset(routinen, handle)
6794
6795#if defined(__parallel)
6796 msglen = SIZE(msg)
6797 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_min, comm%handle, ierr)
6798 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6799 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6800#else
6801 mark_used(msg)
6802 mark_used(comm)
6803#endif
6804 CALL mp_timestop(handle)
6805 END SUBROUTINE mp_min_iv
6806
6807! **************************************************************************************************
6808!> \brief Multiplies a set of numbers scattered across a number of processes,
6809!> then replicates the result.
6810!> \param[in,out] msg a number to multiply (input) and result (output)
6811!> \param[in] comm message passing environment identifier
6812!> \par MPI mapping
6813!> mpi_allreduce
6814! **************************************************************************************************
6815 SUBROUTINE mp_prod_i (msg, comm)
6816 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6817 CLASS(mp_comm_type), INTENT(IN) :: comm
6818
6819 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_i'
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 = 1
6830 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer, mpi_prod, comm%handle, ierr)
6831 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
6832 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
6833#else
6834 mark_used(msg)
6835 mark_used(comm)
6836#endif
6837 CALL mp_timestop(handle)
6838 END SUBROUTINE mp_prod_i
6839
6840! **************************************************************************************************
6841!> \brief Scatters data from one processes to all others
6842!> \param[in] msg_scatter Data to scatter (for root process)
6843!> \param[out] msg Received data
6844!> \param[in] root Process which scatters data
6845!> \param[in] comm Message passing environment identifier
6846!> \par MPI mapping
6847!> mpi_scatter
6848! **************************************************************************************************
6849 SUBROUTINE mp_scatter_iv(msg_scatter, msg, root, comm)
6850 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
6851 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
6852 INTEGER, INTENT(IN) :: root
6853 CLASS(mp_comm_type), INTENT(IN) :: comm
6854
6855 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_iv'
6856
6857 INTEGER :: handle
6858#if defined(__parallel)
6859 INTEGER :: ierr, msglen
6860#endif
6861
6862 CALL mp_timeset(routinen, handle)
6863
6864#if defined(__parallel)
6865 msglen = SIZE(msg)
6866 CALL mpi_scatter(msg_scatter, msglen, mpi_integer, msg, &
6867 msglen, mpi_integer, root, comm%handle, ierr)
6868 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
6869 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
6870#else
6871 mark_used(root)
6872 mark_used(comm)
6873 msg = msg_scatter
6874#endif
6875 CALL mp_timestop(handle)
6876 END SUBROUTINE mp_scatter_iv
6877
6878! **************************************************************************************************
6879!> \brief Scatters data from one processes to all others
6880!> \param[in] msg_scatter Data to scatter (for root process)
6881!> \param[in] root Process which scatters data
6882!> \param[in] comm Message passing environment identifier
6883!> \par MPI mapping
6884!> mpi_scatter
6885! **************************************************************************************************
6886 SUBROUTINE mp_iscatter_i (msg_scatter, msg, root, comm, request)
6887 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:)
6888 INTEGER(KIND=int_4), INTENT(INOUT) :: msg
6889 INTEGER, INTENT(IN) :: root
6890 CLASS(mp_comm_type), INTENT(IN) :: comm
6891 TYPE(mp_request_type), INTENT(OUT) :: request
6892
6893 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_i'
6894
6895 INTEGER :: handle
6896#if defined(__parallel)
6897 INTEGER :: ierr, msglen
6898#endif
6899
6900 CALL mp_timeset(routinen, handle)
6901
6902#if defined(__parallel)
6903#if !defined(__GNUC__) || __GNUC__ >= 9
6904 cpassert(is_contiguous(msg_scatter))
6905#endif
6906 msglen = 1
6907 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer, msg, &
6908 msglen, mpi_integer, root, comm%handle, request%handle, ierr)
6909 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
6910 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6911#else
6912 mark_used(root)
6913 mark_used(comm)
6914 msg = msg_scatter(1)
6915 request = mp_request_null
6916#endif
6917 CALL mp_timestop(handle)
6918 END SUBROUTINE mp_iscatter_i
6919
6920! **************************************************************************************************
6921!> \brief Scatters data from one processes to all others
6922!> \param[in] msg_scatter Data to scatter (for root process)
6923!> \param[in] root Process which scatters data
6924!> \param[in] comm Message passing environment identifier
6925!> \par MPI mapping
6926!> mpi_scatter
6927! **************************************************************************************************
6928 SUBROUTINE mp_iscatter_iv2(msg_scatter, msg, root, comm, request)
6929 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:, :)
6930 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6931 INTEGER, INTENT(IN) :: root
6932 CLASS(mp_comm_type), INTENT(IN) :: comm
6933 TYPE(mp_request_type), INTENT(OUT) :: request
6934
6935 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_iv2'
6936
6937 INTEGER :: handle
6938#if defined(__parallel)
6939 INTEGER :: ierr, msglen
6940#endif
6941
6942 CALL mp_timeset(routinen, handle)
6943
6944#if defined(__parallel)
6945#if !defined(__GNUC__) || __GNUC__ >= 9
6946 cpassert(is_contiguous(msg_scatter))
6947#endif
6948 msglen = SIZE(msg)
6949 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer, msg, &
6950 msglen, mpi_integer, root, comm%handle, request%handle, ierr)
6951 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
6952 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6953#else
6954 mark_used(root)
6955 mark_used(comm)
6956 msg(:) = msg_scatter(:, 1)
6957 request = mp_request_null
6958#endif
6959 CALL mp_timestop(handle)
6960 END SUBROUTINE mp_iscatter_iv2
6961
6962! **************************************************************************************************
6963!> \brief Scatters data from one processes to all others
6964!> \param[in] msg_scatter Data to scatter (for root process)
6965!> \param[in] root Process which scatters data
6966!> \param[in] comm Message passing environment identifier
6967!> \par MPI mapping
6968!> mpi_scatter
6969! **************************************************************************************************
6970 SUBROUTINE mp_iscatterv_iv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
6971 INTEGER(KIND=int_4), INTENT(IN) :: msg_scatter(:)
6972 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
6973 INTEGER(KIND=int_4), INTENT(INOUT) :: msg(:)
6974 INTEGER, INTENT(IN) :: recvcount, root
6975 CLASS(mp_comm_type), INTENT(IN) :: comm
6976 TYPE(mp_request_type), INTENT(OUT) :: request
6977
6978 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_iv'
6979
6980 INTEGER :: handle
6981#if defined(__parallel)
6982 INTEGER :: ierr
6983#endif
6984
6985 CALL mp_timeset(routinen, handle)
6986
6987#if defined(__parallel)
6988#if !defined(__GNUC__) || __GNUC__ >= 9
6989 cpassert(is_contiguous(msg_scatter))
6990 cpassert(is_contiguous(msg))
6991 cpassert(is_contiguous(sendcounts))
6992 cpassert(is_contiguous(displs))
6993#endif
6994 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_integer, msg, &
6995 recvcount, mpi_integer, root, comm%handle, request%handle, ierr)
6996 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
6997 CALL add_perf(perf_id=24, count=1, msg_size=1*int_4_size)
6998#else
6999 mark_used(sendcounts)
7000 mark_used(displs)
7001 mark_used(recvcount)
7002 mark_used(root)
7003 mark_used(comm)
7004 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
7005 request = mp_request_null
7006#endif
7007 CALL mp_timestop(handle)
7008 END SUBROUTINE mp_iscatterv_iv
7009
7010! **************************************************************************************************
7011!> \brief Gathers a datum from all processes to one
7012!> \param[in] msg Datum to send to root
7013!> \param[out] msg_gather Received data (on root)
7014!> \param[in] root Process which gathers the data
7015!> \param[in] comm Message passing environment identifier
7016!> \par MPI mapping
7017!> mpi_gather
7018! **************************************************************************************************
7019 SUBROUTINE mp_gather_i (msg, msg_gather, root, comm)
7020 INTEGER(KIND=int_4), INTENT(IN) :: msg
7021 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7022 INTEGER, INTENT(IN) :: root
7023 CLASS(mp_comm_type), INTENT(IN) :: comm
7024
7025 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_i'
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, root, 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(root)
7042 mark_used(comm)
7043 msg_gather(1) = msg
7044#endif
7045 CALL mp_timestop(handle)
7046 END SUBROUTINE mp_gather_i
7047
7048! **************************************************************************************************
7049!> \brief Gathers a datum from all processes to one, uses the source process of comm
7050!> \param[in] msg Datum to send to root
7051!> \param[out] msg_gather Received data (on root)
7052!> \param[in] comm Message passing environment identifier
7053!> \par MPI mapping
7054!> mpi_gather
7055! **************************************************************************************************
7056 SUBROUTINE mp_gather_i_src(msg, msg_gather, comm)
7057 INTEGER(KIND=int_4), INTENT(IN) :: msg
7058 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7059 CLASS(mp_comm_type), INTENT(IN) :: comm
7060
7061 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_i_src'
7062
7063 INTEGER :: handle
7064#if defined(__parallel)
7065 INTEGER :: ierr, msglen
7066#endif
7067
7068 CALL mp_timeset(routinen, handle)
7069
7070#if defined(__parallel)
7071 msglen = 1
7072 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7073 msglen, mpi_integer, comm%source, comm%handle, ierr)
7074 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7075 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7076#else
7077 mark_used(comm)
7078 msg_gather(1) = msg
7079#endif
7080 CALL mp_timestop(handle)
7081 END SUBROUTINE mp_gather_i_src
7082
7083! **************************************************************************************************
7084!> \brief Gathers data from all processes to one
7085!> \param[in] msg Datum to send to root
7086!> \param msg_gather ...
7087!> \param root ...
7088!> \param comm ...
7089!> \par Data length
7090!> All data (msg) is equal-sized
7091!> \par MPI mapping
7092!> mpi_gather
7093!> \note see mp_gather_i
7094! **************************************************************************************************
7095 SUBROUTINE mp_gather_iv(msg, msg_gather, root, comm)
7096 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
7097 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7098 INTEGER, INTENT(IN) :: root
7099 CLASS(mp_comm_type), INTENT(IN) :: comm
7100
7101 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_iv'
7102
7103 INTEGER :: handle
7104#if defined(__parallel)
7105 INTEGER :: ierr, msglen
7106#endif
7107
7108 CALL mp_timeset(routinen, handle)
7109
7110#if defined(__parallel)
7111 msglen = SIZE(msg)
7112 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7113 msglen, mpi_integer, root, comm%handle, ierr)
7114 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7115 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7116#else
7117 mark_used(root)
7118 mark_used(comm)
7119 msg_gather = msg
7120#endif
7121 CALL mp_timestop(handle)
7122 END SUBROUTINE mp_gather_iv
7123
7124! **************************************************************************************************
7125!> \brief Gathers data from all processes to one. Gathers from comm%source
7126!> \param[in] msg Datum to send to root
7127!> \param msg_gather ...
7128!> \param comm ...
7129!> \par Data length
7130!> All data (msg) is equal-sized
7131!> \par MPI mapping
7132!> mpi_gather
7133!> \note see mp_gather_i
7134! **************************************************************************************************
7135 SUBROUTINE mp_gather_iv_src(msg, msg_gather, comm)
7136 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
7137 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
7138 CLASS(mp_comm_type), INTENT(IN) :: comm
7139
7140 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_iv_src'
7141
7142 INTEGER :: handle
7143#if defined(__parallel)
7144 INTEGER :: ierr, msglen
7145#endif
7146
7147 CALL mp_timeset(routinen, handle)
7148
7149#if defined(__parallel)
7150 msglen = SIZE(msg)
7151 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7152 msglen, mpi_integer, comm%source, comm%handle, ierr)
7153 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7154 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7155#else
7156 mark_used(comm)
7157 msg_gather = msg
7158#endif
7159 CALL mp_timestop(handle)
7160 END SUBROUTINE mp_gather_iv_src
7161
7162! **************************************************************************************************
7163!> \brief Gathers data from all processes to one
7164!> \param[in] msg Datum to send to root
7165!> \param msg_gather ...
7166!> \param root ...
7167!> \param comm ...
7168!> \par Data length
7169!> All data (msg) is equal-sized
7170!> \par MPI mapping
7171!> mpi_gather
7172!> \note see mp_gather_i
7173! **************************************************************************************************
7174 SUBROUTINE mp_gather_im(msg, msg_gather, root, comm)
7175 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
7176 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
7177 INTEGER, INTENT(IN) :: root
7178 CLASS(mp_comm_type), INTENT(IN) :: comm
7179
7180 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_im'
7181
7182 INTEGER :: handle
7183#if defined(__parallel)
7184 INTEGER :: ierr, msglen
7185#endif
7186
7187 CALL mp_timeset(routinen, handle)
7188
7189#if defined(__parallel)
7190 msglen = SIZE(msg)
7191 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7192 msglen, mpi_integer, root, comm%handle, ierr)
7193 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7194 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7195#else
7196 mark_used(root)
7197 mark_used(comm)
7198 msg_gather = msg
7199#endif
7200 CALL mp_timestop(handle)
7201 END SUBROUTINE mp_gather_im
7202
7203! **************************************************************************************************
7204!> \brief Gathers data from all processes to one. Gathers from comm%source
7205!> \param[in] msg Datum to send to root
7206!> \param msg_gather ...
7207!> \param comm ...
7208!> \par Data length
7209!> All data (msg) is equal-sized
7210!> \par MPI mapping
7211!> mpi_gather
7212!> \note see mp_gather_i
7213! **************************************************************************************************
7214 SUBROUTINE mp_gather_im_src(msg, msg_gather, comm)
7215 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
7216 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
7217 CLASS(mp_comm_type), INTENT(IN) :: comm
7218
7219 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_im_src'
7220
7221 INTEGER :: handle
7222#if defined(__parallel)
7223 INTEGER :: ierr, msglen
7224#endif
7225
7226 CALL mp_timeset(routinen, handle)
7227
7228#if defined(__parallel)
7229 msglen = SIZE(msg)
7230 CALL mpi_gather(msg, msglen, mpi_integer, msg_gather, &
7231 msglen, mpi_integer, comm%source, comm%handle, ierr)
7232 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
7233 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_4_size)
7234#else
7235 mark_used(comm)
7236 msg_gather = msg
7237#endif
7238 CALL mp_timestop(handle)
7239 END SUBROUTINE mp_gather_im_src
7240
7241! **************************************************************************************************
7242!> \brief Gathers data from all processes to one.
7243!> \param[in] sendbuf Data to send to root
7244!> \param[out] recvbuf Received data (on root)
7245!> \param[in] recvcounts Sizes of data received from processes
7246!> \param[in] displs Offsets of data received from processes
7247!> \param[in] root Process which gathers the data
7248!> \param[in] comm Message passing environment identifier
7249!> \par Data length
7250!> Data can have different lengths
7251!> \par Offsets
7252!> Offsets start at 0
7253!> \par MPI mapping
7254!> mpi_gather
7255! **************************************************************************************************
7256 SUBROUTINE mp_gatherv_iv(sendbuf, recvbuf, recvcounts, displs, root, comm)
7257
7258 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
7259 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
7260 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7261 INTEGER, INTENT(IN) :: root
7262 CLASS(mp_comm_type), INTENT(IN) :: comm
7263
7264 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_iv'
7265
7266 INTEGER :: handle
7267#if defined(__parallel)
7268 INTEGER :: ierr, sendcount
7269#endif
7270
7271 CALL mp_timeset(routinen, handle)
7272
7273#if defined(__parallel)
7274 sendcount = SIZE(sendbuf)
7275 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7276 recvbuf, recvcounts, displs, mpi_integer, &
7277 root, comm%handle, ierr)
7278 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7279 CALL add_perf(perf_id=4, &
7280 count=1, &
7281 msg_size=sendcount*int_4_size)
7282#else
7283 mark_used(recvcounts)
7284 mark_used(root)
7285 mark_used(comm)
7286 recvbuf(1 + displs(1):) = sendbuf
7287#endif
7288 CALL mp_timestop(handle)
7289 END SUBROUTINE mp_gatherv_iv
7290
7291! **************************************************************************************************
7292!> \brief Gathers data from all processes to one. Gathers from comm%source
7293!> \param[in] sendbuf Data to send to root
7294!> \param[out] recvbuf Received data (on root)
7295!> \param[in] recvcounts Sizes of data received from processes
7296!> \param[in] displs Offsets of data received from processes
7297!> \param[in] comm Message passing environment identifier
7298!> \par Data length
7299!> Data can have different lengths
7300!> \par Offsets
7301!> Offsets start at 0
7302!> \par MPI mapping
7303!> mpi_gather
7304! **************************************************************************************************
7305 SUBROUTINE mp_gatherv_iv_src(sendbuf, recvbuf, recvcounts, displs, comm)
7306
7307 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
7308 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
7309 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7310 CLASS(mp_comm_type), INTENT(IN) :: comm
7311
7312 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_iv_src'
7313
7314 INTEGER :: handle
7315#if defined(__parallel)
7316 INTEGER :: ierr, sendcount
7317#endif
7318
7319 CALL mp_timeset(routinen, handle)
7320
7321#if defined(__parallel)
7322 sendcount = SIZE(sendbuf)
7323 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7324 recvbuf, recvcounts, displs, mpi_integer, &
7325 comm%source, comm%handle, ierr)
7326 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7327 CALL add_perf(perf_id=4, &
7328 count=1, &
7329 msg_size=sendcount*int_4_size)
7330#else
7331 mark_used(recvcounts)
7332 mark_used(comm)
7333 recvbuf(1 + displs(1):) = sendbuf
7334#endif
7335 CALL mp_timestop(handle)
7336 END SUBROUTINE mp_gatherv_iv_src
7337
7338! **************************************************************************************************
7339!> \brief Gathers data from all processes to one.
7340!> \param[in] sendbuf Data to send to root
7341!> \param[out] recvbuf Received data (on root)
7342!> \param[in] recvcounts Sizes of data received from processes
7343!> \param[in] displs Offsets of data received from processes
7344!> \param[in] root Process which gathers the data
7345!> \param[in] comm Message passing environment identifier
7346!> \par Data length
7347!> Data can have different lengths
7348!> \par Offsets
7349!> Offsets start at 0
7350!> \par MPI mapping
7351!> mpi_gather
7352! **************************************************************************************************
7353 SUBROUTINE mp_gatherv_im2(sendbuf, recvbuf, recvcounts, displs, root, comm)
7354
7355 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
7356 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
7357 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7358 INTEGER, INTENT(IN) :: root
7359 CLASS(mp_comm_type), INTENT(IN) :: comm
7360
7361 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_im2'
7362
7363 INTEGER :: handle
7364#if defined(__parallel)
7365 INTEGER :: ierr, sendcount
7366#endif
7367
7368 CALL mp_timeset(routinen, handle)
7369
7370#if defined(__parallel)
7371 sendcount = SIZE(sendbuf)
7372 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7373 recvbuf, recvcounts, displs, mpi_integer, &
7374 root, comm%handle, ierr)
7375 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7376 CALL add_perf(perf_id=4, &
7377 count=1, &
7378 msg_size=sendcount*int_4_size)
7379#else
7380 mark_used(recvcounts)
7381 mark_used(root)
7382 mark_used(comm)
7383 recvbuf(:, 1 + displs(1):) = sendbuf
7384#endif
7385 CALL mp_timestop(handle)
7386 END SUBROUTINE mp_gatherv_im2
7387
7388! **************************************************************************************************
7389!> \brief Gathers data from all processes to one.
7390!> \param[in] sendbuf Data to send to root
7391!> \param[out] recvbuf Received data (on root)
7392!> \param[in] recvcounts Sizes of data received from processes
7393!> \param[in] displs Offsets of data received from processes
7394!> \param[in] comm Message passing environment identifier
7395!> \par Data length
7396!> Data can have different lengths
7397!> \par Offsets
7398!> Offsets start at 0
7399!> \par MPI mapping
7400!> mpi_gather
7401! **************************************************************************************************
7402 SUBROUTINE mp_gatherv_im2_src(sendbuf, recvbuf, recvcounts, displs, comm)
7403
7404 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
7405 INTEGER(KIND=int_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
7406 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7407 CLASS(mp_comm_type), INTENT(IN) :: comm
7408
7409 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_im2_src'
7410
7411 INTEGER :: handle
7412#if defined(__parallel)
7413 INTEGER :: ierr, sendcount
7414#endif
7415
7416 CALL mp_timeset(routinen, handle)
7417
7418#if defined(__parallel)
7419 sendcount = SIZE(sendbuf)
7420 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer, &
7421 recvbuf, recvcounts, displs, mpi_integer, &
7422 comm%source, comm%handle, ierr)
7423 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7424 CALL add_perf(perf_id=4, &
7425 count=1, &
7426 msg_size=sendcount*int_4_size)
7427#else
7428 mark_used(recvcounts)
7429 mark_used(comm)
7430 recvbuf(:, 1 + displs(1):) = sendbuf
7431#endif
7432 CALL mp_timestop(handle)
7433 END SUBROUTINE mp_gatherv_im2_src
7434
7435! **************************************************************************************************
7436!> \brief Gathers data from all processes to one.
7437!> \param[in] sendbuf Data to send to root
7438!> \param[out] recvbuf Received data (on root)
7439!> \param[in] recvcounts Sizes of data received from processes
7440!> \param[in] displs Offsets of data received from processes
7441!> \param[in] root Process which gathers the data
7442!> \param[in] comm Message passing environment identifier
7443!> \par Data length
7444!> Data can have different lengths
7445!> \par Offsets
7446!> Offsets start at 0
7447!> \par MPI mapping
7448!> mpi_gather
7449! **************************************************************************************************
7450 SUBROUTINE mp_igatherv_iv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
7451 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: sendbuf
7452 INTEGER(KIND=int_4), DIMENSION(:), INTENT(OUT) :: recvbuf
7453 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
7454 INTEGER, INTENT(IN) :: sendcount, root
7455 CLASS(mp_comm_type), INTENT(IN) :: comm
7456 TYPE(mp_request_type), INTENT(OUT) :: request
7457
7458 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_iv'
7459
7460 INTEGER :: handle
7461#if defined(__parallel)
7462 INTEGER :: ierr
7463#endif
7464
7465 CALL mp_timeset(routinen, handle)
7466
7467#if defined(__parallel)
7468#if !defined(__GNUC__) || __GNUC__ >= 9
7469 cpassert(is_contiguous(sendbuf))
7470 cpassert(is_contiguous(recvbuf))
7471 cpassert(is_contiguous(recvcounts))
7472 cpassert(is_contiguous(displs))
7473#endif
7474 CALL mpi_igatherv(sendbuf, sendcount, mpi_integer, &
7475 recvbuf, recvcounts, displs, mpi_integer, &
7476 root, comm%handle, request%handle, ierr)
7477 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
7478 CALL add_perf(perf_id=24, &
7479 count=1, &
7480 msg_size=sendcount*int_4_size)
7481#else
7482 mark_used(sendcount)
7483 mark_used(recvcounts)
7484 mark_used(root)
7485 mark_used(comm)
7486 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
7487 request = mp_request_null
7488#endif
7489 CALL mp_timestop(handle)
7490 END SUBROUTINE mp_igatherv_iv
7491
7492! **************************************************************************************************
7493!> \brief Gathers a datum from all processes and all processes receive the
7494!> same data
7495!> \param[in] msgout Datum to send
7496!> \param[out] msgin Received data
7497!> \param[in] comm Message passing environment identifier
7498!> \par Data size
7499!> All processes send equal-sized data
7500!> \par MPI mapping
7501!> mpi_allgather
7502! **************************************************************************************************
7503 SUBROUTINE mp_allgather_i (msgout, msgin, comm)
7504 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7505 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
7506 CLASS(mp_comm_type), INTENT(IN) :: comm
7507
7508 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i'
7509
7510 INTEGER :: handle
7511#if defined(__parallel)
7512 INTEGER :: ierr, rcount, scount
7513#endif
7514
7515 CALL mp_timeset(routinen, handle)
7516
7517#if defined(__parallel)
7518 scount = 1
7519 rcount = 1
7520 CALL mpi_allgather(msgout, scount, mpi_integer, &
7521 msgin, rcount, mpi_integer, &
7522 comm%handle, ierr)
7523 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7524#else
7525 mark_used(comm)
7526 msgin = msgout
7527#endif
7528 CALL mp_timestop(handle)
7529 END SUBROUTINE mp_allgather_i
7530
7531! **************************************************************************************************
7532!> \brief Gathers a datum from all processes and all processes receive the
7533!> same data
7534!> \param[in] msgout Datum to send
7535!> \param[out] msgin Received data
7536!> \param[in] comm Message passing environment identifier
7537!> \par Data size
7538!> All processes send equal-sized data
7539!> \par MPI mapping
7540!> mpi_allgather
7541! **************************************************************************************************
7542 SUBROUTINE mp_allgather_i2(msgout, msgin, comm)
7543 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7544 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7545 CLASS(mp_comm_type), INTENT(IN) :: comm
7546
7547 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i2'
7548
7549 INTEGER :: handle
7550#if defined(__parallel)
7551 INTEGER :: ierr, rcount, scount
7552#endif
7553
7554 CALL mp_timeset(routinen, handle)
7555
7556#if defined(__parallel)
7557 scount = 1
7558 rcount = 1
7559 CALL mpi_allgather(msgout, scount, mpi_integer, &
7560 msgin, rcount, mpi_integer, &
7561 comm%handle, ierr)
7562 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7563#else
7564 mark_used(comm)
7565 msgin = msgout
7566#endif
7567 CALL mp_timestop(handle)
7568 END SUBROUTINE mp_allgather_i2
7569
7570! **************************************************************************************************
7571!> \brief Gathers a datum from all processes and all processes receive the
7572!> same data
7573!> \param[in] msgout Datum to send
7574!> \param[out] msgin Received data
7575!> \param[in] comm Message passing environment identifier
7576!> \par Data size
7577!> All processes send equal-sized data
7578!> \par MPI mapping
7579!> mpi_allgather
7580! **************************************************************************************************
7581 SUBROUTINE mp_iallgather_i (msgout, msgin, comm, request)
7582 INTEGER(KIND=int_4), INTENT(IN) :: msgout
7583 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7584 CLASS(mp_comm_type), INTENT(IN) :: comm
7585 TYPE(mp_request_type), INTENT(OUT) :: request
7586
7587 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i'
7588
7589 INTEGER :: handle
7590#if defined(__parallel)
7591 INTEGER :: ierr, rcount, scount
7592#endif
7593
7594 CALL mp_timeset(routinen, handle)
7595
7596#if defined(__parallel)
7597#if !defined(__GNUC__) || __GNUC__ >= 9
7598 cpassert(is_contiguous(msgin))
7599#endif
7600 scount = 1
7601 rcount = 1
7602 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7603 msgin, rcount, mpi_integer, &
7604 comm%handle, request%handle, ierr)
7605 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7606#else
7607 mark_used(comm)
7608 msgin = msgout
7609 request = mp_request_null
7610#endif
7611 CALL mp_timestop(handle)
7612 END SUBROUTINE mp_iallgather_i
7613
7614! **************************************************************************************************
7615!> \brief Gathers vector data from all processes and all processes receive the
7616!> same data
7617!> \param[in] msgout Rank-1 data to send
7618!> \param[out] msgin Received data
7619!> \param[in] comm Message passing environment identifier
7620!> \par Data size
7621!> All processes send equal-sized data
7622!> \par Ranks
7623!> The last rank counts the processes
7624!> \par MPI mapping
7625!> mpi_allgather
7626! **************************************************************************************************
7627 SUBROUTINE mp_allgather_i12(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_i12'
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_i12
7654
7655! **************************************************************************************************
7656!> \brief Gathers matrix data from all processes and all processes receive the
7657!> same data
7658!> \param[in] msgout Rank-2 data to send
7659!> \param msgin ...
7660!> \param comm ...
7661!> \note see mp_allgather_i12
7662! **************************************************************************************************
7663 SUBROUTINE mp_allgather_i23(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_i23'
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_i23
7690
7691! **************************************************************************************************
7692!> \brief Gathers rank-3 data from all processes and all processes receive the
7693!> same data
7694!> \param[in] msgout Rank-3 data to send
7695!> \param msgin ...
7696!> \param comm ...
7697!> \note see mp_allgather_i12
7698! **************************************************************************************************
7699 SUBROUTINE mp_allgather_i34(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_i34'
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(:, :, :, 1) = msgout(:, :, :)
7723#endif
7724 CALL mp_timestop(handle)
7725 END SUBROUTINE mp_allgather_i34
7726
7727! **************************************************************************************************
7728!> \brief Gathers rank-2 data from all processes and all processes receive the
7729!> same data
7730!> \param[in] msgout Rank-2 data to send
7731!> \param msgin ...
7732!> \param comm ...
7733!> \note see mp_allgather_i12
7734! **************************************************************************************************
7735 SUBROUTINE mp_allgather_i22(msgout, msgin, comm)
7736 INTEGER(KIND=int_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
7737 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
7738 CLASS(mp_comm_type), INTENT(IN) :: comm
7739
7740 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_i22'
7741
7742 INTEGER :: handle
7743#if defined(__parallel)
7744 INTEGER :: ierr, rcount, scount
7745#endif
7746
7747 CALL mp_timeset(routinen, handle)
7748
7749#if defined(__parallel)
7750 scount = SIZE(msgout(:, :))
7751 rcount = scount
7752 CALL mpi_allgather(msgout, scount, mpi_integer, &
7753 msgin, rcount, mpi_integer, &
7754 comm%handle, ierr)
7755 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
7756#else
7757 mark_used(comm)
7758 msgin(:, :) = msgout(:, :)
7759#endif
7760 CALL mp_timestop(handle)
7761 END SUBROUTINE mp_allgather_i22
7762
7763! **************************************************************************************************
7764!> \brief Gathers rank-1 data from all processes and all processes receive the
7765!> same data
7766!> \param[in] msgout Rank-1 data to send
7767!> \param msgin ...
7768!> \param comm ...
7769!> \param request ...
7770!> \note see mp_allgather_i11
7771! **************************************************************************************************
7772 SUBROUTINE mp_iallgather_i11(msgout, msgin, comm, request)
7773 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7774 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
7775 CLASS(mp_comm_type), INTENT(IN) :: comm
7776 TYPE(mp_request_type), INTENT(OUT) :: request
7777
7778 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i11'
7779
7780 INTEGER :: handle
7781#if defined(__parallel)
7782 INTEGER :: ierr, rcount, scount
7783#endif
7784
7785 CALL mp_timeset(routinen, handle)
7786
7787#if defined(__parallel)
7788#if !defined(__GNUC__) || __GNUC__ >= 9
7789 cpassert(is_contiguous(msgout))
7790 cpassert(is_contiguous(msgin))
7791#endif
7792 scount = SIZE(msgout(:))
7793 rcount = scount
7794 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7795 msgin, rcount, mpi_integer, &
7796 comm%handle, request%handle, ierr)
7797 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7798#else
7799 mark_used(comm)
7800 msgin = msgout
7801 request = mp_request_null
7802#endif
7803 CALL mp_timestop(handle)
7804 END SUBROUTINE mp_iallgather_i11
7805
7806! **************************************************************************************************
7807!> \brief Gathers rank-2 data from all processes and all processes receive the
7808!> same data
7809!> \param[in] msgout Rank-2 data to send
7810!> \param msgin ...
7811!> \param comm ...
7812!> \param request ...
7813!> \note see mp_allgather_i12
7814! **************************************************************************************************
7815 SUBROUTINE mp_iallgather_i13(msgout, msgin, comm, request)
7816 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
7817 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :)
7818 CLASS(mp_comm_type), INTENT(IN) :: comm
7819 TYPE(mp_request_type), INTENT(OUT) :: request
7820
7821 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i13'
7822
7823 INTEGER :: handle
7824#if defined(__parallel)
7825 INTEGER :: ierr, rcount, scount
7826#endif
7827
7828 CALL mp_timeset(routinen, handle)
7829
7830#if defined(__parallel)
7831#if !defined(__GNUC__) || __GNUC__ >= 9
7832 cpassert(is_contiguous(msgout))
7833 cpassert(is_contiguous(msgin))
7834#endif
7835
7836 scount = SIZE(msgout(:))
7837 rcount = scount
7838 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7839 msgin, rcount, mpi_integer, &
7840 comm%handle, request%handle, ierr)
7841 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7842#else
7843 mark_used(comm)
7844 msgin(:, 1, 1) = msgout(:)
7845 request = mp_request_null
7846#endif
7847 CALL mp_timestop(handle)
7848 END SUBROUTINE mp_iallgather_i13
7849
7850! **************************************************************************************************
7851!> \brief Gathers rank-2 data from all processes and all processes receive the
7852!> same data
7853!> \param[in] msgout Rank-2 data to send
7854!> \param msgin ...
7855!> \param comm ...
7856!> \param request ...
7857!> \note see mp_allgather_i12
7858! **************************************************************************************************
7859 SUBROUTINE mp_iallgather_i22(msgout, msgin, comm, request)
7860 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :)
7861 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :)
7862 CLASS(mp_comm_type), INTENT(IN) :: comm
7863 TYPE(mp_request_type), INTENT(OUT) :: request
7864
7865 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i22'
7866
7867 INTEGER :: handle
7868#if defined(__parallel)
7869 INTEGER :: ierr, rcount, scount
7870#endif
7871
7872 CALL mp_timeset(routinen, handle)
7873
7874#if defined(__parallel)
7875#if !defined(__GNUC__) || __GNUC__ >= 9
7876 cpassert(is_contiguous(msgout))
7877 cpassert(is_contiguous(msgin))
7878#endif
7879
7880 scount = SIZE(msgout(:, :))
7881 rcount = scount
7882 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7883 msgin, rcount, mpi_integer, &
7884 comm%handle, request%handle, ierr)
7885 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7886#else
7887 mark_used(comm)
7888 msgin(:, :) = msgout(:, :)
7889 request = mp_request_null
7890#endif
7891 CALL mp_timestop(handle)
7892 END SUBROUTINE mp_iallgather_i22
7893
7894! **************************************************************************************************
7895!> \brief Gathers rank-2 data from all processes and all processes receive the
7896!> same data
7897!> \param[in] msgout Rank-2 data to send
7898!> \param msgin ...
7899!> \param comm ...
7900!> \param request ...
7901!> \note see mp_allgather_i12
7902! **************************************************************************************************
7903 SUBROUTINE mp_iallgather_i24(msgout, msgin, comm, request)
7904 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :)
7905 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :, :)
7906 CLASS(mp_comm_type), INTENT(IN) :: comm
7907 TYPE(mp_request_type), INTENT(OUT) :: request
7908
7909 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i24'
7910
7911 INTEGER :: handle
7912#if defined(__parallel)
7913 INTEGER :: ierr, rcount, scount
7914#endif
7915
7916 CALL mp_timeset(routinen, handle)
7917
7918#if defined(__parallel)
7919#if !defined(__GNUC__) || __GNUC__ >= 9
7920 cpassert(is_contiguous(msgout))
7921 cpassert(is_contiguous(msgin))
7922#endif
7923
7924 scount = SIZE(msgout(:, :))
7925 rcount = scount
7926 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7927 msgin, rcount, mpi_integer, &
7928 comm%handle, request%handle, ierr)
7929 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7930#else
7931 mark_used(comm)
7932 msgin(:, :, 1, 1) = msgout(:, :)
7933 request = mp_request_null
7934#endif
7935 CALL mp_timestop(handle)
7936 END SUBROUTINE mp_iallgather_i24
7937
7938! **************************************************************************************************
7939!> \brief Gathers rank-3 data from all processes and all processes receive the
7940!> same data
7941!> \param[in] msgout Rank-3 data to send
7942!> \param msgin ...
7943!> \param comm ...
7944!> \param request ...
7945!> \note see mp_allgather_i12
7946! **************************************************************************************************
7947 SUBROUTINE mp_iallgather_i33(msgout, msgin, comm, request)
7948 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:, :, :)
7949 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:, :, :)
7950 CLASS(mp_comm_type), INTENT(IN) :: comm
7951 TYPE(mp_request_type), INTENT(OUT) :: request
7952
7953 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_i33'
7954
7955 INTEGER :: handle
7956#if defined(__parallel)
7957 INTEGER :: ierr, rcount, scount
7958#endif
7959
7960 CALL mp_timeset(routinen, handle)
7961
7962#if defined(__parallel)
7963#if !defined(__GNUC__) || __GNUC__ >= 9
7964 cpassert(is_contiguous(msgout))
7965 cpassert(is_contiguous(msgin))
7966#endif
7967
7968 scount = SIZE(msgout(:, :, :))
7969 rcount = scount
7970 CALL mpi_iallgather(msgout, scount, mpi_integer, &
7971 msgin, rcount, mpi_integer, &
7972 comm%handle, request%handle, ierr)
7973 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
7974#else
7975 mark_used(comm)
7976 msgin(:, :, :) = msgout(:, :, :)
7977 request = mp_request_null
7978#endif
7979 CALL mp_timestop(handle)
7980 END SUBROUTINE mp_iallgather_i33
7981
7982! **************************************************************************************************
7983!> \brief Gathers vector data from all processes and all processes receive the
7984!> same data
7985!> \param[in] msgout Rank-1 data to send
7986!> \param[out] msgin Received data
7987!> \param[in] rcount Size of sent data for every process
7988!> \param[in] rdispl Offset of sent data for every process
7989!> \param[in] comm Message passing environment identifier
7990!> \par Data size
7991!> Processes can send different-sized data
7992!> \par Ranks
7993!> The last rank counts the processes
7994!> \par Offsets
7995!> Offsets are from 0
7996!> \par MPI mapping
7997!> mpi_allgather
7998! **************************************************************************************************
7999 SUBROUTINE mp_allgatherv_iv(msgout, msgin, rcount, rdispl, comm)
8000 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
8001 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
8002 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
8003 CLASS(mp_comm_type), INTENT(IN) :: comm
8004
8005 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_iv'
8006
8007 INTEGER :: handle
8008#if defined(__parallel)
8009 INTEGER :: ierr, scount
8010#endif
8011
8012 CALL mp_timeset(routinen, handle)
8013
8014#if defined(__parallel)
8015 scount = SIZE(msgout)
8016 CALL mpi_allgatherv(msgout, scount, mpi_integer, msgin, rcount, &
8017 rdispl, mpi_integer, comm%handle, ierr)
8018 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
8019#else
8020 mark_used(rcount)
8021 mark_used(rdispl)
8022 mark_used(comm)
8023 msgin = msgout
8024#endif
8025 CALL mp_timestop(handle)
8026 END SUBROUTINE mp_allgatherv_iv
8027
8028! **************************************************************************************************
8029!> \brief Gathers vector data from all processes and all processes receive the
8030!> same data
8031!> \param[in] msgout Rank-1 data to send
8032!> \param[out] msgin Received data
8033!> \param[in] rcount Size of sent data for every process
8034!> \param[in] rdispl Offset of sent data for every process
8035!> \param[in] comm Message passing environment identifier
8036!> \par Data size
8037!> Processes can send different-sized data
8038!> \par Ranks
8039!> The last rank counts the processes
8040!> \par Offsets
8041!> Offsets are from 0
8042!> \par MPI mapping
8043!> mpi_allgather
8044! **************************************************************************************************
8045 SUBROUTINE mp_allgatherv_im2(msgout, msgin, rcount, rdispl, comm)
8046 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
8047 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
8048 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
8049 CLASS(mp_comm_type), INTENT(IN) :: comm
8050
8051 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_iv'
8052
8053 INTEGER :: handle
8054#if defined(__parallel)
8055 INTEGER :: ierr, scount
8056#endif
8057
8058 CALL mp_timeset(routinen, handle)
8059
8060#if defined(__parallel)
8061 scount = SIZE(msgout)
8062 CALL mpi_allgatherv(msgout, scount, mpi_integer, msgin, rcount, &
8063 rdispl, mpi_integer, comm%handle, ierr)
8064 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
8065#else
8066 mark_used(rcount)
8067 mark_used(rdispl)
8068 mark_used(comm)
8069 msgin = msgout
8070#endif
8071 CALL mp_timestop(handle)
8072 END SUBROUTINE mp_allgatherv_im2
8073
8074! **************************************************************************************************
8075!> \brief Gathers vector data from all processes and all processes receive the
8076!> same data
8077!> \param[in] msgout Rank-1 data to send
8078!> \param[out] msgin Received data
8079!> \param[in] rcount Size of sent data for every process
8080!> \param[in] rdispl Offset of sent data for every process
8081!> \param[in] comm Message passing environment identifier
8082!> \par Data size
8083!> Processes can send different-sized data
8084!> \par Ranks
8085!> The last rank counts the processes
8086!> \par Offsets
8087!> Offsets are from 0
8088!> \par MPI mapping
8089!> mpi_allgather
8090! **************************************************************************************************
8091 SUBROUTINE mp_iallgatherv_iv(msgout, msgin, rcount, rdispl, comm, request)
8092 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
8093 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
8094 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
8095 CLASS(mp_comm_type), INTENT(IN) :: comm
8096 TYPE(mp_request_type), INTENT(OUT) :: request
8097
8098 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_iv'
8099
8100 INTEGER :: handle
8101#if defined(__parallel)
8102 INTEGER :: ierr, scount, rsize
8103#endif
8104
8105 CALL mp_timeset(routinen, handle)
8106
8107#if defined(__parallel)
8108#if !defined(__GNUC__) || __GNUC__ >= 9
8109 cpassert(is_contiguous(msgout))
8110 cpassert(is_contiguous(msgin))
8111 cpassert(is_contiguous(rcount))
8112 cpassert(is_contiguous(rdispl))
8113#endif
8114
8115 scount = SIZE(msgout)
8116 rsize = SIZE(rcount)
8117 CALL mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, &
8118 rdispl, comm, request, ierr)
8119 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
8120#else
8121 mark_used(rcount)
8122 mark_used(rdispl)
8123 mark_used(comm)
8124 msgin = msgout
8125 request = mp_request_null
8126#endif
8127 CALL mp_timestop(handle)
8128 END SUBROUTINE mp_iallgatherv_iv
8129
8130! **************************************************************************************************
8131!> \brief Gathers vector data from all processes and all processes receive the
8132!> same data
8133!> \param[in] msgout Rank-1 data to send
8134!> \param[out] msgin Received data
8135!> \param[in] rcount Size of sent data for every process
8136!> \param[in] rdispl Offset of sent data for every process
8137!> \param[in] comm Message passing environment identifier
8138!> \par Data size
8139!> Processes can send different-sized data
8140!> \par Ranks
8141!> The last rank counts the processes
8142!> \par Offsets
8143!> Offsets are from 0
8144!> \par MPI mapping
8145!> mpi_allgather
8146! **************************************************************************************************
8147 SUBROUTINE mp_iallgatherv_iv2(msgout, msgin, rcount, rdispl, comm, request)
8148 INTEGER(KIND=int_4), INTENT(IN) :: msgout(:)
8149 INTEGER(KIND=int_4), INTENT(OUT) :: msgin(:)
8150 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
8151 CLASS(mp_comm_type), INTENT(IN) :: comm
8152 TYPE(mp_request_type), INTENT(OUT) :: request
8153
8154 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_iv2'
8155
8156 INTEGER :: handle
8157#if defined(__parallel)
8158 INTEGER :: ierr, scount, rsize
8159#endif
8160
8161 CALL mp_timeset(routinen, handle)
8162
8163#if defined(__parallel)
8164#if !defined(__GNUC__) || __GNUC__ >= 9
8165 cpassert(is_contiguous(msgout))
8166 cpassert(is_contiguous(msgin))
8167 cpassert(is_contiguous(rcount))
8168 cpassert(is_contiguous(rdispl))
8169#endif
8170
8171 scount = SIZE(msgout)
8172 rsize = SIZE(rcount)
8173 CALL mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, &
8174 rdispl, comm, request, ierr)
8175 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
8176#else
8177 mark_used(rcount)
8178 mark_used(rdispl)
8179 mark_used(comm)
8180 msgin = msgout
8181 request = mp_request_null
8182#endif
8183 CALL mp_timestop(handle)
8184 END SUBROUTINE mp_iallgatherv_iv2
8185
8186! **************************************************************************************************
8187!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
8188!> the issue is with the rank of rcount and rdispl
8189!> \param count ...
8190!> \param array_of_requests ...
8191!> \param array_of_statuses ...
8192!> \param ierr ...
8193!> \author Alfio Lazzaro
8194! **************************************************************************************************
8195#if defined(__parallel)
8196 SUBROUTINE mp_iallgatherv_iv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
8197 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
8198 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
8199 INTEGER, INTENT(IN) :: rsize
8200 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
8201 CLASS(mp_comm_type), INTENT(IN) :: comm
8202 TYPE(mp_request_type), INTENT(OUT) :: request
8203 INTEGER, INTENT(INOUT) :: ierr
8204
8205 CALL mpi_iallgatherv(msgout, scount, mpi_integer, msgin, rcount, &
8206 rdispl, mpi_integer, comm%handle, request%handle, ierr)
8207
8208 END SUBROUTINE mp_iallgatherv_iv_internal
8209#endif
8210
8211! **************************************************************************************************
8212!> \brief Sums a vector and partitions the result among processes
8213!> \param[in] msgout Data to sum
8214!> \param[out] msgin Received portion of summed data
8215!> \param[in] rcount Partition sizes of the summed data for
8216!> every process
8217!> \param[in] comm Message passing environment identifier
8218! **************************************************************************************************
8219 SUBROUTINE mp_sum_scatter_iv(msgout, msgin, rcount, comm)
8220 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
8221 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
8222 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
8223 CLASS(mp_comm_type), INTENT(IN) :: comm
8224
8225 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_iv'
8226
8227 INTEGER :: handle
8228#if defined(__parallel)
8229 INTEGER :: ierr
8230#endif
8231
8232 CALL mp_timeset(routinen, handle)
8233
8234#if defined(__parallel)
8235 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_integer, mpi_sum, &
8236 comm%handle, ierr)
8237 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
8238
8239 CALL add_perf(perf_id=3, count=1, &
8240 msg_size=rcount(1)*2*int_4_size)
8241#else
8242 mark_used(rcount)
8243 mark_used(comm)
8244 msgin = msgout(:, 1)
8245#endif
8246 CALL mp_timestop(handle)
8247 END SUBROUTINE mp_sum_scatter_iv
8248
8249! **************************************************************************************************
8250!> \brief Sends and receives vector data
8251!> \param[in] msgin Data to send
8252!> \param[in] dest Process to send data to
8253!> \param[out] msgout Received data
8254!> \param[in] source Process from which to receive
8255!> \param[in] comm Message passing environment identifier
8256!> \param[in] tag Send and recv tag (default: 0)
8257! **************************************************************************************************
8258 SUBROUTINE mp_sendrecv_i (msgin, dest, msgout, source, comm, tag)
8259 INTEGER(KIND=int_4), INTENT(IN) :: msgin
8260 INTEGER, INTENT(IN) :: dest
8261 INTEGER(KIND=int_4), INTENT(OUT) :: msgout
8262 INTEGER, INTENT(IN) :: source
8263 CLASS(mp_comm_type), INTENT(IN) :: comm
8264 INTEGER, INTENT(IN), OPTIONAL :: tag
8265
8266 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_i'
8267
8268 INTEGER :: handle
8269#if defined(__parallel)
8270 INTEGER :: ierr, msglen_in, msglen_out, &
8271 recv_tag, send_tag
8272#endif
8273
8274 CALL mp_timeset(routinen, handle)
8275
8276#if defined(__parallel)
8277 msglen_in = 1
8278 msglen_out = 1
8279 send_tag = 0 ! cannot think of something better here, this might be dangerous
8280 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8281 IF (PRESENT(tag)) THEN
8282 send_tag = tag
8283 recv_tag = tag
8284 END IF
8285 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8286 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8287 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8288 CALL add_perf(perf_id=7, count=1, &
8289 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8290#else
8291 mark_used(dest)
8292 mark_used(source)
8293 mark_used(comm)
8294 mark_used(tag)
8295 msgout = msgin
8296#endif
8297 CALL mp_timestop(handle)
8298 END SUBROUTINE mp_sendrecv_i
8299
8300! **************************************************************************************************
8301!> \brief Sends and receives vector data
8302!> \param[in] msgin Data to send
8303!> \param[in] dest Process to send data to
8304!> \param[out] msgout Received data
8305!> \param[in] source Process from which to receive
8306!> \param[in] comm Message passing environment identifier
8307!> \param[in] tag Send and recv tag (default: 0)
8308! **************************************************************************************************
8309 SUBROUTINE mp_sendrecv_iv(msgin, dest, msgout, source, comm, tag)
8310 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
8311 INTEGER, INTENT(IN) :: dest
8312 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
8313 INTEGER, INTENT(IN) :: source
8314 CLASS(mp_comm_type), INTENT(IN) :: comm
8315 INTEGER, INTENT(IN), OPTIONAL :: tag
8316
8317 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_iv'
8318
8319 INTEGER :: handle
8320#if defined(__parallel)
8321 INTEGER :: ierr, msglen_in, msglen_out, &
8322 recv_tag, send_tag
8323#endif
8324
8325 CALL mp_timeset(routinen, handle)
8326
8327#if defined(__parallel)
8328 msglen_in = SIZE(msgin)
8329 msglen_out = SIZE(msgout)
8330 send_tag = 0 ! cannot think of something better here, this might be dangerous
8331 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8332 IF (PRESENT(tag)) THEN
8333 send_tag = tag
8334 recv_tag = tag
8335 END IF
8336 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8337 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8338 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8339 CALL add_perf(perf_id=7, count=1, &
8340 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8341#else
8342 mark_used(dest)
8343 mark_used(source)
8344 mark_used(comm)
8345 mark_used(tag)
8346 msgout = msgin
8347#endif
8348 CALL mp_timestop(handle)
8349 END SUBROUTINE mp_sendrecv_iv
8350
8351! **************************************************************************************************
8352!> \brief Sends and receives matrix data
8353!> \param msgin ...
8354!> \param dest ...
8355!> \param msgout ...
8356!> \param source ...
8357!> \param comm ...
8358!> \param tag ...
8359!> \note see mp_sendrecv_iv
8360! **************************************************************************************************
8361 SUBROUTINE mp_sendrecv_im2(msgin, dest, msgout, source, comm, tag)
8362 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
8363 INTEGER, INTENT(IN) :: dest
8364 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
8365 INTEGER, INTENT(IN) :: source
8366 CLASS(mp_comm_type), INTENT(IN) :: comm
8367 INTEGER, INTENT(IN), OPTIONAL :: tag
8368
8369 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im2'
8370
8371 INTEGER :: handle
8372#if defined(__parallel)
8373 INTEGER :: ierr, msglen_in, msglen_out, &
8374 recv_tag, send_tag
8375#endif
8376
8377 CALL mp_timeset(routinen, handle)
8378
8379#if defined(__parallel)
8380 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
8381 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
8382 send_tag = 0 ! cannot think of something better here, this might be dangerous
8383 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8384 IF (PRESENT(tag)) THEN
8385 send_tag = tag
8386 recv_tag = tag
8387 END IF
8388 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8389 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8390 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8391 CALL add_perf(perf_id=7, count=1, &
8392 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8393#else
8394 mark_used(dest)
8395 mark_used(source)
8396 mark_used(comm)
8397 mark_used(tag)
8398 msgout = msgin
8399#endif
8400 CALL mp_timestop(handle)
8401 END SUBROUTINE mp_sendrecv_im2
8402
8403! **************************************************************************************************
8404!> \brief Sends and receives rank-3 data
8405!> \param msgin ...
8406!> \param dest ...
8407!> \param msgout ...
8408!> \param source ...
8409!> \param comm ...
8410!> \note see mp_sendrecv_iv
8411! **************************************************************************************************
8412 SUBROUTINE mp_sendrecv_im3(msgin, dest, msgout, source, comm, tag)
8413 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
8414 INTEGER, INTENT(IN) :: dest
8415 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
8416 INTEGER, INTENT(IN) :: source
8417 CLASS(mp_comm_type), INTENT(IN) :: comm
8418 INTEGER, INTENT(IN), OPTIONAL :: tag
8419
8420 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im3'
8421
8422 INTEGER :: handle
8423#if defined(__parallel)
8424 INTEGER :: ierr, msglen_in, msglen_out, &
8425 recv_tag, send_tag
8426#endif
8427
8428 CALL mp_timeset(routinen, handle)
8429
8430#if defined(__parallel)
8431 msglen_in = SIZE(msgin)
8432 msglen_out = SIZE(msgout)
8433 send_tag = 0 ! cannot think of something better here, this might be dangerous
8434 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8435 IF (PRESENT(tag)) THEN
8436 send_tag = tag
8437 recv_tag = tag
8438 END IF
8439 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8440 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8441 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8442 CALL add_perf(perf_id=7, count=1, &
8443 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8444#else
8445 mark_used(dest)
8446 mark_used(source)
8447 mark_used(comm)
8448 mark_used(tag)
8449 msgout = msgin
8450#endif
8451 CALL mp_timestop(handle)
8452 END SUBROUTINE mp_sendrecv_im3
8453
8454! **************************************************************************************************
8455!> \brief Sends and receives rank-4 data
8456!> \param msgin ...
8457!> \param dest ...
8458!> \param msgout ...
8459!> \param source ...
8460!> \param comm ...
8461!> \note see mp_sendrecv_iv
8462! **************************************************************************************************
8463 SUBROUTINE mp_sendrecv_im4(msgin, dest, msgout, source, comm, tag)
8464 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
8465 INTEGER, INTENT(IN) :: dest
8466 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
8467 INTEGER, INTENT(IN) :: source
8468 CLASS(mp_comm_type), INTENT(IN) :: comm
8469 INTEGER, INTENT(IN), OPTIONAL :: tag
8470
8471 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_im4'
8472
8473 INTEGER :: handle
8474#if defined(__parallel)
8475 INTEGER :: ierr, msglen_in, msglen_out, &
8476 recv_tag, send_tag
8477#endif
8478
8479 CALL mp_timeset(routinen, handle)
8480
8481#if defined(__parallel)
8482 msglen_in = SIZE(msgin)
8483 msglen_out = SIZE(msgout)
8484 send_tag = 0 ! cannot think of something better here, this might be dangerous
8485 recv_tag = 0 ! cannot think of something better here, this might be dangerous
8486 IF (PRESENT(tag)) THEN
8487 send_tag = tag
8488 recv_tag = tag
8489 END IF
8490 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer, dest, send_tag, msgout, &
8491 msglen_out, mpi_integer, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
8492 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
8493 CALL add_perf(perf_id=7, count=1, &
8494 msg_size=(msglen_in + msglen_out)*int_4_size/2)
8495#else
8496 mark_used(dest)
8497 mark_used(source)
8498 mark_used(comm)
8499 mark_used(tag)
8500 msgout = msgin
8501#endif
8502 CALL mp_timestop(handle)
8503 END SUBROUTINE mp_sendrecv_im4
8504
8505! **************************************************************************************************
8506!> \brief Non-blocking send and receive of a scalar
8507!> \param[in] msgin Scalar data to send
8508!> \param[in] dest Which process to send to
8509!> \param[out] msgout Receive data into this pointer
8510!> \param[in] source Process to receive from
8511!> \param[in] comm Message passing environment identifier
8512!> \param[out] send_request Request handle for the send
8513!> \param[out] recv_request Request handle for the receive
8514!> \param[in] tag (optional) tag to differentiate requests
8515!> \par Implementation
8516!> Calls mpi_isend and mpi_irecv.
8517!> \par History
8518!> 02.2005 created [Alfio Lazzaro]
8519! **************************************************************************************************
8520 SUBROUTINE mp_isendrecv_i (msgin, dest, msgout, source, comm, send_request, &
8521 recv_request, tag)
8522 INTEGER(KIND=int_4), INTENT(IN) :: msgin
8523 INTEGER, INTENT(IN) :: dest
8524 INTEGER(KIND=int_4), INTENT(INOUT) :: msgout
8525 INTEGER, INTENT(IN) :: source
8526 CLASS(mp_comm_type), INTENT(IN) :: comm
8527 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
8528 INTEGER, INTENT(in), OPTIONAL :: tag
8529
8530 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_i'
8531
8532 INTEGER :: handle
8533#if defined(__parallel)
8534 INTEGER :: ierr, my_tag
8535#endif
8536
8537 CALL mp_timeset(routinen, handle)
8538
8539#if defined(__parallel)
8540 my_tag = 0
8541 IF (PRESENT(tag)) my_tag = tag
8542
8543 CALL mpi_irecv(msgout, 1, mpi_integer, source, my_tag, &
8544 comm%handle, recv_request%handle, ierr)
8545 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8546
8547 CALL mpi_isend(msgin, 1, mpi_integer, dest, my_tag, &
8548 comm%handle, send_request%handle, ierr)
8549 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8550
8551 CALL add_perf(perf_id=8, count=1, msg_size=2*int_4_size)
8552#else
8553 mark_used(dest)
8554 mark_used(source)
8555 mark_used(comm)
8556 mark_used(tag)
8557 send_request = mp_request_null
8558 recv_request = mp_request_null
8559 msgout = msgin
8560#endif
8561 CALL mp_timestop(handle)
8562 END SUBROUTINE mp_isendrecv_i
8563
8564! **************************************************************************************************
8565!> \brief Non-blocking send and receive of a vector
8566!> \param[in] msgin Vector data to send
8567!> \param[in] dest Which process to send to
8568!> \param[out] msgout Receive data into this pointer
8569!> \param[in] source Process to receive from
8570!> \param[in] comm Message passing environment identifier
8571!> \param[out] send_request Request handle for the send
8572!> \param[out] recv_request Request handle for the receive
8573!> \param[in] tag (optional) tag to differentiate requests
8574!> \par Implementation
8575!> Calls mpi_isend and mpi_irecv.
8576!> \par History
8577!> 11.2004 created [Joost VandeVondele]
8578!> \note
8579!> arrays can be pointers or assumed shape, but they must be contiguous!
8580! **************************************************************************************************
8581 SUBROUTINE mp_isendrecv_iv(msgin, dest, msgout, source, comm, send_request, &
8582 recv_request, tag)
8583 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: msgin
8584 INTEGER, INTENT(IN) :: dest
8585 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT) :: msgout
8586 INTEGER, INTENT(IN) :: source
8587 CLASS(mp_comm_type), INTENT(IN) :: comm
8588 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
8589 INTEGER, INTENT(in), OPTIONAL :: tag
8590
8591 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_iv'
8592
8593 INTEGER :: handle
8594#if defined(__parallel)
8595 INTEGER :: ierr, msglen, my_tag
8596 INTEGER(KIND=int_4) :: foo
8597#endif
8598
8599 CALL mp_timeset(routinen, handle)
8600
8601#if defined(__parallel)
8602#if !defined(__GNUC__) || __GNUC__ >= 9
8603 cpassert(is_contiguous(msgout))
8604 cpassert(is_contiguous(msgin))
8605#endif
8606
8607 my_tag = 0
8608 IF (PRESENT(tag)) my_tag = tag
8609
8610 msglen = SIZE(msgout, 1)
8611 IF (msglen > 0) THEN
8612 CALL mpi_irecv(msgout(1), msglen, mpi_integer, source, my_tag, &
8613 comm%handle, recv_request%handle, ierr)
8614 ELSE
8615 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8616 comm%handle, recv_request%handle, ierr)
8617 END IF
8618 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8619
8620 msglen = SIZE(msgin, 1)
8621 IF (msglen > 0) THEN
8622 CALL mpi_isend(msgin(1), msglen, mpi_integer, dest, my_tag, &
8623 comm%handle, send_request%handle, ierr)
8624 ELSE
8625 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8626 comm%handle, send_request%handle, ierr)
8627 END IF
8628 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8629
8630 msglen = (msglen + SIZE(msgout, 1) + 1)/2
8631 CALL add_perf(perf_id=8, count=1, msg_size=msglen*int_4_size)
8632#else
8633 mark_used(dest)
8634 mark_used(source)
8635 mark_used(comm)
8636 mark_used(tag)
8637 send_request = mp_request_null
8638 recv_request = mp_request_null
8639 msgout = msgin
8640#endif
8641 CALL mp_timestop(handle)
8642 END SUBROUTINE mp_isendrecv_iv
8643
8644! **************************************************************************************************
8645!> \brief Non-blocking send of vector data
8646!> \param msgin ...
8647!> \param dest ...
8648!> \param comm ...
8649!> \param request ...
8650!> \param tag ...
8651!> \par History
8652!> 08.2003 created [f&j]
8653!> \note see mp_isendrecv_iv
8654!> \note
8655!> arrays can be pointers or assumed shape, but they must be contiguous!
8656! **************************************************************************************************
8657 SUBROUTINE mp_isend_iv(msgin, dest, comm, request, tag)
8658 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: msgin
8659 INTEGER, INTENT(IN) :: dest
8660 CLASS(mp_comm_type), INTENT(IN) :: comm
8661 TYPE(mp_request_type), INTENT(out) :: request
8662 INTEGER, INTENT(in), OPTIONAL :: tag
8663
8664 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_iv'
8665
8666 INTEGER :: handle, ierr
8667#if defined(__parallel)
8668 INTEGER :: msglen, my_tag
8669 INTEGER(KIND=int_4) :: foo(1)
8670#endif
8671
8672 CALL mp_timeset(routinen, handle)
8673
8674#if defined(__parallel)
8675#if !defined(__GNUC__) || __GNUC__ >= 9
8676 cpassert(is_contiguous(msgin))
8677#endif
8678 my_tag = 0
8679 IF (PRESENT(tag)) my_tag = tag
8680
8681 msglen = SIZE(msgin)
8682 IF (msglen > 0) THEN
8683 CALL mpi_isend(msgin(1), msglen, mpi_integer, dest, my_tag, &
8684 comm%handle, request%handle, ierr)
8685 ELSE
8686 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8687 comm%handle, request%handle, ierr)
8688 END IF
8689 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8690
8691 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8692#else
8693 mark_used(msgin)
8694 mark_used(dest)
8695 mark_used(comm)
8696 mark_used(request)
8697 mark_used(tag)
8698 ierr = 1
8699 request = mp_request_null
8700 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8701#endif
8702 CALL mp_timestop(handle)
8703 END SUBROUTINE mp_isend_iv
8704
8705! **************************************************************************************************
8706!> \brief Non-blocking send of matrix data
8707!> \param msgin ...
8708!> \param dest ...
8709!> \param comm ...
8710!> \param request ...
8711!> \param tag ...
8712!> \par History
8713!> 2009-11-25 [UB] Made type-generic for templates
8714!> \author fawzi
8715!> \note see mp_isendrecv_iv
8716!> \note see mp_isend_iv
8717!> \note
8718!> arrays can be pointers or assumed shape, but they must be contiguous!
8719! **************************************************************************************************
8720 SUBROUTINE mp_isend_im2(msgin, dest, comm, request, tag)
8721 INTEGER(KIND=int_4), DIMENSION(:, :), INTENT(IN) :: msgin
8722 INTEGER, INTENT(IN) :: dest
8723 CLASS(mp_comm_type), INTENT(IN) :: comm
8724 TYPE(mp_request_type), INTENT(out) :: request
8725 INTEGER, INTENT(in), OPTIONAL :: tag
8726
8727 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im2'
8728
8729 INTEGER :: handle, ierr
8730#if defined(__parallel)
8731 INTEGER :: msglen, my_tag
8732 INTEGER(KIND=int_4) :: foo(1)
8733#endif
8734
8735 CALL mp_timeset(routinen, handle)
8736
8737#if defined(__parallel)
8738#if !defined(__GNUC__) || __GNUC__ >= 9
8739 cpassert(is_contiguous(msgin))
8740#endif
8741
8742 my_tag = 0
8743 IF (PRESENT(tag)) my_tag = tag
8744
8745 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
8746 IF (msglen > 0) THEN
8747 CALL mpi_isend(msgin(1, 1), msglen, mpi_integer, dest, my_tag, &
8748 comm%handle, request%handle, ierr)
8749 ELSE
8750 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8751 comm%handle, request%handle, ierr)
8752 END IF
8753 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8754
8755 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8756#else
8757 mark_used(msgin)
8758 mark_used(dest)
8759 mark_used(comm)
8760 mark_used(request)
8761 mark_used(tag)
8762 ierr = 1
8763 request = mp_request_null
8764 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8765#endif
8766 CALL mp_timestop(handle)
8767 END SUBROUTINE mp_isend_im2
8768
8769! **************************************************************************************************
8770!> \brief Non-blocking send of rank-3 data
8771!> \param msgin ...
8772!> \param dest ...
8773!> \param comm ...
8774!> \param request ...
8775!> \param tag ...
8776!> \par History
8777!> 9.2008 added _rm3 subroutine [Iain Bethune]
8778!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
8779!> 2009-11-25 [UB] Made type-generic for templates
8780!> \author fawzi
8781!> \note see mp_isendrecv_iv
8782!> \note see mp_isend_iv
8783!> \note
8784!> arrays can be pointers or assumed shape, but they must be contiguous!
8785! **************************************************************************************************
8786 SUBROUTINE mp_isend_im3(msgin, dest, comm, request, tag)
8787 INTEGER(KIND=int_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
8788 INTEGER, INTENT(IN) :: dest
8789 CLASS(mp_comm_type), INTENT(IN) :: comm
8790 TYPE(mp_request_type), INTENT(out) :: request
8791 INTEGER, INTENT(in), OPTIONAL :: tag
8792
8793 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im3'
8794
8795 INTEGER :: handle, ierr
8796#if defined(__parallel)
8797 INTEGER :: msglen, my_tag
8798 INTEGER(KIND=int_4) :: foo(1)
8799#endif
8800
8801 CALL mp_timeset(routinen, handle)
8802
8803#if defined(__parallel)
8804#if !defined(__GNUC__) || __GNUC__ >= 9
8805 cpassert(is_contiguous(msgin))
8806#endif
8807
8808 my_tag = 0
8809 IF (PRESENT(tag)) my_tag = tag
8810
8811 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
8812 IF (msglen > 0) THEN
8813 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_integer, dest, my_tag, &
8814 comm%handle, request%handle, ierr)
8815 ELSE
8816 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8817 comm%handle, request%handle, ierr)
8818 END IF
8819 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8820
8821 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8822#else
8823 mark_used(msgin)
8824 mark_used(dest)
8825 mark_used(comm)
8826 mark_used(request)
8827 mark_used(tag)
8828 ierr = 1
8829 request = mp_request_null
8830 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8831#endif
8832 CALL mp_timestop(handle)
8833 END SUBROUTINE mp_isend_im3
8834
8835! **************************************************************************************************
8836!> \brief Non-blocking send of rank-4 data
8837!> \param msgin the input message
8838!> \param dest the destination processor
8839!> \param comm the communicator object
8840!> \param request the communication request id
8841!> \param tag the message tag
8842!> \par History
8843!> 2.2016 added _im4 subroutine [Nico Holmberg]
8844!> \author fawzi
8845!> \note see mp_isend_iv
8846!> \note
8847!> arrays can be pointers or assumed shape, but they must be contiguous!
8848! **************************************************************************************************
8849 SUBROUTINE mp_isend_im4(msgin, dest, comm, request, tag)
8850 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
8851 INTEGER, INTENT(IN) :: dest
8852 CLASS(mp_comm_type), INTENT(IN) :: comm
8853 TYPE(mp_request_type), INTENT(out) :: request
8854 INTEGER, INTENT(in), OPTIONAL :: tag
8855
8856 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_im4'
8857
8858 INTEGER :: handle, ierr
8859#if defined(__parallel)
8860 INTEGER :: msglen, my_tag
8861 INTEGER(KIND=int_4) :: foo(1)
8862#endif
8863
8864 CALL mp_timeset(routinen, handle)
8865
8866#if defined(__parallel)
8867#if !defined(__GNUC__) || __GNUC__ >= 9
8868 cpassert(is_contiguous(msgin))
8869#endif
8870
8871 my_tag = 0
8872 IF (PRESENT(tag)) my_tag = tag
8873
8874 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
8875 IF (msglen > 0) THEN
8876 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_integer, dest, my_tag, &
8877 comm%handle, request%handle, ierr)
8878 ELSE
8879 CALL mpi_isend(foo, msglen, mpi_integer, dest, my_tag, &
8880 comm%handle, request%handle, ierr)
8881 END IF
8882 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
8883
8884 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_4_size)
8885#else
8886 mark_used(msgin)
8887 mark_used(dest)
8888 mark_used(comm)
8889 mark_used(request)
8890 mark_used(tag)
8891 ierr = 1
8892 request = mp_request_null
8893 CALL mp_stop(ierr, "mp_isend called in non parallel case")
8894#endif
8895 CALL mp_timestop(handle)
8896 END SUBROUTINE mp_isend_im4
8897
8898! **************************************************************************************************
8899!> \brief Non-blocking receive of vector data
8900!> \param msgout ...
8901!> \param source ...
8902!> \param comm ...
8903!> \param request ...
8904!> \param tag ...
8905!> \par History
8906!> 08.2003 created [f&j]
8907!> 2009-11-25 [UB] Made type-generic for templates
8908!> \note see mp_isendrecv_iv
8909!> \note
8910!> arrays can be pointers or assumed shape, but they must be contiguous!
8911! **************************************************************************************************
8912 SUBROUTINE mp_irecv_iv(msgout, source, comm, request, tag)
8913 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT) :: msgout
8914 INTEGER, INTENT(IN) :: source
8915 CLASS(mp_comm_type), INTENT(IN) :: comm
8916 TYPE(mp_request_type), INTENT(out) :: request
8917 INTEGER, INTENT(in), OPTIONAL :: tag
8918
8919 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_iv'
8920
8921 INTEGER :: handle
8922#if defined(__parallel)
8923 INTEGER :: ierr, msglen, my_tag
8924 INTEGER(KIND=int_4) :: foo(1)
8925#endif
8926
8927 CALL mp_timeset(routinen, handle)
8928
8929#if defined(__parallel)
8930#if !defined(__GNUC__) || __GNUC__ >= 9
8931 cpassert(is_contiguous(msgout))
8932#endif
8933
8934 my_tag = 0
8935 IF (PRESENT(tag)) my_tag = tag
8936
8937 msglen = SIZE(msgout)
8938 IF (msglen > 0) THEN
8939 CALL mpi_irecv(msgout(1), msglen, mpi_integer, source, my_tag, &
8940 comm%handle, request%handle, ierr)
8941 ELSE
8942 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
8943 comm%handle, request%handle, ierr)
8944 END IF
8945 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
8946
8947 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
8948#else
8949 cpabort("mp_irecv called in non parallel case")
8950 mark_used(msgout)
8951 mark_used(source)
8952 mark_used(comm)
8953 mark_used(tag)
8954 request = mp_request_null
8955#endif
8956 CALL mp_timestop(handle)
8957 END SUBROUTINE mp_irecv_iv
8958
8959! **************************************************************************************************
8960!> \brief Non-blocking receive of matrix data
8961!> \param msgout ...
8962!> \param source ...
8963!> \param comm ...
8964!> \param request ...
8965!> \param tag ...
8966!> \par History
8967!> 2009-11-25 [UB] Made type-generic for templates
8968!> \author fawzi
8969!> \note see mp_isendrecv_iv
8970!> \note see mp_irecv_iv
8971!> \note
8972!> arrays can be pointers or assumed shape, but they must be contiguous!
8973! **************************************************************************************************
8974 SUBROUTINE mp_irecv_im2(msgout, source, comm, request, tag)
8975 INTEGER(KIND=int_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
8976 INTEGER, INTENT(IN) :: source
8977 CLASS(mp_comm_type), INTENT(IN) :: comm
8978 TYPE(mp_request_type), INTENT(out) :: request
8979 INTEGER, INTENT(in), OPTIONAL :: tag
8980
8981 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im2'
8982
8983 INTEGER :: handle
8984#if defined(__parallel)
8985 INTEGER :: ierr, msglen, my_tag
8986 INTEGER(KIND=int_4) :: foo(1)
8987#endif
8988
8989 CALL mp_timeset(routinen, handle)
8990
8991#if defined(__parallel)
8992#if !defined(__GNUC__) || __GNUC__ >= 9
8993 cpassert(is_contiguous(msgout))
8994#endif
8995
8996 my_tag = 0
8997 IF (PRESENT(tag)) my_tag = tag
8998
8999 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
9000 IF (msglen > 0) THEN
9001 CALL mpi_irecv(msgout(1, 1), msglen, mpi_integer, source, my_tag, &
9002 comm%handle, request%handle, ierr)
9003 ELSE
9004 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
9005 comm%handle, request%handle, ierr)
9006 END IF
9007 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
9008
9009 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
9010#else
9011 mark_used(msgout)
9012 mark_used(source)
9013 mark_used(comm)
9014 mark_used(tag)
9015 request = mp_request_null
9016 cpabort("mp_irecv called in non parallel case")
9017#endif
9018 CALL mp_timestop(handle)
9019 END SUBROUTINE mp_irecv_im2
9020
9021! **************************************************************************************************
9022!> \brief Non-blocking send of rank-3 data
9023!> \param msgout ...
9024!> \param source ...
9025!> \param comm ...
9026!> \param request ...
9027!> \param tag ...
9028!> \par History
9029!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
9030!> 2009-11-25 [UB] Made type-generic for templates
9031!> \author fawzi
9032!> \note see mp_isendrecv_iv
9033!> \note see mp_irecv_iv
9034!> \note
9035!> arrays can be pointers or assumed shape, but they must be contiguous!
9036! **************************************************************************************************
9037 SUBROUTINE mp_irecv_im3(msgout, source, comm, request, tag)
9038 INTEGER(KIND=int_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
9039 INTEGER, INTENT(IN) :: source
9040 CLASS(mp_comm_type), INTENT(IN) :: comm
9041 TYPE(mp_request_type), INTENT(out) :: request
9042 INTEGER, INTENT(in), OPTIONAL :: tag
9043
9044 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im3'
9045
9046 INTEGER :: handle
9047#if defined(__parallel)
9048 INTEGER :: ierr, msglen, my_tag
9049 INTEGER(KIND=int_4) :: foo(1)
9050#endif
9051
9052 CALL mp_timeset(routinen, handle)
9053
9054#if defined(__parallel)
9055#if !defined(__GNUC__) || __GNUC__ >= 9
9056 cpassert(is_contiguous(msgout))
9057#endif
9058
9059 my_tag = 0
9060 IF (PRESENT(tag)) my_tag = tag
9061
9062 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
9063 IF (msglen > 0) THEN
9064 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_integer, source, my_tag, &
9065 comm%handle, request%handle, ierr)
9066 ELSE
9067 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
9068 comm%handle, request%handle, ierr)
9069 END IF
9070 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
9071
9072 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
9073#else
9074 mark_used(msgout)
9075 mark_used(source)
9076 mark_used(comm)
9077 mark_used(tag)
9078 request = mp_request_null
9079 cpabort("mp_irecv called in non parallel case")
9080#endif
9081 CALL mp_timestop(handle)
9082 END SUBROUTINE mp_irecv_im3
9083
9084! **************************************************************************************************
9085!> \brief Non-blocking receive of rank-4 data
9086!> \param msgout the output message
9087!> \param source the source processor
9088!> \param comm the communicator object
9089!> \param request the communication request id
9090!> \param tag the message tag
9091!> \par History
9092!> 2.2016 added _im4 subroutine [Nico Holmberg]
9093!> \author fawzi
9094!> \note see mp_irecv_iv
9095!> \note
9096!> arrays can be pointers or assumed shape, but they must be contiguous!
9097! **************************************************************************************************
9098 SUBROUTINE mp_irecv_im4(msgout, source, comm, request, tag)
9099 INTEGER(KIND=int_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
9100 INTEGER, INTENT(IN) :: source
9101 CLASS(mp_comm_type), INTENT(IN) :: comm
9102 TYPE(mp_request_type), INTENT(out) :: request
9103 INTEGER, INTENT(in), OPTIONAL :: tag
9104
9105 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_im4'
9106
9107 INTEGER :: handle
9108#if defined(__parallel)
9109 INTEGER :: ierr, msglen, my_tag
9110 INTEGER(KIND=int_4) :: foo(1)
9111#endif
9112
9113 CALL mp_timeset(routinen, handle)
9114
9115#if defined(__parallel)
9116#if !defined(__GNUC__) || __GNUC__ >= 9
9117 cpassert(is_contiguous(msgout))
9118#endif
9119
9120 my_tag = 0
9121 IF (PRESENT(tag)) my_tag = tag
9122
9123 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
9124 IF (msglen > 0) THEN
9125 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_integer, source, my_tag, &
9126 comm%handle, request%handle, ierr)
9127 ELSE
9128 CALL mpi_irecv(foo, msglen, mpi_integer, source, my_tag, &
9129 comm%handle, request%handle, ierr)
9130 END IF
9131 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
9132
9133 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_4_size)
9134#else
9135 mark_used(msgout)
9136 mark_used(source)
9137 mark_used(comm)
9138 mark_used(tag)
9139 request = mp_request_null
9140 cpabort("mp_irecv called in non parallel case")
9141#endif
9142 CALL mp_timestop(handle)
9143 END SUBROUTINE mp_irecv_im4
9144
9145! **************************************************************************************************
9146!> \brief Window initialization function for vector data
9147!> \param base ...
9148!> \param comm ...
9149!> \param win ...
9150!> \par History
9151!> 02.2015 created [Alfio Lazzaro]
9152!> \note
9153!> arrays can be pointers or assumed shape, but they must be contiguous!
9154! **************************************************************************************************
9155 SUBROUTINE mp_win_create_iv(base, comm, win)
9156 INTEGER(KIND=int_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
9157 TYPE(mp_comm_type), INTENT(IN) :: comm
9158 CLASS(mp_win_type), INTENT(INOUT) :: win
9159
9160 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_iv'
9161
9162 INTEGER :: handle
9163#if defined(__parallel)
9164 INTEGER :: ierr
9165 INTEGER(kind=mpi_address_kind) :: len
9166 INTEGER(KIND=int_4) :: foo(1)
9167#endif
9168
9169 CALL mp_timeset(routinen, handle)
9170
9171#if defined(__parallel)
9172
9173 len = SIZE(base)*int_4_size
9174 IF (len > 0) THEN
9175 CALL mpi_win_create(base(1), len, int_4_size, mpi_info_null, comm%handle, win%handle, ierr)
9176 ELSE
9177 CALL mpi_win_create(foo, len, int_4_size, mpi_info_null, comm%handle, win%handle, ierr)
9178 END IF
9179 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
9180
9181 CALL add_perf(perf_id=20, count=1)
9182#else
9183 mark_used(base)
9184 mark_used(comm)
9185 win%handle = mp_win_null_handle
9186#endif
9187 CALL mp_timestop(handle)
9188 END SUBROUTINE mp_win_create_iv
9189
9190! **************************************************************************************************
9191!> \brief Single-sided get function for vector data
9192!> \param base ...
9193!> \param comm ...
9194!> \param win ...
9195!> \par History
9196!> 02.2015 created [Alfio Lazzaro]
9197!> \note
9198!> arrays can be pointers or assumed shape, but they must be contiguous!
9199! **************************************************************************************************
9200 SUBROUTINE mp_rget_iv(base, source, win, win_data, myproc, disp, request, &
9201 origin_datatype, target_datatype)
9202 INTEGER(KIND=int_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
9203 INTEGER, INTENT(IN) :: source
9204 CLASS(mp_win_type), INTENT(IN) :: win
9205 INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: win_data
9206 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
9207 TYPE(mp_request_type), INTENT(OUT) :: request
9208 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
9209
9210 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_iv'
9211
9212 INTEGER :: handle
9213#if defined(__parallel)
9214 INTEGER :: ierr, len, &
9215 origin_len, target_len
9216 LOGICAL :: do_local_copy
9217 INTEGER(kind=mpi_address_kind) :: disp_aint
9218 mpi_data_type :: handle_origin_datatype, handle_target_datatype
9219#endif
9220
9221 CALL mp_timeset(routinen, handle)
9222
9223#if defined(__parallel)
9224 len = SIZE(base)
9225 disp_aint = 0
9226 IF (PRESENT(disp)) THEN
9227 disp_aint = int(disp, kind=mpi_address_kind)
9228 END IF
9229 handle_origin_datatype = mpi_integer
9230 origin_len = len
9231 IF (PRESENT(origin_datatype)) THEN
9232 handle_origin_datatype = origin_datatype%type_handle
9233 origin_len = 1
9234 END IF
9235 handle_target_datatype = mpi_integer
9236 target_len = len
9237 IF (PRESENT(target_datatype)) THEN
9238 handle_target_datatype = target_datatype%type_handle
9239 target_len = 1
9240 END IF
9241 IF (len > 0) THEN
9242 do_local_copy = .false.
9243 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
9244 IF (myproc .EQ. source) do_local_copy = .true.
9245 END IF
9246 IF (do_local_copy) THEN
9247 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
9248 base(:) = win_data(disp_aint + 1:disp_aint + len)
9249 !$OMP END PARALLEL WORKSHARE
9250 request = mp_request_null
9251 ierr = 0
9252 ELSE
9253 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
9254 target_len, handle_target_datatype, win%handle, request%handle, ierr)
9255 END IF
9256 ELSE
9257 request = mp_request_null
9258 ierr = 0
9259 END IF
9260 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
9261
9262 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*int_4_size)
9263#else
9264 mark_used(source)
9265 mark_used(win)
9266 mark_used(myproc)
9267 mark_used(origin_datatype)
9268 mark_used(target_datatype)
9269
9270 request = mp_request_null
9271 !
9272 IF (PRESENT(disp)) THEN
9273 base(:) = win_data(disp + 1:disp + SIZE(base))
9274 ELSE
9275 base(:) = win_data(:SIZE(base))
9276 END IF
9277
9278#endif
9279 CALL mp_timestop(handle)
9280 END SUBROUTINE mp_rget_iv
9281
9282! **************************************************************************************************
9283!> \brief ...
9284!> \param count ...
9285!> \param lengths ...
9286!> \param displs ...
9287!> \return ...
9288! ***************************************************************************
9289 FUNCTION mp_type_indexed_make_i (count, lengths, displs) &
9290 result(type_descriptor)
9291 INTEGER, INTENT(IN) :: count
9292 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
9293 TYPE(mp_type_descriptor_type) :: type_descriptor
9294
9295 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_i'
9296
9297 INTEGER :: handle
9298#if defined(__parallel)
9299 INTEGER :: ierr
9300#endif
9301
9302 CALL mp_timeset(routinen, handle)
9303
9304#if defined(__parallel)
9305 CALL mpi_type_indexed(count, lengths, displs, mpi_integer, &
9306 type_descriptor%type_handle, ierr)
9307 IF (ierr /= 0) &
9308 cpabort("MPI_Type_Indexed @ "//routinen)
9309 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
9310 IF (ierr /= 0) &
9311 cpabort("MPI_Type_commit @ "//routinen)
9312#else
9313 type_descriptor%type_handle = 17
9314#endif
9315 type_descriptor%length = count
9316 NULLIFY (type_descriptor%subtype)
9317 type_descriptor%vector_descriptor(1:2) = 1
9318 type_descriptor%has_indexing = .true.
9319 type_descriptor%index_descriptor%index => lengths
9320 type_descriptor%index_descriptor%chunks => displs
9321
9322 CALL mp_timestop(handle)
9323
9324 END FUNCTION mp_type_indexed_make_i
9325
9326! **************************************************************************************************
9327!> \brief Allocates special parallel memory
9328!> \param[in] DATA pointer to integer array to allocate
9329!> \param[in] len number of integers to allocate
9330!> \param[out] stat (optional) allocation status result
9331!> \author UB
9332! **************************************************************************************************
9333 SUBROUTINE mp_allocate_i (DATA, len, stat)
9334 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
9335 INTEGER, INTENT(IN) :: len
9336 INTEGER, INTENT(OUT), OPTIONAL :: stat
9337
9338 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_i'
9339
9340 INTEGER :: handle, ierr
9341
9342 CALL mp_timeset(routinen, handle)
9343
9344#if defined(__parallel)
9345 NULLIFY (data)
9346 CALL mp_alloc_mem(DATA, len, stat=ierr)
9347 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
9348 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
9349 CALL add_perf(perf_id=15, count=1)
9350#else
9351 ALLOCATE (DATA(len), stat=ierr)
9352 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
9353 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
9354#endif
9355 IF (PRESENT(stat)) stat = ierr
9356 CALL mp_timestop(handle)
9357 END SUBROUTINE mp_allocate_i
9358
9359! **************************************************************************************************
9360!> \brief Deallocates special parallel memory
9361!> \param[in] DATA pointer to special memory to deallocate
9362!> \param stat ...
9363!> \author UB
9364! **************************************************************************************************
9365 SUBROUTINE mp_deallocate_i (DATA, stat)
9366 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
9367 INTEGER, INTENT(OUT), OPTIONAL :: stat
9368
9369 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_i'
9370
9371 INTEGER :: handle
9372#if defined(__parallel)
9373 INTEGER :: ierr
9374#endif
9375
9376 CALL mp_timeset(routinen, handle)
9377
9378#if defined(__parallel)
9379 CALL mp_free_mem(DATA, ierr)
9380 IF (PRESENT(stat)) THEN
9381 stat = ierr
9382 ELSE
9383 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
9384 END IF
9385 NULLIFY (data)
9386 CALL add_perf(perf_id=15, count=1)
9387#else
9388 DEALLOCATE (data)
9389 IF (PRESENT(stat)) stat = 0
9390#endif
9391 CALL mp_timestop(handle)
9392 END SUBROUTINE mp_deallocate_i
9393
9394! **************************************************************************************************
9395!> \brief (parallel) Blocking individual file write using explicit offsets
9396!> (serial) Unformatted stream write
9397!> \param[in] fh file handle (file storage unit)
9398!> \param[in] offset file offset (position)
9399!> \param[in] msg data to be written to the file
9400!> \param msglen ...
9401!> \par MPI-I/O mapping mpi_file_write_at
9402!> \par STREAM-I/O mapping WRITE
9403!> \param[in](optional) msglen number of the elements of data
9404! **************************************************************************************************
9405 SUBROUTINE mp_file_write_at_iv(fh, offset, msg, msglen)
9406 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
9407 CLASS(mp_file_type), INTENT(IN) :: fh
9408 INTEGER, INTENT(IN), OPTIONAL :: msglen
9409 INTEGER(kind=file_offset), INTENT(IN) :: offset
9410
9411 INTEGER :: msg_len
9412#if defined(__parallel)
9413 INTEGER :: ierr
9414#endif
9415
9416 msg_len = SIZE(msg)
9417 IF (PRESENT(msglen)) msg_len = msglen
9418#if defined(__parallel)
9419 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9420 IF (ierr .NE. 0) &
9421 cpabort("mpi_file_write_at_iv @ mp_file_write_at_iv")
9422#else
9423 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9424#endif
9425 END SUBROUTINE mp_file_write_at_iv
9426
9427! **************************************************************************************************
9428!> \brief ...
9429!> \param fh ...
9430!> \param offset ...
9431!> \param msg ...
9432! **************************************************************************************************
9433 SUBROUTINE mp_file_write_at_i (fh, offset, msg)
9434 INTEGER(KIND=int_4), INTENT(IN) :: msg
9435 CLASS(mp_file_type), INTENT(IN) :: fh
9436 INTEGER(kind=file_offset), INTENT(IN) :: offset
9437
9438#if defined(__parallel)
9439 INTEGER :: ierr
9440
9441 ierr = 0
9442 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9443 IF (ierr .NE. 0) &
9444 cpabort("mpi_file_write_at_i @ mp_file_write_at_i")
9445#else
9446 WRITE (unit=fh%handle, pos=offset + 1) msg
9447#endif
9448 END SUBROUTINE mp_file_write_at_i
9449
9450! **************************************************************************************************
9451!> \brief (parallel) Blocking collective file write using explicit offsets
9452!> (serial) Unformatted stream write
9453!> \param fh ...
9454!> \param offset ...
9455!> \param msg ...
9456!> \param msglen ...
9457!> \par MPI-I/O mapping mpi_file_write_at_all
9458!> \par STREAM-I/O mapping WRITE
9459! **************************************************************************************************
9460 SUBROUTINE mp_file_write_at_all_iv(fh, offset, msg, msglen)
9461 INTEGER(KIND=int_4), CONTIGUOUS, INTENT(IN) :: msg(:)
9462 CLASS(mp_file_type), INTENT(IN) :: fh
9463 INTEGER, INTENT(IN), OPTIONAL :: msglen
9464 INTEGER(kind=file_offset), INTENT(IN) :: offset
9465
9466 INTEGER :: msg_len
9467#if defined(__parallel)
9468 INTEGER :: ierr
9469#endif
9470
9471 msg_len = SIZE(msg)
9472 IF (PRESENT(msglen)) msg_len = msglen
9473#if defined(__parallel)
9474 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9475 IF (ierr .NE. 0) &
9476 cpabort("mpi_file_write_at_all_iv @ mp_file_write_at_all_iv")
9477#else
9478 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9479#endif
9480 END SUBROUTINE mp_file_write_at_all_iv
9481
9482! **************************************************************************************************
9483!> \brief ...
9484!> \param fh ...
9485!> \param offset ...
9486!> \param msg ...
9487! **************************************************************************************************
9488 SUBROUTINE mp_file_write_at_all_i (fh, offset, msg)
9489 INTEGER(KIND=int_4), INTENT(IN) :: msg
9490 CLASS(mp_file_type), INTENT(IN) :: fh
9491 INTEGER(kind=file_offset), INTENT(IN) :: offset
9492
9493#if defined(__parallel)
9494 INTEGER :: ierr
9495
9496 ierr = 0
9497 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9498 IF (ierr .NE. 0) &
9499 cpabort("mpi_file_write_at_all_i @ mp_file_write_at_all_i")
9500#else
9501 WRITE (unit=fh%handle, pos=offset + 1) msg
9502#endif
9503 END SUBROUTINE mp_file_write_at_all_i
9504
9505! **************************************************************************************************
9506!> \brief (parallel) Blocking individual file read using explicit offsets
9507!> (serial) Unformatted stream read
9508!> \param[in] fh file handle (file storage unit)
9509!> \param[in] offset file offset (position)
9510!> \param[out] msg data to be read from the file
9511!> \param msglen ...
9512!> \par MPI-I/O mapping mpi_file_read_at
9513!> \par STREAM-I/O mapping READ
9514!> \param[in](optional) msglen number of elements of data
9515! **************************************************************************************************
9516 SUBROUTINE mp_file_read_at_iv(fh, offset, msg, msglen)
9517 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msg(:)
9518 CLASS(mp_file_type), INTENT(IN) :: fh
9519 INTEGER, INTENT(IN), OPTIONAL :: msglen
9520 INTEGER(kind=file_offset), INTENT(IN) :: offset
9521
9522 INTEGER :: msg_len
9523#if defined(__parallel)
9524 INTEGER :: ierr
9525#endif
9526
9527 msg_len = SIZE(msg)
9528 IF (PRESENT(msglen)) msg_len = msglen
9529#if defined(__parallel)
9530 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9531 IF (ierr .NE. 0) &
9532 cpabort("mpi_file_read_at_iv @ mp_file_read_at_iv")
9533#else
9534 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9535#endif
9536 END SUBROUTINE mp_file_read_at_iv
9537
9538! **************************************************************************************************
9539!> \brief ...
9540!> \param fh ...
9541!> \param offset ...
9542!> \param msg ...
9543! **************************************************************************************************
9544 SUBROUTINE mp_file_read_at_i (fh, offset, msg)
9545 INTEGER(KIND=int_4), INTENT(OUT) :: msg
9546 CLASS(mp_file_type), INTENT(IN) :: fh
9547 INTEGER(kind=file_offset), INTENT(IN) :: offset
9548
9549#if defined(__parallel)
9550 INTEGER :: ierr
9551
9552 ierr = 0
9553 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9554 IF (ierr .NE. 0) &
9555 cpabort("mpi_file_read_at_i @ mp_file_read_at_i")
9556#else
9557 READ (unit=fh%handle, pos=offset + 1) msg
9558#endif
9559 END SUBROUTINE mp_file_read_at_i
9560
9561! **************************************************************************************************
9562!> \brief (parallel) Blocking collective file read using explicit offsets
9563!> (serial) Unformatted stream read
9564!> \param fh ...
9565!> \param offset ...
9566!> \param msg ...
9567!> \param msglen ...
9568!> \par MPI-I/O mapping mpi_file_read_at_all
9569!> \par STREAM-I/O mapping READ
9570! **************************************************************************************************
9571 SUBROUTINE mp_file_read_at_all_iv(fh, offset, msg, msglen)
9572 INTEGER(KIND=int_4), INTENT(OUT), CONTIGUOUS :: msg(:)
9573 CLASS(mp_file_type), INTENT(IN) :: fh
9574 INTEGER, INTENT(IN), OPTIONAL :: msglen
9575 INTEGER(kind=file_offset), INTENT(IN) :: offset
9576
9577 INTEGER :: msg_len
9578#if defined(__parallel)
9579 INTEGER :: ierr
9580#endif
9581
9582 msg_len = SIZE(msg)
9583 IF (PRESENT(msglen)) msg_len = msglen
9584#if defined(__parallel)
9585 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_integer, mpi_status_ignore, ierr)
9586 IF (ierr .NE. 0) &
9587 cpabort("mpi_file_read_at_all_iv @ mp_file_read_at_all_iv")
9588#else
9589 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
9590#endif
9591 END SUBROUTINE mp_file_read_at_all_iv
9592
9593! **************************************************************************************************
9594!> \brief ...
9595!> \param fh ...
9596!> \param offset ...
9597!> \param msg ...
9598! **************************************************************************************************
9599 SUBROUTINE mp_file_read_at_all_i (fh, offset, msg)
9600 INTEGER(KIND=int_4), INTENT(OUT) :: msg
9601 CLASS(mp_file_type), INTENT(IN) :: fh
9602 INTEGER(kind=file_offset), INTENT(IN) :: offset
9603
9604#if defined(__parallel)
9605 INTEGER :: ierr
9606
9607 ierr = 0
9608 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_integer, mpi_status_ignore, ierr)
9609 IF (ierr .NE. 0) &
9610 cpabort("mpi_file_read_at_all_i @ mp_file_read_at_all_i")
9611#else
9612 READ (unit=fh%handle, pos=offset + 1) msg
9613#endif
9614 END SUBROUTINE mp_file_read_at_all_i
9615
9616! **************************************************************************************************
9617!> \brief ...
9618!> \param ptr ...
9619!> \param vector_descriptor ...
9620!> \param index_descriptor ...
9621!> \return ...
9622! **************************************************************************************************
9623 FUNCTION mp_type_make_i (ptr, &
9624 vector_descriptor, index_descriptor) &
9625 result(type_descriptor)
9626 INTEGER(KIND=int_4), DIMENSION(:), TARGET, asynchronous :: ptr
9627 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
9628 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
9629 TYPE(mp_type_descriptor_type) :: type_descriptor
9630
9631 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_i'
9632
9633#if defined(__parallel)
9634 INTEGER :: ierr
9635#endif
9636
9637 NULLIFY (type_descriptor%subtype)
9638 type_descriptor%length = SIZE(ptr)
9639#if defined(__parallel)
9640 type_descriptor%type_handle = mpi_integer
9641 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
9642 IF (ierr /= 0) &
9643 cpabort("MPI_Get_address @ "//routinen)
9644#else
9645 type_descriptor%type_handle = 17
9646#endif
9647 type_descriptor%vector_descriptor(1:2) = 1
9648 type_descriptor%has_indexing = .false.
9649 type_descriptor%data_i => ptr
9650 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
9651 cpabort(routinen//": Vectors and indices NYI")
9652 END IF
9653 END FUNCTION mp_type_make_i
9654
9655! **************************************************************************************************
9656!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
9657!> as the Fortran version returns an integer, which we take to be a C_PTR
9658!> \param DATA data array to allocate
9659!> \param[in] len length (in data elements) of data array allocation
9660!> \param[out] stat (optional) allocation status result
9661! **************************************************************************************************
9662 SUBROUTINE mp_alloc_mem_i (DATA, len, stat)
9663 INTEGER(KIND=int_4), CONTIGUOUS, DIMENSION(:), POINTER :: data
9664 INTEGER, INTENT(IN) :: len
9665 INTEGER, INTENT(OUT), OPTIONAL :: stat
9666
9667#if defined(__parallel)
9668 INTEGER :: size, ierr, length, &
9669 mp_res
9670 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
9671 TYPE(c_ptr) :: mp_baseptr
9672 mpi_info_type :: mp_info
9673
9674 length = max(len, 1)
9675 CALL mpi_type_size(mpi_integer, size, ierr)
9676 mp_size = int(length, kind=mpi_address_kind)*size
9677 IF (mp_size .GT. mp_max_memory_size) THEN
9678 cpabort("MPI cannot allocate more than 2 GiByte")
9679 END IF
9680 mp_info = mpi_info_null
9681 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
9682 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
9683 IF (PRESENT(stat)) stat = mp_res
9684#else
9685 INTEGER :: length, mystat
9686 length = max(len, 1)
9687 IF (PRESENT(stat)) THEN
9688 ALLOCATE (DATA(length), stat=mystat)
9689 stat = mystat ! show to convention checker that stat is used
9690 ELSE
9691 ALLOCATE (DATA(length))
9692 END IF
9693#endif
9694 END SUBROUTINE mp_alloc_mem_i
9695
9696! **************************************************************************************************
9697!> \brief Deallocates am array, ... this is hackish
9698!> as the Fortran version takes an integer, which we hope to get by reference
9699!> \param DATA data array to allocate
9700!> \param[out] stat (optional) allocation status result
9701! **************************************************************************************************
9702 SUBROUTINE mp_free_mem_i (DATA, stat)
9703 INTEGER(KIND=int_4), DIMENSION(:), &
9704 POINTER, asynchronous :: data
9705 INTEGER, INTENT(OUT), OPTIONAL :: stat
9706
9707#if defined(__parallel)
9708 INTEGER :: mp_res
9709 CALL mpi_free_mem(DATA, mp_res)
9710 IF (PRESENT(stat)) stat = mp_res
9711#else
9712 DEALLOCATE (data)
9713 IF (PRESENT(stat)) stat = 0
9714#endif
9715 END SUBROUTINE mp_free_mem_i
9716! **************************************************************************************************
9717!> \brief Shift around the data in msg
9718!> \param[in,out] msg Rank-2 data to shift
9719!> \param[in] comm message passing environment identifier
9720!> \param[in] displ_in displacements (?)
9721!> \par Example
9722!> msg will be moved from rank to rank+displ_in (in a circular way)
9723!> \par Limitations
9724!> * displ_in will be 1 by default (others not tested)
9725!> * the message array needs to be the same size on all processes
9726! **************************************************************************************************
9727 SUBROUTINE mp_shift_lm(msg, comm, displ_in)
9728
9729 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
9730 CLASS(mp_comm_type), INTENT(IN) :: comm
9731 INTEGER, INTENT(IN), OPTIONAL :: displ_in
9732
9733 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_lm'
9734
9735 INTEGER :: handle, ierror
9736#if defined(__parallel)
9737 INTEGER :: displ, left, &
9738 msglen, myrank, nprocs, &
9739 right, tag
9740#endif
9741
9742 ierror = 0
9743 CALL mp_timeset(routinen, handle)
9744
9745#if defined(__parallel)
9746 CALL mpi_comm_rank(comm%handle, myrank, ierror)
9747 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
9748 CALL mpi_comm_size(comm%handle, nprocs, ierror)
9749 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
9750 IF (PRESENT(displ_in)) THEN
9751 displ = displ_in
9752 ELSE
9753 displ = 1
9754 END IF
9755 right = modulo(myrank + displ, nprocs)
9756 left = modulo(myrank - displ, nprocs)
9757 tag = 17
9758 msglen = SIZE(msg)
9759 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer8, right, tag, left, tag, &
9760 comm%handle, mpi_status_ignore, ierror)
9761 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
9762 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_8_size)
9763#else
9764 mark_used(msg)
9765 mark_used(comm)
9766 mark_used(displ_in)
9767#endif
9768 CALL mp_timestop(handle)
9769
9770 END SUBROUTINE mp_shift_lm
9771
9772! **************************************************************************************************
9773!> \brief Shift around the data in msg
9774!> \param[in,out] msg Data to shift
9775!> \param[in] comm message passing environment identifier
9776!> \param[in] displ_in displacements (?)
9777!> \par Example
9778!> msg will be moved from rank to rank+displ_in (in a circular way)
9779!> \par Limitations
9780!> * displ_in will be 1 by default (others not tested)
9781!> * the message array needs to be the same size on all processes
9782! **************************************************************************************************
9783 SUBROUTINE mp_shift_l (msg, comm, displ_in)
9784
9785 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
9786 CLASS(mp_comm_type), INTENT(IN) :: comm
9787 INTEGER, INTENT(IN), OPTIONAL :: displ_in
9788
9789 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_l'
9790
9791 INTEGER :: handle, ierror
9792#if defined(__parallel)
9793 INTEGER :: displ, left, &
9794 msglen, myrank, nprocs, &
9795 right, tag
9796#endif
9797
9798 ierror = 0
9799 CALL mp_timeset(routinen, handle)
9800
9801#if defined(__parallel)
9802 CALL mpi_comm_rank(comm%handle, myrank, ierror)
9803 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
9804 CALL mpi_comm_size(comm%handle, nprocs, ierror)
9805 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
9806 IF (PRESENT(displ_in)) THEN
9807 displ = displ_in
9808 ELSE
9809 displ = 1
9810 END IF
9811 right = modulo(myrank + displ, nprocs)
9812 left = modulo(myrank - displ, nprocs)
9813 tag = 19
9814 msglen = SIZE(msg)
9815 CALL mpi_sendrecv_replace(msg, msglen, mpi_integer8, right, tag, left, &
9816 tag, comm%handle, mpi_status_ignore, ierror)
9817 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
9818 CALL add_perf(perf_id=7, count=1, msg_size=msglen*int_8_size)
9819#else
9820 mark_used(msg)
9821 mark_used(comm)
9822 mark_used(displ_in)
9823#endif
9824 CALL mp_timestop(handle)
9825
9826 END SUBROUTINE mp_shift_l
9827
9828! **************************************************************************************************
9829!> \brief All-to-all data exchange, rank-1 data of different sizes
9830!> \param[in] sb Data to send
9831!> \param[in] scount Data counts for data sent to other processes
9832!> \param[in] sdispl Respective data offsets for data sent to process
9833!> \param[in,out] rb Buffer into which to receive data
9834!> \param[in] rcount Data counts for data received from other
9835!> processes
9836!> \param[in] rdispl Respective data offsets for data received from
9837!> other processes
9838!> \param[in] comm Message passing environment identifier
9839!> \par MPI mapping
9840!> mpi_alltoallv
9841!> \par Array sizes
9842!> The scount, rcount, and the sdispl and rdispl arrays have a
9843!> size equal to the number of processes.
9844!> \par Offsets
9845!> Values in sdispl and rdispl start with 0.
9846! **************************************************************************************************
9847 SUBROUTINE mp_alltoall_l11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
9848
9849 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
9850 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
9851 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
9852 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
9853 CLASS(mp_comm_type), INTENT(IN) :: comm
9854
9855 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l11v'
9856
9857 INTEGER :: handle
9858#if defined(__parallel)
9859 INTEGER :: ierr, msglen
9860#else
9861 INTEGER :: i
9862#endif
9863
9864 CALL mp_timeset(routinen, handle)
9865
9866#if defined(__parallel)
9867 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer8, &
9868 rb, rcount, rdispl, mpi_integer8, comm%handle, ierr)
9869 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
9870 msglen = sum(scount) + sum(rcount)
9871 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9872#else
9873 mark_used(comm)
9874 mark_used(scount)
9875 mark_used(sdispl)
9876 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
9877 DO i = 1, rcount(1)
9878 rb(rdispl(1) + i) = sb(sdispl(1) + i)
9879 END DO
9880#endif
9881 CALL mp_timestop(handle)
9882
9883 END SUBROUTINE mp_alltoall_l11v
9884
9885! **************************************************************************************************
9886!> \brief All-to-all data exchange, rank-2 data of different sizes
9887!> \param sb ...
9888!> \param scount ...
9889!> \param sdispl ...
9890!> \param rb ...
9891!> \param rcount ...
9892!> \param rdispl ...
9893!> \param comm ...
9894!> \par MPI mapping
9895!> mpi_alltoallv
9896!> \note see mp_alltoall_l11v
9897! **************************************************************************************************
9898 SUBROUTINE mp_alltoall_l22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
9899
9900 INTEGER(KIND=int_8), DIMENSION(:, :), &
9901 INTENT(IN), CONTIGUOUS :: sb
9902 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
9903 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, &
9904 INTENT(INOUT) :: rb
9905 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
9906 CLASS(mp_comm_type), INTENT(IN) :: comm
9907
9908 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l22v'
9909
9910 INTEGER :: handle
9911#if defined(__parallel)
9912 INTEGER :: ierr, msglen
9913#endif
9914
9915 CALL mp_timeset(routinen, handle)
9916
9917#if defined(__parallel)
9918 CALL mpi_alltoallv(sb, scount, sdispl, mpi_integer8, &
9919 rb, rcount, rdispl, mpi_integer8, comm%handle, ierr)
9920 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
9921 msglen = sum(scount) + sum(rcount)
9922 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*int_8_size)
9923#else
9924 mark_used(comm)
9925 mark_used(scount)
9926 mark_used(sdispl)
9927 mark_used(rcount)
9928 mark_used(rdispl)
9929 rb = sb
9930#endif
9931 CALL mp_timestop(handle)
9932
9933 END SUBROUTINE mp_alltoall_l22v
9934
9935! **************************************************************************************************
9936!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
9937!> \param[in] sb array with data to send
9938!> \param[out] rb array into which data is received
9939!> \param[in] count number of elements to send/receive (product of the
9940!> extents of the first two dimensions)
9941!> \param[in] comm Message passing environment identifier
9942!> \par Index meaning
9943!> \par The first two indices specify the data while the last index counts
9944!> the processes
9945!> \par Sizes of ranks
9946!> All processes have the same data size.
9947!> \par MPI mapping
9948!> mpi_alltoall
9949! **************************************************************************************************
9950 SUBROUTINE mp_alltoall_l (sb, rb, count, comm)
9951
9952 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
9953 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
9954 INTEGER, INTENT(IN) :: count
9955 CLASS(mp_comm_type), INTENT(IN) :: comm
9956
9957 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l'
9958
9959 INTEGER :: handle
9960#if defined(__parallel)
9961 INTEGER :: ierr, msglen, np
9962#endif
9963
9964 CALL mp_timeset(routinen, handle)
9965
9966#if defined(__parallel)
9967 CALL mpi_alltoall(sb, count, mpi_integer8, &
9968 rb, count, mpi_integer8, comm%handle, ierr)
9969 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
9970 CALL mpi_comm_size(comm%handle, np, ierr)
9971 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
9972 msglen = 2*count*np
9973 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
9974#else
9975 mark_used(count)
9976 mark_used(comm)
9977 rb = sb
9978#endif
9979 CALL mp_timestop(handle)
9980
9981 END SUBROUTINE mp_alltoall_l
9982
9983! **************************************************************************************************
9984!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
9985!> \param sb ...
9986!> \param rb ...
9987!> \param count ...
9988!> \param commp ...
9989!> \note see mp_alltoall_l
9990! **************************************************************************************************
9991 SUBROUTINE mp_alltoall_l22(sb, rb, count, comm)
9992
9993 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
9994 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
9995 INTEGER, INTENT(IN) :: count
9996 CLASS(mp_comm_type), INTENT(IN) :: comm
9997
9998 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l22'
9999
10000 INTEGER :: handle
10001#if defined(__parallel)
10002 INTEGER :: ierr, msglen, np
10003#endif
10004
10005 CALL mp_timeset(routinen, handle)
10006
10007#if defined(__parallel)
10008 CALL mpi_alltoall(sb, count, mpi_integer8, &
10009 rb, count, mpi_integer8, comm%handle, ierr)
10010 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10011 CALL mpi_comm_size(comm%handle, np, ierr)
10012 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10013 msglen = 2*SIZE(sb)*np
10014 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10015#else
10016 mark_used(count)
10017 mark_used(comm)
10018 rb = sb
10019#endif
10020 CALL mp_timestop(handle)
10021
10022 END SUBROUTINE mp_alltoall_l22
10023
10024! **************************************************************************************************
10025!> \brief All-to-all data exchange, rank-3 data with equal sizes
10026!> \param sb ...
10027!> \param rb ...
10028!> \param count ...
10029!> \param comm ...
10030!> \note see mp_alltoall_l
10031! **************************************************************************************************
10032 SUBROUTINE mp_alltoall_l33(sb, rb, count, comm)
10033
10034 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
10035 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
10036 INTEGER, INTENT(IN) :: count
10037 CLASS(mp_comm_type), INTENT(IN) :: comm
10038
10039 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l33'
10040
10041 INTEGER :: handle
10042#if defined(__parallel)
10043 INTEGER :: ierr, msglen, np
10044#endif
10045
10046 CALL mp_timeset(routinen, handle)
10047
10048#if defined(__parallel)
10049 CALL mpi_alltoall(sb, count, mpi_integer8, &
10050 rb, count, mpi_integer8, comm%handle, ierr)
10051 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10052 CALL mpi_comm_size(comm%handle, np, ierr)
10053 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10054 msglen = 2*count*np
10055 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10056#else
10057 mark_used(count)
10058 mark_used(comm)
10059 rb = sb
10060#endif
10061 CALL mp_timestop(handle)
10062
10063 END SUBROUTINE mp_alltoall_l33
10064
10065! **************************************************************************************************
10066!> \brief All-to-all data exchange, rank 4 data, equal sizes
10067!> \param sb ...
10068!> \param rb ...
10069!> \param count ...
10070!> \param comm ...
10071!> \note see mp_alltoall_l
10072! **************************************************************************************************
10073 SUBROUTINE mp_alltoall_l44(sb, rb, count, comm)
10074
10075 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10076 INTENT(IN) :: sb
10077 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10078 INTENT(OUT) :: rb
10079 INTEGER, INTENT(IN) :: count
10080 CLASS(mp_comm_type), INTENT(IN) :: comm
10081
10082 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l44'
10083
10084 INTEGER :: handle
10085#if defined(__parallel)
10086 INTEGER :: ierr, msglen, np
10087#endif
10088
10089 CALL mp_timeset(routinen, handle)
10090
10091#if defined(__parallel)
10092 CALL mpi_alltoall(sb, count, mpi_integer8, &
10093 rb, count, mpi_integer8, comm%handle, ierr)
10094 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10095 CALL mpi_comm_size(comm%handle, np, ierr)
10096 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10097 msglen = 2*count*np
10098 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10099#else
10100 mark_used(count)
10101 mark_used(comm)
10102 rb = sb
10103#endif
10104 CALL mp_timestop(handle)
10105
10106 END SUBROUTINE mp_alltoall_l44
10107
10108! **************************************************************************************************
10109!> \brief All-to-all data exchange, rank 5 data, equal sizes
10110!> \param sb ...
10111!> \param rb ...
10112!> \param count ...
10113!> \param comm ...
10114!> \note see mp_alltoall_l
10115! **************************************************************************************************
10116 SUBROUTINE mp_alltoall_l55(sb, rb, count, comm)
10117
10118 INTEGER(KIND=int_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
10119 INTENT(IN) :: sb
10120 INTEGER(KIND=int_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
10121 INTENT(OUT) :: rb
10122 INTEGER, INTENT(IN) :: count
10123 CLASS(mp_comm_type), INTENT(IN) :: comm
10124
10125 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l55'
10126
10127 INTEGER :: handle
10128#if defined(__parallel)
10129 INTEGER :: ierr, msglen, np
10130#endif
10131
10132 CALL mp_timeset(routinen, handle)
10133
10134#if defined(__parallel)
10135 CALL mpi_alltoall(sb, count, mpi_integer8, &
10136 rb, count, mpi_integer8, comm%handle, ierr)
10137 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10138 CALL mpi_comm_size(comm%handle, np, ierr)
10139 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10140 msglen = 2*count*np
10141 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10142#else
10143 mark_used(count)
10144 mark_used(comm)
10145 rb = sb
10146#endif
10147 CALL mp_timestop(handle)
10148
10149 END SUBROUTINE mp_alltoall_l55
10150
10151! **************************************************************************************************
10152!> \brief All-to-all data exchange, rank-4 data to rank-5 data
10153!> \param sb ...
10154!> \param rb ...
10155!> \param count ...
10156!> \param comm ...
10157!> \note see mp_alltoall_l
10158!> \note User must ensure size consistency.
10159! **************************************************************************************************
10160 SUBROUTINE mp_alltoall_l45(sb, rb, count, comm)
10161
10162 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10163 INTENT(IN) :: sb
10164 INTEGER(KIND=int_8), &
10165 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
10166 INTEGER, INTENT(IN) :: count
10167 CLASS(mp_comm_type), INTENT(IN) :: comm
10168
10169 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l45'
10170
10171 INTEGER :: handle
10172#if defined(__parallel)
10173 INTEGER :: ierr, msglen, np
10174#endif
10175
10176 CALL mp_timeset(routinen, handle)
10177
10178#if defined(__parallel)
10179 CALL mpi_alltoall(sb, count, mpi_integer8, &
10180 rb, count, mpi_integer8, comm%handle, ierr)
10181 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10182 CALL mpi_comm_size(comm%handle, np, ierr)
10183 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10184 msglen = 2*count*np
10185 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10186#else
10187 mark_used(count)
10188 mark_used(comm)
10189 rb = reshape(sb, shape(rb))
10190#endif
10191 CALL mp_timestop(handle)
10192
10193 END SUBROUTINE mp_alltoall_l45
10194
10195! **************************************************************************************************
10196!> \brief All-to-all data exchange, rank-3 data to rank-4 data
10197!> \param sb ...
10198!> \param rb ...
10199!> \param count ...
10200!> \param comm ...
10201!> \note see mp_alltoall_l
10202!> \note User must ensure size consistency.
10203! **************************************************************************************************
10204 SUBROUTINE mp_alltoall_l34(sb, rb, count, comm)
10205
10206 INTEGER(KIND=int_8), DIMENSION(:, :, :), CONTIGUOUS, &
10207 INTENT(IN) :: sb
10208 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10209 INTENT(OUT) :: rb
10210 INTEGER, INTENT(IN) :: count
10211 CLASS(mp_comm_type), INTENT(IN) :: comm
10212
10213 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l34'
10214
10215 INTEGER :: handle
10216#if defined(__parallel)
10217 INTEGER :: ierr, msglen, np
10218#endif
10219
10220 CALL mp_timeset(routinen, handle)
10221
10222#if defined(__parallel)
10223 CALL mpi_alltoall(sb, count, mpi_integer8, &
10224 rb, count, mpi_integer8, comm%handle, ierr)
10225 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10226 CALL mpi_comm_size(comm%handle, np, ierr)
10227 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10228 msglen = 2*count*np
10229 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10230#else
10231 mark_used(count)
10232 mark_used(comm)
10233 rb = reshape(sb, shape(rb))
10234#endif
10235 CALL mp_timestop(handle)
10236
10237 END SUBROUTINE mp_alltoall_l34
10238
10239! **************************************************************************************************
10240!> \brief All-to-all data exchange, rank-5 data to rank-4 data
10241!> \param sb ...
10242!> \param rb ...
10243!> \param count ...
10244!> \param comm ...
10245!> \note see mp_alltoall_l
10246!> \note User must ensure size consistency.
10247! **************************************************************************************************
10248 SUBROUTINE mp_alltoall_l54(sb, rb, count, comm)
10249
10250 INTEGER(KIND=int_8), &
10251 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
10252 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
10253 INTENT(OUT) :: rb
10254 INTEGER, INTENT(IN) :: count
10255 CLASS(mp_comm_type), INTENT(IN) :: comm
10256
10257 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_l54'
10258
10259 INTEGER :: handle
10260#if defined(__parallel)
10261 INTEGER :: ierr, msglen, np
10262#endif
10263
10264 CALL mp_timeset(routinen, handle)
10265
10266#if defined(__parallel)
10267 CALL mpi_alltoall(sb, count, mpi_integer8, &
10268 rb, count, mpi_integer8, comm%handle, ierr)
10269 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
10270 CALL mpi_comm_size(comm%handle, np, ierr)
10271 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
10272 msglen = 2*count*np
10273 CALL add_perf(perf_id=6, count=1, msg_size=msglen*int_8_size)
10274#else
10275 mark_used(count)
10276 mark_used(comm)
10277 rb = reshape(sb, shape(rb))
10278#endif
10279 CALL mp_timestop(handle)
10280
10281 END SUBROUTINE mp_alltoall_l54
10282
10283! **************************************************************************************************
10284!> \brief Send one datum to another process
10285!> \param[in] msg Scalar to send
10286!> \param[in] dest Destination process
10287!> \param[in] tag Transfer identifier
10288!> \param[in] comm Message passing environment identifier
10289!> \par MPI mapping
10290!> mpi_send
10291! **************************************************************************************************
10292 SUBROUTINE mp_send_l (msg, dest, tag, comm)
10293 INTEGER(KIND=int_8), INTENT(IN) :: msg
10294 INTEGER, INTENT(IN) :: dest, tag
10295 CLASS(mp_comm_type), INTENT(IN) :: comm
10296
10297 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_l'
10298
10299 INTEGER :: handle
10300#if defined(__parallel)
10301 INTEGER :: ierr, msglen
10302#endif
10303
10304 CALL mp_timeset(routinen, handle)
10305
10306#if defined(__parallel)
10307 msglen = 1
10308 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10309 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10310 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10311#else
10312 mark_used(msg)
10313 mark_used(dest)
10314 mark_used(tag)
10315 mark_used(comm)
10316 ! only defined in parallel
10317 cpabort("not in parallel mode")
10318#endif
10319 CALL mp_timestop(handle)
10320 END SUBROUTINE mp_send_l
10321
10322! **************************************************************************************************
10323!> \brief Send rank-1 data to another process
10324!> \param[in] msg Rank-1 data to send
10325!> \param dest ...
10326!> \param tag ...
10327!> \param comm ...
10328!> \note see mp_send_l
10329! **************************************************************************************************
10330 SUBROUTINE mp_send_lv(msg, dest, tag, comm)
10331 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
10332 INTEGER, INTENT(IN) :: dest, tag
10333 CLASS(mp_comm_type), INTENT(IN) :: comm
10334
10335 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_lv'
10336
10337 INTEGER :: handle
10338#if defined(__parallel)
10339 INTEGER :: ierr, msglen
10340#endif
10341
10342 CALL mp_timeset(routinen, handle)
10343
10344#if defined(__parallel)
10345 msglen = SIZE(msg)
10346 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10347 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10348 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10349#else
10350 mark_used(msg)
10351 mark_used(dest)
10352 mark_used(tag)
10353 mark_used(comm)
10354 ! only defined in parallel
10355 cpabort("not in parallel mode")
10356#endif
10357 CALL mp_timestop(handle)
10358 END SUBROUTINE mp_send_lv
10359
10360! **************************************************************************************************
10361!> \brief Send rank-2 data to another process
10362!> \param[in] msg Rank-2 data to send
10363!> \param dest ...
10364!> \param tag ...
10365!> \param comm ...
10366!> \note see mp_send_l
10367! **************************************************************************************************
10368 SUBROUTINE mp_send_lm2(msg, dest, tag, comm)
10369 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
10370 INTEGER, INTENT(IN) :: dest, tag
10371 CLASS(mp_comm_type), INTENT(IN) :: comm
10372
10373 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_lm2'
10374
10375 INTEGER :: handle
10376#if defined(__parallel)
10377 INTEGER :: ierr, msglen
10378#endif
10379
10380 CALL mp_timeset(routinen, handle)
10381
10382#if defined(__parallel)
10383 msglen = SIZE(msg)
10384 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10385 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10386 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10387#else
10388 mark_used(msg)
10389 mark_used(dest)
10390 mark_used(tag)
10391 mark_used(comm)
10392 ! only defined in parallel
10393 cpabort("not in parallel mode")
10394#endif
10395 CALL mp_timestop(handle)
10396 END SUBROUTINE mp_send_lm2
10397
10398! **************************************************************************************************
10399!> \brief Send rank-3 data to another process
10400!> \param[in] msg Rank-3 data to send
10401!> \param dest ...
10402!> \param tag ...
10403!> \param comm ...
10404!> \note see mp_send_l
10405! **************************************************************************************************
10406 SUBROUTINE mp_send_lm3(msg, dest, tag, comm)
10407 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
10408 INTEGER, INTENT(IN) :: dest, tag
10409 CLASS(mp_comm_type), INTENT(IN) :: comm
10410
10411 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
10412
10413 INTEGER :: handle
10414#if defined(__parallel)
10415 INTEGER :: ierr, msglen
10416#endif
10417
10418 CALL mp_timeset(routinen, handle)
10419
10420#if defined(__parallel)
10421 msglen = SIZE(msg)
10422 CALL mpi_send(msg, msglen, mpi_integer8, dest, tag, comm%handle, ierr)
10423 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
10424 CALL add_perf(perf_id=13, count=1, msg_size=msglen*int_8_size)
10425#else
10426 mark_used(msg)
10427 mark_used(dest)
10428 mark_used(tag)
10429 mark_used(comm)
10430 ! only defined in parallel
10431 cpabort("not in parallel mode")
10432#endif
10433 CALL mp_timestop(handle)
10434 END SUBROUTINE mp_send_lm3
10435
10436! **************************************************************************************************
10437!> \brief Receive one datum from another process
10438!> \param[in,out] msg Place received data into this variable
10439!> \param[in,out] source Process to receive from
10440!> \param[in,out] tag Transfer identifier
10441!> \param[in] comm Message passing environment identifier
10442!> \par MPI mapping
10443!> mpi_send
10444! **************************************************************************************************
10445 SUBROUTINE mp_recv_l (msg, source, tag, comm)
10446 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10447 INTEGER, INTENT(INOUT) :: source, tag
10448 CLASS(mp_comm_type), INTENT(IN) :: comm
10449
10450 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_l'
10451
10452 INTEGER :: handle
10453#if defined(__parallel)
10454 INTEGER :: ierr, msglen
10455 mpi_status_type :: status
10456#endif
10457
10458 CALL mp_timeset(routinen, handle)
10459
10460#if defined(__parallel)
10461 msglen = 1
10462 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10463 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10464 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10465 ELSE
10466 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10467 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10468 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10469 source = status mpi_status_extract(mpi_source)
10470 tag = status mpi_status_extract(mpi_tag)
10471 END IF
10472#else
10473 mark_used(msg)
10474 mark_used(source)
10475 mark_used(tag)
10476 mark_used(comm)
10477 ! only defined in parallel
10478 cpabort("not in parallel mode")
10479#endif
10480 CALL mp_timestop(handle)
10481 END SUBROUTINE mp_recv_l
10482
10483! **************************************************************************************************
10484!> \brief Receive rank-1 data from another process
10485!> \param[in,out] msg Place received data into this rank-1 array
10486!> \param source ...
10487!> \param tag ...
10488!> \param comm ...
10489!> \note see mp_recv_l
10490! **************************************************************************************************
10491 SUBROUTINE mp_recv_lv(msg, source, tag, comm)
10492 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10493 INTEGER, INTENT(INOUT) :: source, tag
10494 CLASS(mp_comm_type), INTENT(IN) :: comm
10495
10496 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lv'
10497
10498 INTEGER :: handle
10499#if defined(__parallel)
10500 INTEGER :: ierr, msglen
10501 mpi_status_type :: status
10502#endif
10503
10504 CALL mp_timeset(routinen, handle)
10505
10506#if defined(__parallel)
10507 msglen = SIZE(msg)
10508 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10509 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10510 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10511 ELSE
10512 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10513 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10514 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10515 source = status mpi_status_extract(mpi_source)
10516 tag = status mpi_status_extract(mpi_tag)
10517 END IF
10518#else
10519 mark_used(msg)
10520 mark_used(source)
10521 mark_used(tag)
10522 mark_used(comm)
10523 ! only defined in parallel
10524 cpabort("not in parallel mode")
10525#endif
10526 CALL mp_timestop(handle)
10527 END SUBROUTINE mp_recv_lv
10528
10529! **************************************************************************************************
10530!> \brief Receive rank-2 data from another process
10531!> \param[in,out] msg Place received data into this rank-2 array
10532!> \param source ...
10533!> \param tag ...
10534!> \param comm ...
10535!> \note see mp_recv_l
10536! **************************************************************************************************
10537 SUBROUTINE mp_recv_lm2(msg, source, tag, comm)
10538 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10539 INTEGER, INTENT(INOUT) :: source, tag
10540 CLASS(mp_comm_type), INTENT(IN) :: comm
10541
10542 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lm2'
10543
10544 INTEGER :: handle
10545#if defined(__parallel)
10546 INTEGER :: ierr, msglen
10547 mpi_status_type :: status
10548#endif
10549
10550 CALL mp_timeset(routinen, handle)
10551
10552#if defined(__parallel)
10553 msglen = SIZE(msg)
10554 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10555 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10556 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10557 ELSE
10558 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10559 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10560 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10561 source = status mpi_status_extract(mpi_source)
10562 tag = status mpi_status_extract(mpi_tag)
10563 END IF
10564#else
10565 mark_used(msg)
10566 mark_used(source)
10567 mark_used(tag)
10568 mark_used(comm)
10569 ! only defined in parallel
10570 cpabort("not in parallel mode")
10571#endif
10572 CALL mp_timestop(handle)
10573 END SUBROUTINE mp_recv_lm2
10574
10575! **************************************************************************************************
10576!> \brief Receive rank-3 data from another process
10577!> \param[in,out] msg Place received data into this rank-3 array
10578!> \param source ...
10579!> \param tag ...
10580!> \param comm ...
10581!> \note see mp_recv_l
10582! **************************************************************************************************
10583 SUBROUTINE mp_recv_lm3(msg, source, tag, comm)
10584 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
10585 INTEGER, INTENT(INOUT) :: source, tag
10586 CLASS(mp_comm_type), INTENT(IN) :: comm
10587
10588 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_lm3'
10589
10590 INTEGER :: handle
10591#if defined(__parallel)
10592 INTEGER :: ierr, msglen
10593 mpi_status_type :: status
10594#endif
10595
10596 CALL mp_timeset(routinen, handle)
10597
10598#if defined(__parallel)
10599 msglen = SIZE(msg)
10600 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
10601 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, mpi_status_ignore, ierr)
10602 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10603 ELSE
10604 CALL mpi_recv(msg, msglen, mpi_integer8, source, tag, comm%handle, status, ierr)
10605 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
10606 CALL add_perf(perf_id=14, count=1, msg_size=msglen*int_8_size)
10607 source = status mpi_status_extract(mpi_source)
10608 tag = status mpi_status_extract(mpi_tag)
10609 END IF
10610#else
10611 mark_used(msg)
10612 mark_used(source)
10613 mark_used(tag)
10614 mark_used(comm)
10615 ! only defined in parallel
10616 cpabort("not in parallel mode")
10617#endif
10618 CALL mp_timestop(handle)
10619 END SUBROUTINE mp_recv_lm3
10620
10621! **************************************************************************************************
10622!> \brief Broadcasts a datum to all processes.
10623!> \param[in] msg Datum to broadcast
10624!> \param[in] source Processes which broadcasts
10625!> \param[in] comm Message passing environment identifier
10626!> \par MPI mapping
10627!> mpi_bcast
10628! **************************************************************************************************
10629 SUBROUTINE mp_bcast_l (msg, source, comm)
10630 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10631 INTEGER, INTENT(IN) :: source
10632 CLASS(mp_comm_type), INTENT(IN) :: comm
10633
10634 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l'
10635
10636 INTEGER :: handle
10637#if defined(__parallel)
10638 INTEGER :: ierr, msglen
10639#endif
10640
10641 CALL mp_timeset(routinen, handle)
10642
10643#if defined(__parallel)
10644 msglen = 1
10645 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10646 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10647 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10648#else
10649 mark_used(msg)
10650 mark_used(source)
10651 mark_used(comm)
10652#endif
10653 CALL mp_timestop(handle)
10654 END SUBROUTINE mp_bcast_l
10655
10656! **************************************************************************************************
10657!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
10658!> \param[in] msg Datum to broadcast
10659!> \param[in] comm Message passing environment identifier
10660!> \par MPI mapping
10661!> mpi_bcast
10662! **************************************************************************************************
10663 SUBROUTINE mp_bcast_l_src(msg, comm)
10664 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10665 CLASS(mp_comm_type), INTENT(IN) :: comm
10666
10667 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l_src'
10668
10669 INTEGER :: handle
10670#if defined(__parallel)
10671 INTEGER :: ierr, msglen
10672#endif
10673
10674 CALL mp_timeset(routinen, handle)
10675
10676#if defined(__parallel)
10677 msglen = 1
10678 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10679 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10680 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10681#else
10682 mark_used(msg)
10683 mark_used(comm)
10684#endif
10685 CALL mp_timestop(handle)
10686 END SUBROUTINE mp_bcast_l_src
10687
10688! **************************************************************************************************
10689!> \brief Broadcasts a datum to all processes.
10690!> \param[in] msg Datum to broadcast
10691!> \param[in] source Processes which broadcasts
10692!> \param[in] comm Message passing environment identifier
10693!> \par MPI mapping
10694!> mpi_bcast
10695! **************************************************************************************************
10696 SUBROUTINE mp_ibcast_l (msg, source, comm, request)
10697 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10698 INTEGER, INTENT(IN) :: source
10699 CLASS(mp_comm_type), INTENT(IN) :: comm
10700 TYPE(mp_request_type), INTENT(OUT) :: request
10701
10702 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_l'
10703
10704 INTEGER :: handle
10705#if defined(__parallel)
10706 INTEGER :: ierr, msglen
10707#endif
10708
10709 CALL mp_timeset(routinen, handle)
10710
10711#if defined(__parallel)
10712 msglen = 1
10713 CALL mpi_ibcast(msg, msglen, mpi_integer8, source, comm%handle, request%handle, ierr)
10714 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
10715 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_8_size)
10716#else
10717 mark_used(msg)
10718 mark_used(source)
10719 mark_used(comm)
10720 request = mp_request_null
10721#endif
10722 CALL mp_timestop(handle)
10723 END SUBROUTINE mp_ibcast_l
10724
10725! **************************************************************************************************
10726!> \brief Broadcasts rank-1 data to all processes
10727!> \param[in] msg Data to broadcast
10728!> \param source ...
10729!> \param comm ...
10730!> \note see mp_bcast_l1
10731! **************************************************************************************************
10732 SUBROUTINE mp_bcast_lv(msg, source, comm)
10733 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10734 INTEGER, INTENT(IN) :: source
10735 CLASS(mp_comm_type), INTENT(IN) :: comm
10736
10737 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lv'
10738
10739 INTEGER :: handle
10740#if defined(__parallel)
10741 INTEGER :: ierr, msglen
10742#endif
10743
10744 CALL mp_timeset(routinen, handle)
10745
10746#if defined(__parallel)
10747 msglen = SIZE(msg)
10748 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10749 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10750 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10751#else
10752 mark_used(msg)
10753 mark_used(source)
10754 mark_used(comm)
10755#endif
10756 CALL mp_timestop(handle)
10757 END SUBROUTINE mp_bcast_lv
10758
10759! **************************************************************************************************
10760!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
10761!> \param[in] msg Data to broadcast
10762!> \param comm ...
10763!> \note see mp_bcast_l1
10764! **************************************************************************************************
10765 SUBROUTINE mp_bcast_lv_src(msg, comm)
10766 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
10767 CLASS(mp_comm_type), INTENT(IN) :: comm
10768
10769 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lv_src'
10770
10771 INTEGER :: handle
10772#if defined(__parallel)
10773 INTEGER :: ierr, msglen
10774#endif
10775
10776 CALL mp_timeset(routinen, handle)
10777
10778#if defined(__parallel)
10779 msglen = SIZE(msg)
10780 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10781 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10782 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10783#else
10784 mark_used(msg)
10785 mark_used(comm)
10786#endif
10787 CALL mp_timestop(handle)
10788 END SUBROUTINE mp_bcast_lv_src
10789
10790! **************************************************************************************************
10791!> \brief Broadcasts rank-1 data to all processes
10792!> \param[in] msg Data to broadcast
10793!> \param source ...
10794!> \param comm ...
10795!> \note see mp_bcast_l1
10796! **************************************************************************************************
10797 SUBROUTINE mp_ibcast_lv(msg, source, comm, request)
10798 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
10799 INTEGER, INTENT(IN) :: source
10800 CLASS(mp_comm_type), INTENT(IN) :: comm
10801 TYPE(mp_request_type) :: request
10802
10803 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_lv'
10804
10805 INTEGER :: handle
10806#if defined(__parallel)
10807 INTEGER :: ierr, msglen
10808#endif
10809
10810 CALL mp_timeset(routinen, handle)
10811
10812#if defined(__parallel)
10813#if !defined(__GNUC__) || __GNUC__ >= 9
10814 cpassert(is_contiguous(msg))
10815#endif
10816 msglen = SIZE(msg)
10817 CALL mpi_ibcast(msg, msglen, mpi_integer8, source, comm%handle, request%handle, ierr)
10818 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
10819 CALL add_perf(perf_id=22, count=1, msg_size=msglen*int_8_size)
10820#else
10821 mark_used(msg)
10822 mark_used(source)
10823 mark_used(comm)
10824 request = mp_request_null
10825#endif
10826 CALL mp_timestop(handle)
10827 END SUBROUTINE mp_ibcast_lv
10828
10829! **************************************************************************************************
10830!> \brief Broadcasts rank-2 data to all processes
10831!> \param[in] msg Data to broadcast
10832!> \param source ...
10833!> \param comm ...
10834!> \note see mp_bcast_l1
10835! **************************************************************************************************
10836 SUBROUTINE mp_bcast_lm(msg, source, comm)
10837 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10838 INTEGER, INTENT(IN) :: source
10839 CLASS(mp_comm_type), INTENT(IN) :: comm
10840
10841 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lm'
10842
10843 INTEGER :: handle
10844#if defined(__parallel)
10845 INTEGER :: ierr, msglen
10846#endif
10847
10848 CALL mp_timeset(routinen, handle)
10849
10850#if defined(__parallel)
10851 msglen = SIZE(msg)
10852 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10853 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10854 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10855#else
10856 mark_used(msg)
10857 mark_used(source)
10858 mark_used(comm)
10859#endif
10860 CALL mp_timestop(handle)
10861 END SUBROUTINE mp_bcast_lm
10862
10863! **************************************************************************************************
10864!> \brief Broadcasts rank-2 data to all processes
10865!> \param[in] msg Data to broadcast
10866!> \param source ...
10867!> \param comm ...
10868!> \note see mp_bcast_l1
10869! **************************************************************************************************
10870 SUBROUTINE mp_bcast_lm_src(msg, comm)
10871 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
10872 CLASS(mp_comm_type), INTENT(IN) :: comm
10873
10874 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_lm_src'
10875
10876 INTEGER :: handle
10877#if defined(__parallel)
10878 INTEGER :: ierr, msglen
10879#endif
10880
10881 CALL mp_timeset(routinen, handle)
10882
10883#if defined(__parallel)
10884 msglen = SIZE(msg)
10885 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10886 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10887 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10888#else
10889 mark_used(msg)
10890 mark_used(comm)
10891#endif
10892 CALL mp_timestop(handle)
10893 END SUBROUTINE mp_bcast_lm_src
10894
10895! **************************************************************************************************
10896!> \brief Broadcasts rank-3 data to all processes
10897!> \param[in] msg Data to broadcast
10898!> \param source ...
10899!> \param comm ...
10900!> \note see mp_bcast_l1
10901! **************************************************************************************************
10902 SUBROUTINE mp_bcast_l3(msg, source, comm)
10903 INTEGER(KIND=int_8), CONTIGUOUS :: msg(:, :, :)
10904 INTEGER, INTENT(IN) :: source
10905 CLASS(mp_comm_type), INTENT(IN) :: comm
10906
10907 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l3'
10908
10909 INTEGER :: handle
10910#if defined(__parallel)
10911 INTEGER :: ierr, msglen
10912#endif
10913
10914 CALL mp_timeset(routinen, handle)
10915
10916#if defined(__parallel)
10917 msglen = SIZE(msg)
10918 CALL mpi_bcast(msg, msglen, mpi_integer8, source, comm%handle, ierr)
10919 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10920 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10921#else
10922 mark_used(msg)
10923 mark_used(source)
10924 mark_used(comm)
10925#endif
10926 CALL mp_timestop(handle)
10927 END SUBROUTINE mp_bcast_l3
10928
10929! **************************************************************************************************
10930!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
10931!> \param[in] msg Data to broadcast
10932!> \param source ...
10933!> \param comm ...
10934!> \note see mp_bcast_l1
10935! **************************************************************************************************
10936 SUBROUTINE mp_bcast_l3_src(msg, comm)
10937 INTEGER(KIND=int_8), CONTIGUOUS :: msg(:, :, :)
10938 CLASS(mp_comm_type), INTENT(IN) :: comm
10939
10940 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_l3_src'
10941
10942 INTEGER :: handle
10943#if defined(__parallel)
10944 INTEGER :: ierr, msglen
10945#endif
10946
10947 CALL mp_timeset(routinen, handle)
10948
10949#if defined(__parallel)
10950 msglen = SIZE(msg)
10951 CALL mpi_bcast(msg, msglen, mpi_integer8, comm%source, comm%handle, ierr)
10952 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
10953 CALL add_perf(perf_id=2, count=1, msg_size=msglen*int_8_size)
10954#else
10955 mark_used(msg)
10956 mark_used(comm)
10957#endif
10958 CALL mp_timestop(handle)
10959 END SUBROUTINE mp_bcast_l3_src
10960
10961! **************************************************************************************************
10962!> \brief Sums a datum from all processes with result left on all processes.
10963!> \param[in,out] msg Datum to sum (input) and result (output)
10964!> \param[in] comm Message passing environment identifier
10965!> \par MPI mapping
10966!> mpi_allreduce
10967! **************************************************************************************************
10968 SUBROUTINE mp_sum_l (msg, comm)
10969 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
10970 CLASS(mp_comm_type), INTENT(IN) :: comm
10971
10972 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_l'
10973
10974 INTEGER :: handle
10975#if defined(__parallel)
10976 INTEGER :: ierr, msglen
10977#endif
10978
10979 CALL mp_timeset(routinen, handle)
10980
10981#if defined(__parallel)
10982 msglen = 1
10983 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
10984 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
10985 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
10986#else
10987 mark_used(msg)
10988 mark_used(comm)
10989#endif
10990 CALL mp_timestop(handle)
10991 END SUBROUTINE mp_sum_l
10992
10993! **************************************************************************************************
10994!> \brief Element-wise sum of a rank-1 array on all processes.
10995!> \param[in,out] msg Vector to sum and result
10996!> \param comm ...
10997!> \note see mp_sum_l
10998! **************************************************************************************************
10999 SUBROUTINE mp_sum_lv(msg, comm)
11000 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
11001 CLASS(mp_comm_type), INTENT(IN) :: comm
11002
11003 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lv'
11004
11005 INTEGER :: handle
11006#if defined(__parallel)
11007 INTEGER :: ierr, msglen
11008#endif
11009
11010 CALL mp_timeset(routinen, handle)
11011
11012#if defined(__parallel)
11013 msglen = SIZE(msg)
11014 IF (msglen > 0) THEN
11015 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11016 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11017 END IF
11018 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11019#else
11020 mark_used(msg)
11021 mark_used(comm)
11022#endif
11023 CALL mp_timestop(handle)
11024 END SUBROUTINE mp_sum_lv
11025
11026! **************************************************************************************************
11027!> \brief Element-wise sum of a rank-1 array on all processes.
11028!> \param[in,out] msg Vector to sum and result
11029!> \param comm ...
11030!> \note see mp_sum_l
11031! **************************************************************************************************
11032 SUBROUTINE mp_isum_lv(msg, comm, request)
11033 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11034 CLASS(mp_comm_type), INTENT(IN) :: comm
11035 TYPE(mp_request_type), INTENT(OUT) :: request
11036
11037 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_lv'
11038
11039 INTEGER :: handle
11040#if defined(__parallel)
11041 INTEGER :: ierr, msglen
11042#endif
11043
11044 CALL mp_timeset(routinen, handle)
11045
11046#if defined(__parallel)
11047#if !defined(__GNUC__) || __GNUC__ >= 9
11048 cpassert(is_contiguous(msg))
11049#endif
11050 msglen = SIZE(msg)
11051 IF (msglen > 0) THEN
11052 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, request%handle, ierr)
11053 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
11054 ELSE
11055 request = mp_request_null
11056 END IF
11057 CALL add_perf(perf_id=23, count=1, msg_size=msglen*int_8_size)
11058#else
11059 mark_used(msg)
11060 mark_used(comm)
11061 request = mp_request_null
11062#endif
11063 CALL mp_timestop(handle)
11064 END SUBROUTINE mp_isum_lv
11065
11066! **************************************************************************************************
11067!> \brief Element-wise sum of a rank-2 array on all processes.
11068!> \param[in] msg Matrix to sum and result
11069!> \param comm ...
11070!> \note see mp_sum_l
11071! **************************************************************************************************
11072 SUBROUTINE mp_sum_lm(msg, comm)
11073 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11074 CLASS(mp_comm_type), INTENT(IN) :: comm
11075
11076 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm'
11077
11078 INTEGER :: handle
11079#if defined(__parallel)
11080 INTEGER, PARAMETER :: max_msg = 2**25
11081 INTEGER :: ierr, m1, msglen, step, msglensum
11082#endif
11083
11084 CALL mp_timeset(routinen, handle)
11085
11086#if defined(__parallel)
11087 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
11088 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
11089 msglensum = 0
11090 DO m1 = lbound(msg, 2), ubound(msg, 2), step
11091 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
11092 msglensum = msglensum + msglen
11093 IF (msglen > 0) THEN
11094 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11095 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11096 END IF
11097 END DO
11098 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*int_8_size)
11099#else
11100 mark_used(msg)
11101 mark_used(comm)
11102#endif
11103 CALL mp_timestop(handle)
11104 END SUBROUTINE mp_sum_lm
11105
11106! **************************************************************************************************
11107!> \brief Element-wise sum of a rank-3 array on all processes.
11108!> \param[in] msg Array to sum and result
11109!> \param comm ...
11110!> \note see mp_sum_l
11111! **************************************************************************************************
11112 SUBROUTINE mp_sum_lm3(msg, comm)
11113 INTEGER(KIND=int_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
11114 CLASS(mp_comm_type), INTENT(IN) :: comm
11115
11116 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm3'
11117
11118 INTEGER :: handle
11119#if defined(__parallel)
11120 INTEGER :: ierr, msglen
11121#endif
11122
11123 CALL mp_timeset(routinen, handle)
11124
11125#if defined(__parallel)
11126 msglen = SIZE(msg)
11127 IF (msglen > 0) THEN
11128 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11129 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11130 END IF
11131 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11132#else
11133 mark_used(msg)
11134 mark_used(comm)
11135#endif
11136 CALL mp_timestop(handle)
11137 END SUBROUTINE mp_sum_lm3
11138
11139! **************************************************************************************************
11140!> \brief Element-wise sum of a rank-4 array on all processes.
11141!> \param[in] msg Array to sum and result
11142!> \param comm ...
11143!> \note see mp_sum_l
11144! **************************************************************************************************
11145 SUBROUTINE mp_sum_lm4(msg, comm)
11146 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
11147 CLASS(mp_comm_type), INTENT(IN) :: comm
11148
11149 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_lm4'
11150
11151 INTEGER :: handle
11152#if defined(__parallel)
11153 INTEGER :: ierr, msglen
11154#endif
11155
11156 CALL mp_timeset(routinen, handle)
11157
11158#if defined(__parallel)
11159 msglen = SIZE(msg)
11160 IF (msglen > 0) THEN
11161 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11162 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11163 END IF
11164 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11165#else
11166 mark_used(msg)
11167 mark_used(comm)
11168#endif
11169 CALL mp_timestop(handle)
11170 END SUBROUTINE mp_sum_lm4
11171
11172! **************************************************************************************************
11173!> \brief Element-wise sum of data from all processes with result left only on
11174!> one.
11175!> \param[in,out] msg Vector to sum (input) and (only on process root)
11176!> result (output)
11177!> \param root ...
11178!> \param[in] comm Message passing environment identifier
11179!> \par MPI mapping
11180!> mpi_reduce
11181! **************************************************************************************************
11182 SUBROUTINE mp_sum_root_lv(msg, root, comm)
11183 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
11184 INTEGER, INTENT(IN) :: root
11185 CLASS(mp_comm_type), INTENT(IN) :: comm
11186
11187 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_lv'
11188
11189 INTEGER :: handle
11190#if defined(__parallel)
11191 INTEGER :: ierr, m1, msglen, taskid
11192 INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
11193#endif
11194
11195 CALL mp_timeset(routinen, handle)
11196
11197#if defined(__parallel)
11198 msglen = SIZE(msg)
11199 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11200 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11201 IF (msglen > 0) THEN
11202 m1 = SIZE(msg, 1)
11203 ALLOCATE (res(m1))
11204 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_sum, &
11205 root, comm%handle, ierr)
11206 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11207 IF (taskid == root) THEN
11208 msg = res
11209 END IF
11210 DEALLOCATE (res)
11211 END IF
11212 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11213#else
11214 mark_used(msg)
11215 mark_used(root)
11216 mark_used(comm)
11217#endif
11218 CALL mp_timestop(handle)
11219 END SUBROUTINE mp_sum_root_lv
11220
11221! **************************************************************************************************
11222!> \brief Element-wise sum of data from all processes with result left only on
11223!> one.
11224!> \param[in,out] msg Matrix to sum (input) and (only on process root)
11225!> result (output)
11226!> \param root ...
11227!> \param comm ...
11228!> \note see mp_sum_root_lv
11229! **************************************************************************************************
11230 SUBROUTINE mp_sum_root_lm(msg, root, comm)
11231 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11232 INTEGER, INTENT(IN) :: root
11233 CLASS(mp_comm_type), INTENT(IN) :: comm
11234
11235 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
11236
11237 INTEGER :: handle
11238#if defined(__parallel)
11239 INTEGER :: ierr, m1, m2, msglen, taskid
11240 INTEGER(KIND=int_8), ALLOCATABLE :: res(:, :)
11241#endif
11242
11243 CALL mp_timeset(routinen, handle)
11244
11245#if defined(__parallel)
11246 msglen = SIZE(msg)
11247 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11248 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11249 IF (msglen > 0) THEN
11250 m1 = SIZE(msg, 1)
11251 m2 = SIZE(msg, 2)
11252 ALLOCATE (res(m1, m2))
11253 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_sum, root, comm%handle, ierr)
11254 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11255 IF (taskid == root) THEN
11256 msg = res
11257 END IF
11258 DEALLOCATE (res)
11259 END IF
11260 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11261#else
11262 mark_used(root)
11263 mark_used(msg)
11264 mark_used(comm)
11265#endif
11266 CALL mp_timestop(handle)
11267 END SUBROUTINE mp_sum_root_lm
11268
11269! **************************************************************************************************
11270!> \brief Partial sum of data from all processes with result on each process.
11271!> \param[in] msg Matrix to sum (input)
11272!> \param[out] res Matrix containing result (output)
11273!> \param[in] comm Message passing environment identifier
11274! **************************************************************************************************
11275 SUBROUTINE mp_sum_partial_lm(msg, res, comm)
11276 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11277 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
11278 CLASS(mp_comm_type), INTENT(IN) :: comm
11279
11280 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_lm'
11281
11282 INTEGER :: handle
11283#if defined(__parallel)
11284 INTEGER :: ierr, msglen, taskid
11285#endif
11286
11287 CALL mp_timeset(routinen, handle)
11288
11289#if defined(__parallel)
11290 msglen = SIZE(msg)
11291 CALL mpi_comm_rank(comm%handle, taskid, ierr)
11292 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
11293 IF (msglen > 0) THEN
11294 CALL mpi_scan(msg, res, msglen, mpi_integer8, mpi_sum, comm%handle, ierr)
11295 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
11296 END IF
11297 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11298 ! perf_id is same as for other summation routines
11299#else
11300 res = msg
11301 mark_used(comm)
11302#endif
11303 CALL mp_timestop(handle)
11304 END SUBROUTINE mp_sum_partial_lm
11305
11306! **************************************************************************************************
11307!> \brief Finds the maximum of a datum with the result left on all processes.
11308!> \param[in,out] msg Find maximum among these data (input) and
11309!> maximum (output)
11310!> \param[in] comm Message passing environment identifier
11311!> \par MPI mapping
11312!> mpi_allreduce
11313! **************************************************************************************************
11314 SUBROUTINE mp_max_l (msg, comm)
11315 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11316 CLASS(mp_comm_type), INTENT(IN) :: comm
11317
11318 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_l'
11319
11320 INTEGER :: handle
11321#if defined(__parallel)
11322 INTEGER :: ierr, msglen
11323#endif
11324
11325 CALL mp_timeset(routinen, handle)
11326
11327#if defined(__parallel)
11328 msglen = 1
11329 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11330 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
11336 CALL mp_timestop(handle)
11337 END SUBROUTINE mp_max_l
11338
11339! **************************************************************************************************
11340!> \brief Finds the maximum of a datum with the result left on all processes.
11341!> \param[in,out] msg Find maximum among these data (input) and
11342!> maximum (output)
11343!> \param[in] comm Message passing environment identifier
11344!> \par MPI mapping
11345!> mpi_allreduce
11346! **************************************************************************************************
11347 SUBROUTINE mp_max_root_l (msg, root, comm)
11348 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11349 INTEGER, INTENT(IN) :: root
11350 CLASS(mp_comm_type), INTENT(IN) :: comm
11351
11352 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_l'
11353
11354 INTEGER :: handle
11355#if defined(__parallel)
11356 INTEGER :: ierr, msglen
11357 INTEGER(KIND=int_8) :: res
11358#endif
11359
11360 CALL mp_timeset(routinen, handle)
11361
11362#if defined(__parallel)
11363 msglen = 1
11364 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_max, root, comm%handle, ierr)
11365 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
11366 IF (root == comm%mepos) msg = res
11367 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11368#else
11369 mark_used(msg)
11370 mark_used(comm)
11371 mark_used(root)
11372#endif
11373 CALL mp_timestop(handle)
11374 END SUBROUTINE mp_max_root_l
11375
11376! **************************************************************************************************
11377!> \brief Finds the element-wise maximum of a vector with the result left on
11378!> all processes.
11379!> \param[in,out] msg Find maximum among these data (input) and
11380!> maximum (output)
11381!> \param comm ...
11382!> \note see mp_max_l
11383! **************************************************************************************************
11384 SUBROUTINE mp_max_lv(msg, comm)
11385 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
11386 CLASS(mp_comm_type), INTENT(IN) :: comm
11387
11388 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_lv'
11389
11390 INTEGER :: handle
11391#if defined(__parallel)
11392 INTEGER :: ierr, msglen
11393#endif
11394
11395 CALL mp_timeset(routinen, handle)
11396
11397#if defined(__parallel)
11398 msglen = SIZE(msg)
11399 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_max, comm%handle, ierr)
11400 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
11406 CALL mp_timestop(handle)
11407 END SUBROUTINE mp_max_lv
11408
11409! **************************************************************************************************
11410!> \brief Finds the element-wise maximum of a vector with the result left on
11411!> all processes.
11412!> \param[in,out] msg Find maximum among these data (input) and
11413!> maximum (output)
11414!> \param comm ...
11415!> \note see mp_max_l
11416! **************************************************************************************************
11417 SUBROUTINE mp_max_root_lm(msg, root, comm)
11418 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
11419 INTEGER :: root
11420 CLASS(mp_comm_type), INTENT(IN) :: comm
11421
11422 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_lm'
11423
11424 INTEGER :: handle
11425#if defined(__parallel)
11426 INTEGER :: ierr, msglen
11427 INTEGER(KIND=int_8) :: res(size(msg, 1), size(msg, 2))
11428#endif
11429
11430 CALL mp_timeset(routinen, handle)
11431
11432#if defined(__parallel)
11433 msglen = SIZE(msg)
11434 CALL mpi_reduce(msg, res, msglen, mpi_integer8, mpi_max, root, comm%handle, ierr)
11435 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11436 IF (root == comm%mepos) msg = res
11437 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11438#else
11439 mark_used(msg)
11440 mark_used(comm)
11441 mark_used(root)
11442#endif
11443 CALL mp_timestop(handle)
11444 END SUBROUTINE mp_max_root_lm
11445
11446! **************************************************************************************************
11447!> \brief Finds the minimum of a datum with the result left on all processes.
11448!> \param[in,out] msg Find minimum among these data (input) and
11449!> maximum (output)
11450!> \param[in] comm Message passing environment identifier
11451!> \par MPI mapping
11452!> mpi_allreduce
11453! **************************************************************************************************
11454 SUBROUTINE mp_min_l (msg, comm)
11455 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11456 CLASS(mp_comm_type), INTENT(IN) :: comm
11457
11458 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_l'
11459
11460 INTEGER :: handle
11461#if defined(__parallel)
11462 INTEGER :: ierr, msglen
11463#endif
11464
11465 CALL mp_timeset(routinen, handle)
11466
11467#if defined(__parallel)
11468 msglen = 1
11469 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11470 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11471 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11472#else
11473 mark_used(msg)
11474 mark_used(comm)
11475#endif
11476 CALL mp_timestop(handle)
11477 END SUBROUTINE mp_min_l
11478
11479! **************************************************************************************************
11480!> \brief Finds the element-wise minimum of vector with the result left on
11481!> all processes.
11482!> \param[in,out] msg Find minimum among these data (input) and
11483!> maximum (output)
11484!> \param comm ...
11485!> \par MPI mapping
11486!> mpi_allreduce
11487!> \note see mp_min_l
11488! **************************************************************************************************
11489 SUBROUTINE mp_min_lv(msg, comm)
11490 INTEGER(KIND=int_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
11491 CLASS(mp_comm_type), INTENT(IN) :: comm
11492
11493 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_lv'
11494
11495 INTEGER :: handle
11496#if defined(__parallel)
11497 INTEGER :: ierr, msglen
11498#endif
11499
11500 CALL mp_timeset(routinen, handle)
11501
11502#if defined(__parallel)
11503 msglen = SIZE(msg)
11504 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_min, comm%handle, ierr)
11505 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11506 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11507#else
11508 mark_used(msg)
11509 mark_used(comm)
11510#endif
11511 CALL mp_timestop(handle)
11512 END SUBROUTINE mp_min_lv
11513
11514! **************************************************************************************************
11515!> \brief Multiplies a set of numbers scattered across a number of processes,
11516!> then replicates the result.
11517!> \param[in,out] msg a number to multiply (input) and result (output)
11518!> \param[in] comm message passing environment identifier
11519!> \par MPI mapping
11520!> mpi_allreduce
11521! **************************************************************************************************
11522 SUBROUTINE mp_prod_l (msg, comm)
11523 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11524 CLASS(mp_comm_type), INTENT(IN) :: comm
11525
11526 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_l'
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 = 1
11537 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_integer8, mpi_prod, comm%handle, ierr)
11538 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
11539 CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
11540#else
11541 mark_used(msg)
11542 mark_used(comm)
11543#endif
11544 CALL mp_timestop(handle)
11545 END SUBROUTINE mp_prod_l
11546
11547! **************************************************************************************************
11548!> \brief Scatters data from one processes to all others
11549!> \param[in] msg_scatter Data to scatter (for root process)
11550!> \param[out] msg Received data
11551!> \param[in] root Process which scatters data
11552!> \param[in] comm Message passing environment identifier
11553!> \par MPI mapping
11554!> mpi_scatter
11555! **************************************************************************************************
11556 SUBROUTINE mp_scatter_lv(msg_scatter, msg, root, comm)
11557 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
11558 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
11559 INTEGER, INTENT(IN) :: root
11560 CLASS(mp_comm_type), INTENT(IN) :: comm
11561
11562 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_lv'
11563
11564 INTEGER :: handle
11565#if defined(__parallel)
11566 INTEGER :: ierr, msglen
11567#endif
11568
11569 CALL mp_timeset(routinen, handle)
11570
11571#if defined(__parallel)
11572 msglen = SIZE(msg)
11573 CALL mpi_scatter(msg_scatter, msglen, mpi_integer8, msg, &
11574 msglen, mpi_integer8, root, comm%handle, ierr)
11575 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
11576 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11577#else
11578 mark_used(root)
11579 mark_used(comm)
11580 msg = msg_scatter
11581#endif
11582 CALL mp_timestop(handle)
11583 END SUBROUTINE mp_scatter_lv
11584
11585! **************************************************************************************************
11586!> \brief Scatters data from one processes to all others
11587!> \param[in] msg_scatter Data to scatter (for root process)
11588!> \param[in] root Process which scatters data
11589!> \param[in] comm Message passing environment identifier
11590!> \par MPI mapping
11591!> mpi_scatter
11592! **************************************************************************************************
11593 SUBROUTINE mp_iscatter_l (msg_scatter, msg, root, comm, request)
11594 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:)
11595 INTEGER(KIND=int_8), INTENT(INOUT) :: msg
11596 INTEGER, INTENT(IN) :: root
11597 CLASS(mp_comm_type), INTENT(IN) :: comm
11598 TYPE(mp_request_type), INTENT(OUT) :: request
11599
11600 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_l'
11601
11602 INTEGER :: handle
11603#if defined(__parallel)
11604 INTEGER :: ierr, msglen
11605#endif
11606
11607 CALL mp_timeset(routinen, handle)
11608
11609#if defined(__parallel)
11610#if !defined(__GNUC__) || __GNUC__ >= 9
11611 cpassert(is_contiguous(msg_scatter))
11612#endif
11613 msglen = 1
11614 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer8, msg, &
11615 msglen, mpi_integer8, root, comm%handle, request%handle, ierr)
11616 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
11617 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11618#else
11619 mark_used(root)
11620 mark_used(comm)
11621 msg = msg_scatter(1)
11622 request = mp_request_null
11623#endif
11624 CALL mp_timestop(handle)
11625 END SUBROUTINE mp_iscatter_l
11626
11627! **************************************************************************************************
11628!> \brief Scatters data from one processes to all others
11629!> \param[in] msg_scatter Data to scatter (for root process)
11630!> \param[in] root Process which scatters data
11631!> \param[in] comm Message passing environment identifier
11632!> \par MPI mapping
11633!> mpi_scatter
11634! **************************************************************************************************
11635 SUBROUTINE mp_iscatter_lv2(msg_scatter, msg, root, comm, request)
11636 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:, :)
11637 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11638 INTEGER, INTENT(IN) :: root
11639 CLASS(mp_comm_type), INTENT(IN) :: comm
11640 TYPE(mp_request_type), INTENT(OUT) :: request
11641
11642 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_lv2'
11643
11644 INTEGER :: handle
11645#if defined(__parallel)
11646 INTEGER :: ierr, msglen
11647#endif
11648
11649 CALL mp_timeset(routinen, handle)
11650
11651#if defined(__parallel)
11652#if !defined(__GNUC__) || __GNUC__ >= 9
11653 cpassert(is_contiguous(msg_scatter))
11654#endif
11655 msglen = SIZE(msg)
11656 CALL mpi_iscatter(msg_scatter, msglen, mpi_integer8, msg, &
11657 msglen, mpi_integer8, root, comm%handle, request%handle, ierr)
11658 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
11659 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11660#else
11661 mark_used(root)
11662 mark_used(comm)
11663 msg(:) = msg_scatter(:, 1)
11664 request = mp_request_null
11665#endif
11666 CALL mp_timestop(handle)
11667 END SUBROUTINE mp_iscatter_lv2
11668
11669! **************************************************************************************************
11670!> \brief Scatters data from one processes to all others
11671!> \param[in] msg_scatter Data to scatter (for root process)
11672!> \param[in] root Process which scatters data
11673!> \param[in] comm Message passing environment identifier
11674!> \par MPI mapping
11675!> mpi_scatter
11676! **************************************************************************************************
11677 SUBROUTINE mp_iscatterv_lv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
11678 INTEGER(KIND=int_8), INTENT(IN) :: msg_scatter(:)
11679 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
11680 INTEGER(KIND=int_8), INTENT(INOUT) :: msg(:)
11681 INTEGER, INTENT(IN) :: recvcount, root
11682 CLASS(mp_comm_type), INTENT(IN) :: comm
11683 TYPE(mp_request_type), INTENT(OUT) :: request
11684
11685 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_lv'
11686
11687 INTEGER :: handle
11688#if defined(__parallel)
11689 INTEGER :: ierr
11690#endif
11691
11692 CALL mp_timeset(routinen, handle)
11693
11694#if defined(__parallel)
11695#if !defined(__GNUC__) || __GNUC__ >= 9
11696 cpassert(is_contiguous(msg_scatter))
11697 cpassert(is_contiguous(msg))
11698 cpassert(is_contiguous(sendcounts))
11699 cpassert(is_contiguous(displs))
11700#endif
11701 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_integer8, msg, &
11702 recvcount, mpi_integer8, root, comm%handle, request%handle, ierr)
11703 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
11704 CALL add_perf(perf_id=24, count=1, msg_size=1*int_8_size)
11705#else
11706 mark_used(sendcounts)
11707 mark_used(displs)
11708 mark_used(recvcount)
11709 mark_used(root)
11710 mark_used(comm)
11711 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
11712 request = mp_request_null
11713#endif
11714 CALL mp_timestop(handle)
11715 END SUBROUTINE mp_iscatterv_lv
11716
11717! **************************************************************************************************
11718!> \brief Gathers a datum from all processes to one
11719!> \param[in] msg Datum to send to root
11720!> \param[out] msg_gather Received data (on root)
11721!> \param[in] root Process which gathers the data
11722!> \param[in] comm Message passing environment identifier
11723!> \par MPI mapping
11724!> mpi_gather
11725! **************************************************************************************************
11726 SUBROUTINE mp_gather_l (msg, msg_gather, root, comm)
11727 INTEGER(KIND=int_8), INTENT(IN) :: msg
11728 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11729 INTEGER, INTENT(IN) :: root
11730 CLASS(mp_comm_type), INTENT(IN) :: comm
11731
11732 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_l'
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, root, 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(root)
11749 mark_used(comm)
11750 msg_gather(1) = msg
11751#endif
11752 CALL mp_timestop(handle)
11753 END SUBROUTINE mp_gather_l
11754
11755! **************************************************************************************************
11756!> \brief Gathers a datum from all processes to one, uses the source process of comm
11757!> \param[in] msg Datum to send to root
11758!> \param[out] msg_gather Received data (on root)
11759!> \param[in] comm Message passing environment identifier
11760!> \par MPI mapping
11761!> mpi_gather
11762! **************************************************************************************************
11763 SUBROUTINE mp_gather_l_src(msg, msg_gather, comm)
11764 INTEGER(KIND=int_8), INTENT(IN) :: msg
11765 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11766 CLASS(mp_comm_type), INTENT(IN) :: comm
11767
11768 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_l_src'
11769
11770 INTEGER :: handle
11771#if defined(__parallel)
11772 INTEGER :: ierr, msglen
11773#endif
11774
11775 CALL mp_timeset(routinen, handle)
11776
11777#if defined(__parallel)
11778 msglen = 1
11779 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11780 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11781 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11782 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11783#else
11784 mark_used(comm)
11785 msg_gather(1) = msg
11786#endif
11787 CALL mp_timestop(handle)
11788 END SUBROUTINE mp_gather_l_src
11789
11790! **************************************************************************************************
11791!> \brief Gathers data from all processes to one
11792!> \param[in] msg Datum to send to root
11793!> \param msg_gather ...
11794!> \param root ...
11795!> \param comm ...
11796!> \par Data length
11797!> All data (msg) is equal-sized
11798!> \par MPI mapping
11799!> mpi_gather
11800!> \note see mp_gather_l
11801! **************************************************************************************************
11802 SUBROUTINE mp_gather_lv(msg, msg_gather, root, comm)
11803 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
11804 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11805 INTEGER, INTENT(IN) :: root
11806 CLASS(mp_comm_type), INTENT(IN) :: comm
11807
11808 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lv'
11809
11810 INTEGER :: handle
11811#if defined(__parallel)
11812 INTEGER :: ierr, msglen
11813#endif
11814
11815 CALL mp_timeset(routinen, handle)
11816
11817#if defined(__parallel)
11818 msglen = SIZE(msg)
11819 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11820 msglen, mpi_integer8, root, comm%handle, ierr)
11821 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11822 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11823#else
11824 mark_used(root)
11825 mark_used(comm)
11826 msg_gather = msg
11827#endif
11828 CALL mp_timestop(handle)
11829 END SUBROUTINE mp_gather_lv
11830
11831! **************************************************************************************************
11832!> \brief Gathers data from all processes to one. Gathers from comm%source
11833!> \param[in] msg Datum to send to root
11834!> \param msg_gather ...
11835!> \param comm ...
11836!> \par Data length
11837!> All data (msg) is equal-sized
11838!> \par MPI mapping
11839!> mpi_gather
11840!> \note see mp_gather_l
11841! **************************************************************************************************
11842 SUBROUTINE mp_gather_lv_src(msg, msg_gather, comm)
11843 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
11844 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
11845 CLASS(mp_comm_type), INTENT(IN) :: comm
11846
11847 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lv_src'
11848
11849 INTEGER :: handle
11850#if defined(__parallel)
11851 INTEGER :: ierr, msglen
11852#endif
11853
11854 CALL mp_timeset(routinen, handle)
11855
11856#if defined(__parallel)
11857 msglen = SIZE(msg)
11858 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11859 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11860 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11861 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11862#else
11863 mark_used(comm)
11864 msg_gather = msg
11865#endif
11866 CALL mp_timestop(handle)
11867 END SUBROUTINE mp_gather_lv_src
11868
11869! **************************************************************************************************
11870!> \brief Gathers data from all processes to one
11871!> \param[in] msg Datum to send to root
11872!> \param msg_gather ...
11873!> \param root ...
11874!> \param comm ...
11875!> \par Data length
11876!> All data (msg) is equal-sized
11877!> \par MPI mapping
11878!> mpi_gather
11879!> \note see mp_gather_l
11880! **************************************************************************************************
11881 SUBROUTINE mp_gather_lm(msg, msg_gather, root, comm)
11882 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11883 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
11884 INTEGER, INTENT(IN) :: root
11885 CLASS(mp_comm_type), INTENT(IN) :: comm
11886
11887 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lm'
11888
11889 INTEGER :: handle
11890#if defined(__parallel)
11891 INTEGER :: ierr, msglen
11892#endif
11893
11894 CALL mp_timeset(routinen, handle)
11895
11896#if defined(__parallel)
11897 msglen = SIZE(msg)
11898 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11899 msglen, mpi_integer8, root, comm%handle, ierr)
11900 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11901 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11902#else
11903 mark_used(root)
11904 mark_used(comm)
11905 msg_gather = msg
11906#endif
11907 CALL mp_timestop(handle)
11908 END SUBROUTINE mp_gather_lm
11909
11910! **************************************************************************************************
11911!> \brief Gathers data from all processes to one. Gathers from comm%source
11912!> \param[in] msg Datum to send to root
11913!> \param msg_gather ...
11914!> \param comm ...
11915!> \par Data length
11916!> All data (msg) is equal-sized
11917!> \par MPI mapping
11918!> mpi_gather
11919!> \note see mp_gather_l
11920! **************************************************************************************************
11921 SUBROUTINE mp_gather_lm_src(msg, msg_gather, comm)
11922 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
11923 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
11924 CLASS(mp_comm_type), INTENT(IN) :: comm
11925
11926 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_lm_src'
11927
11928 INTEGER :: handle
11929#if defined(__parallel)
11930 INTEGER :: ierr, msglen
11931#endif
11932
11933 CALL mp_timeset(routinen, handle)
11934
11935#if defined(__parallel)
11936 msglen = SIZE(msg)
11937 CALL mpi_gather(msg, msglen, mpi_integer8, msg_gather, &
11938 msglen, mpi_integer8, comm%source, comm%handle, ierr)
11939 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
11940 CALL add_perf(perf_id=4, count=1, msg_size=msglen*int_8_size)
11941#else
11942 mark_used(comm)
11943 msg_gather = msg
11944#endif
11945 CALL mp_timestop(handle)
11946 END SUBROUTINE mp_gather_lm_src
11947
11948! **************************************************************************************************
11949!> \brief Gathers data from all processes to one.
11950!> \param[in] sendbuf Data to send to root
11951!> \param[out] recvbuf Received data (on root)
11952!> \param[in] recvcounts Sizes of data received from processes
11953!> \param[in] displs Offsets of data received from processes
11954!> \param[in] root Process which gathers the data
11955!> \param[in] comm Message passing environment identifier
11956!> \par Data length
11957!> Data can have different lengths
11958!> \par Offsets
11959!> Offsets start at 0
11960!> \par MPI mapping
11961!> mpi_gather
11962! **************************************************************************************************
11963 SUBROUTINE mp_gatherv_lv(sendbuf, recvbuf, recvcounts, displs, root, comm)
11964
11965 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
11966 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
11967 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
11968 INTEGER, INTENT(IN) :: root
11969 CLASS(mp_comm_type), INTENT(IN) :: comm
11970
11971 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lv'
11972
11973 INTEGER :: handle
11974#if defined(__parallel)
11975 INTEGER :: ierr, sendcount
11976#endif
11977
11978 CALL mp_timeset(routinen, handle)
11979
11980#if defined(__parallel)
11981 sendcount = SIZE(sendbuf)
11982 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
11983 recvbuf, recvcounts, displs, mpi_integer8, &
11984 root, comm%handle, ierr)
11985 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
11986 CALL add_perf(perf_id=4, &
11987 count=1, &
11988 msg_size=sendcount*int_8_size)
11989#else
11990 mark_used(recvcounts)
11991 mark_used(root)
11992 mark_used(comm)
11993 recvbuf(1 + displs(1):) = sendbuf
11994#endif
11995 CALL mp_timestop(handle)
11996 END SUBROUTINE mp_gatherv_lv
11997
11998! **************************************************************************************************
11999!> \brief Gathers data from all processes to one. Gathers from comm%source
12000!> \param[in] sendbuf Data to send to root
12001!> \param[out] recvbuf Received data (on root)
12002!> \param[in] recvcounts Sizes of data received from processes
12003!> \param[in] displs Offsets of data received from processes
12004!> \param[in] comm Message passing environment identifier
12005!> \par Data length
12006!> Data can have different lengths
12007!> \par Offsets
12008!> Offsets start at 0
12009!> \par MPI mapping
12010!> mpi_gather
12011! **************************************************************************************************
12012 SUBROUTINE mp_gatherv_lv_src(sendbuf, recvbuf, recvcounts, displs, comm)
12013
12014 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
12015 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
12016 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12017 CLASS(mp_comm_type), INTENT(IN) :: comm
12018
12019 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lv_src'
12020
12021 INTEGER :: handle
12022#if defined(__parallel)
12023 INTEGER :: ierr, sendcount
12024#endif
12025
12026 CALL mp_timeset(routinen, handle)
12027
12028#if defined(__parallel)
12029 sendcount = SIZE(sendbuf)
12030 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12031 recvbuf, recvcounts, displs, mpi_integer8, &
12032 comm%source, comm%handle, ierr)
12033 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12034 CALL add_perf(perf_id=4, &
12035 count=1, &
12036 msg_size=sendcount*int_8_size)
12037#else
12038 mark_used(recvcounts)
12039 mark_used(comm)
12040 recvbuf(1 + displs(1):) = sendbuf
12041#endif
12042 CALL mp_timestop(handle)
12043 END SUBROUTINE mp_gatherv_lv_src
12044
12045! **************************************************************************************************
12046!> \brief Gathers data from all processes to one.
12047!> \param[in] sendbuf Data to send to root
12048!> \param[out] recvbuf Received data (on root)
12049!> \param[in] recvcounts Sizes of data received from processes
12050!> \param[in] displs Offsets of data received from processes
12051!> \param[in] root Process which gathers the data
12052!> \param[in] comm Message passing environment identifier
12053!> \par Data length
12054!> Data can have different lengths
12055!> \par Offsets
12056!> Offsets start at 0
12057!> \par MPI mapping
12058!> mpi_gather
12059! **************************************************************************************************
12060 SUBROUTINE mp_gatherv_lm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
12061
12062 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
12063 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
12064 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12065 INTEGER, INTENT(IN) :: root
12066 CLASS(mp_comm_type), INTENT(IN) :: comm
12067
12068 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lm2'
12069
12070 INTEGER :: handle
12071#if defined(__parallel)
12072 INTEGER :: ierr, sendcount
12073#endif
12074
12075 CALL mp_timeset(routinen, handle)
12076
12077#if defined(__parallel)
12078 sendcount = SIZE(sendbuf)
12079 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12080 recvbuf, recvcounts, displs, mpi_integer8, &
12081 root, comm%handle, ierr)
12082 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12083 CALL add_perf(perf_id=4, &
12084 count=1, &
12085 msg_size=sendcount*int_8_size)
12086#else
12087 mark_used(recvcounts)
12088 mark_used(root)
12089 mark_used(comm)
12090 recvbuf(:, 1 + displs(1):) = sendbuf
12091#endif
12092 CALL mp_timestop(handle)
12093 END SUBROUTINE mp_gatherv_lm2
12094
12095! **************************************************************************************************
12096!> \brief Gathers data from all processes to one.
12097!> \param[in] sendbuf Data to send to root
12098!> \param[out] recvbuf Received data (on root)
12099!> \param[in] recvcounts Sizes of data received from processes
12100!> \param[in] displs Offsets of data received from processes
12101!> \param[in] comm Message passing environment identifier
12102!> \par Data length
12103!> Data can have different lengths
12104!> \par Offsets
12105!> Offsets start at 0
12106!> \par MPI mapping
12107!> mpi_gather
12108! **************************************************************************************************
12109 SUBROUTINE mp_gatherv_lm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
12110
12111 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
12112 INTEGER(KIND=int_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
12113 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12114 CLASS(mp_comm_type), INTENT(IN) :: comm
12115
12116 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_lm2_src'
12117
12118 INTEGER :: handle
12119#if defined(__parallel)
12120 INTEGER :: ierr, sendcount
12121#endif
12122
12123 CALL mp_timeset(routinen, handle)
12124
12125#if defined(__parallel)
12126 sendcount = SIZE(sendbuf)
12127 CALL mpi_gatherv(sendbuf, sendcount, mpi_integer8, &
12128 recvbuf, recvcounts, displs, mpi_integer8, &
12129 comm%source, comm%handle, ierr)
12130 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12131 CALL add_perf(perf_id=4, &
12132 count=1, &
12133 msg_size=sendcount*int_8_size)
12134#else
12135 mark_used(recvcounts)
12136 mark_used(comm)
12137 recvbuf(:, 1 + displs(1):) = sendbuf
12138#endif
12139 CALL mp_timestop(handle)
12140 END SUBROUTINE mp_gatherv_lm2_src
12141
12142! **************************************************************************************************
12143!> \brief Gathers data from all processes to one.
12144!> \param[in] sendbuf Data to send to root
12145!> \param[out] recvbuf Received data (on root)
12146!> \param[in] recvcounts Sizes of data received from processes
12147!> \param[in] displs Offsets of data received from processes
12148!> \param[in] root Process which gathers the data
12149!> \param[in] comm Message passing environment identifier
12150!> \par Data length
12151!> Data can have different lengths
12152!> \par Offsets
12153!> Offsets start at 0
12154!> \par MPI mapping
12155!> mpi_gather
12156! **************************************************************************************************
12157 SUBROUTINE mp_igatherv_lv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
12158 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: sendbuf
12159 INTEGER(KIND=int_8), DIMENSION(:), INTENT(OUT) :: recvbuf
12160 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
12161 INTEGER, INTENT(IN) :: sendcount, root
12162 CLASS(mp_comm_type), INTENT(IN) :: comm
12163 TYPE(mp_request_type), INTENT(OUT) :: request
12164
12165 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_lv'
12166
12167 INTEGER :: handle
12168#if defined(__parallel)
12169 INTEGER :: ierr
12170#endif
12171
12172 CALL mp_timeset(routinen, handle)
12173
12174#if defined(__parallel)
12175#if !defined(__GNUC__) || __GNUC__ >= 9
12176 cpassert(is_contiguous(sendbuf))
12177 cpassert(is_contiguous(recvbuf))
12178 cpassert(is_contiguous(recvcounts))
12179 cpassert(is_contiguous(displs))
12180#endif
12181 CALL mpi_igatherv(sendbuf, sendcount, mpi_integer8, &
12182 recvbuf, recvcounts, displs, mpi_integer8, &
12183 root, comm%handle, request%handle, ierr)
12184 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
12185 CALL add_perf(perf_id=24, &
12186 count=1, &
12187 msg_size=sendcount*int_8_size)
12188#else
12189 mark_used(sendcount)
12190 mark_used(recvcounts)
12191 mark_used(root)
12192 mark_used(comm)
12193 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
12194 request = mp_request_null
12195#endif
12196 CALL mp_timestop(handle)
12197 END SUBROUTINE mp_igatherv_lv
12198
12199! **************************************************************************************************
12200!> \brief Gathers a datum from all processes and all processes receive the
12201!> same data
12202!> \param[in] msgout Datum to send
12203!> \param[out] msgin Received data
12204!> \param[in] comm Message passing environment identifier
12205!> \par Data size
12206!> All processes send equal-sized data
12207!> \par MPI mapping
12208!> mpi_allgather
12209! **************************************************************************************************
12210 SUBROUTINE mp_allgather_l (msgout, msgin, comm)
12211 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12212 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
12213 CLASS(mp_comm_type), INTENT(IN) :: comm
12214
12215 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l'
12216
12217 INTEGER :: handle
12218#if defined(__parallel)
12219 INTEGER :: ierr, rcount, scount
12220#endif
12221
12222 CALL mp_timeset(routinen, handle)
12223
12224#if defined(__parallel)
12225 scount = 1
12226 rcount = 1
12227 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12228 msgin, rcount, mpi_integer8, &
12229 comm%handle, ierr)
12230 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12231#else
12232 mark_used(comm)
12233 msgin = msgout
12234#endif
12235 CALL mp_timestop(handle)
12236 END SUBROUTINE mp_allgather_l
12237
12238! **************************************************************************************************
12239!> \brief Gathers a datum from all processes and all processes receive the
12240!> same data
12241!> \param[in] msgout Datum to send
12242!> \param[out] msgin Received data
12243!> \param[in] comm Message passing environment identifier
12244!> \par Data size
12245!> All processes send equal-sized data
12246!> \par MPI mapping
12247!> mpi_allgather
12248! **************************************************************************************************
12249 SUBROUTINE mp_allgather_l2(msgout, msgin, comm)
12250 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12251 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12252 CLASS(mp_comm_type), INTENT(IN) :: comm
12253
12254 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l2'
12255
12256 INTEGER :: handle
12257#if defined(__parallel)
12258 INTEGER :: ierr, rcount, scount
12259#endif
12260
12261 CALL mp_timeset(routinen, handle)
12262
12263#if defined(__parallel)
12264 scount = 1
12265 rcount = 1
12266 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12267 msgin, rcount, mpi_integer8, &
12268 comm%handle, ierr)
12269 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12270#else
12271 mark_used(comm)
12272 msgin = msgout
12273#endif
12274 CALL mp_timestop(handle)
12275 END SUBROUTINE mp_allgather_l2
12276
12277! **************************************************************************************************
12278!> \brief Gathers a datum from all processes and all processes receive the
12279!> same data
12280!> \param[in] msgout Datum to send
12281!> \param[out] msgin Received data
12282!> \param[in] comm Message passing environment identifier
12283!> \par Data size
12284!> All processes send equal-sized data
12285!> \par MPI mapping
12286!> mpi_allgather
12287! **************************************************************************************************
12288 SUBROUTINE mp_iallgather_l (msgout, msgin, comm, request)
12289 INTEGER(KIND=int_8), INTENT(IN) :: msgout
12290 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12291 CLASS(mp_comm_type), INTENT(IN) :: comm
12292 TYPE(mp_request_type), INTENT(OUT) :: request
12293
12294 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l'
12295
12296 INTEGER :: handle
12297#if defined(__parallel)
12298 INTEGER :: ierr, rcount, scount
12299#endif
12300
12301 CALL mp_timeset(routinen, handle)
12302
12303#if defined(__parallel)
12304#if !defined(__GNUC__) || __GNUC__ >= 9
12305 cpassert(is_contiguous(msgin))
12306#endif
12307 scount = 1
12308 rcount = 1
12309 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12310 msgin, rcount, mpi_integer8, &
12311 comm%handle, request%handle, ierr)
12312 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12313#else
12314 mark_used(comm)
12315 msgin = msgout
12316 request = mp_request_null
12317#endif
12318 CALL mp_timestop(handle)
12319 END SUBROUTINE mp_iallgather_l
12320
12321! **************************************************************************************************
12322!> \brief Gathers vector data from all processes and all processes receive the
12323!> same data
12324!> \param[in] msgout Rank-1 data to send
12325!> \param[out] msgin Received data
12326!> \param[in] comm Message passing environment identifier
12327!> \par Data size
12328!> All processes send equal-sized data
12329!> \par Ranks
12330!> The last rank counts the processes
12331!> \par MPI mapping
12332!> mpi_allgather
12333! **************************************************************************************************
12334 SUBROUTINE mp_allgather_l12(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_l12'
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_l12
12361
12362! **************************************************************************************************
12363!> \brief Gathers matrix data from all processes and all processes receive the
12364!> same data
12365!> \param[in] msgout Rank-2 data to send
12366!> \param msgin ...
12367!> \param comm ...
12368!> \note see mp_allgather_l12
12369! **************************************************************************************************
12370 SUBROUTINE mp_allgather_l23(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_l23'
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_l23
12397
12398! **************************************************************************************************
12399!> \brief Gathers rank-3 data from all processes and all processes receive the
12400!> same data
12401!> \param[in] msgout Rank-3 data to send
12402!> \param msgin ...
12403!> \param comm ...
12404!> \note see mp_allgather_l12
12405! **************************************************************************************************
12406 SUBROUTINE mp_allgather_l34(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_l34'
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(:, :, :, 1) = msgout(:, :, :)
12430#endif
12431 CALL mp_timestop(handle)
12432 END SUBROUTINE mp_allgather_l34
12433
12434! **************************************************************************************************
12435!> \brief Gathers rank-2 data from all processes and all processes receive the
12436!> same data
12437!> \param[in] msgout Rank-2 data to send
12438!> \param msgin ...
12439!> \param comm ...
12440!> \note see mp_allgather_l12
12441! **************************************************************************************************
12442 SUBROUTINE mp_allgather_l22(msgout, msgin, comm)
12443 INTEGER(KIND=int_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
12444 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
12445 CLASS(mp_comm_type), INTENT(IN) :: comm
12446
12447 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_l22'
12448
12449 INTEGER :: handle
12450#if defined(__parallel)
12451 INTEGER :: ierr, rcount, scount
12452#endif
12453
12454 CALL mp_timeset(routinen, handle)
12455
12456#if defined(__parallel)
12457 scount = SIZE(msgout(:, :))
12458 rcount = scount
12459 CALL mpi_allgather(msgout, scount, mpi_integer8, &
12460 msgin, rcount, mpi_integer8, &
12461 comm%handle, ierr)
12462 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
12463#else
12464 mark_used(comm)
12465 msgin(:, :) = msgout(:, :)
12466#endif
12467 CALL mp_timestop(handle)
12468 END SUBROUTINE mp_allgather_l22
12469
12470! **************************************************************************************************
12471!> \brief Gathers rank-1 data from all processes and all processes receive the
12472!> same data
12473!> \param[in] msgout Rank-1 data to send
12474!> \param msgin ...
12475!> \param comm ...
12476!> \param request ...
12477!> \note see mp_allgather_l11
12478! **************************************************************************************************
12479 SUBROUTINE mp_iallgather_l11(msgout, msgin, comm, request)
12480 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12481 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12482 CLASS(mp_comm_type), INTENT(IN) :: comm
12483 TYPE(mp_request_type), INTENT(OUT) :: request
12484
12485 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l11'
12486
12487 INTEGER :: handle
12488#if defined(__parallel)
12489 INTEGER :: ierr, rcount, scount
12490#endif
12491
12492 CALL mp_timeset(routinen, handle)
12493
12494#if defined(__parallel)
12495#if !defined(__GNUC__) || __GNUC__ >= 9
12496 cpassert(is_contiguous(msgout))
12497 cpassert(is_contiguous(msgin))
12498#endif
12499 scount = SIZE(msgout(:))
12500 rcount = scount
12501 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12502 msgin, rcount, mpi_integer8, &
12503 comm%handle, request%handle, ierr)
12504 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12505#else
12506 mark_used(comm)
12507 msgin = msgout
12508 request = mp_request_null
12509#endif
12510 CALL mp_timestop(handle)
12511 END SUBROUTINE mp_iallgather_l11
12512
12513! **************************************************************************************************
12514!> \brief Gathers rank-2 data from all processes and all processes receive the
12515!> same data
12516!> \param[in] msgout Rank-2 data to send
12517!> \param msgin ...
12518!> \param comm ...
12519!> \param request ...
12520!> \note see mp_allgather_l12
12521! **************************************************************************************************
12522 SUBROUTINE mp_iallgather_l13(msgout, msgin, comm, request)
12523 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12524 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :)
12525 CLASS(mp_comm_type), INTENT(IN) :: comm
12526 TYPE(mp_request_type), INTENT(OUT) :: request
12527
12528 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l13'
12529
12530 INTEGER :: handle
12531#if defined(__parallel)
12532 INTEGER :: ierr, rcount, scount
12533#endif
12534
12535 CALL mp_timeset(routinen, handle)
12536
12537#if defined(__parallel)
12538#if !defined(__GNUC__) || __GNUC__ >= 9
12539 cpassert(is_contiguous(msgout))
12540 cpassert(is_contiguous(msgin))
12541#endif
12542
12543 scount = SIZE(msgout(:))
12544 rcount = scount
12545 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12546 msgin, rcount, mpi_integer8, &
12547 comm%handle, request%handle, ierr)
12548 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12549#else
12550 mark_used(comm)
12551 msgin(:, 1, 1) = msgout(:)
12552 request = mp_request_null
12553#endif
12554 CALL mp_timestop(handle)
12555 END SUBROUTINE mp_iallgather_l13
12556
12557! **************************************************************************************************
12558!> \brief Gathers rank-2 data from all processes and all processes receive the
12559!> same data
12560!> \param[in] msgout Rank-2 data to send
12561!> \param msgin ...
12562!> \param comm ...
12563!> \param request ...
12564!> \note see mp_allgather_l12
12565! **************************************************************************************************
12566 SUBROUTINE mp_iallgather_l22(msgout, msgin, comm, request)
12567 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :)
12568 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :)
12569 CLASS(mp_comm_type), INTENT(IN) :: comm
12570 TYPE(mp_request_type), INTENT(OUT) :: request
12571
12572 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l22'
12573
12574 INTEGER :: handle
12575#if defined(__parallel)
12576 INTEGER :: ierr, rcount, scount
12577#endif
12578
12579 CALL mp_timeset(routinen, handle)
12580
12581#if defined(__parallel)
12582#if !defined(__GNUC__) || __GNUC__ >= 9
12583 cpassert(is_contiguous(msgout))
12584 cpassert(is_contiguous(msgin))
12585#endif
12586
12587 scount = SIZE(msgout(:, :))
12588 rcount = scount
12589 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12590 msgin, rcount, mpi_integer8, &
12591 comm%handle, request%handle, ierr)
12592 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12593#else
12594 mark_used(comm)
12595 msgin(:, :) = msgout(:, :)
12596 request = mp_request_null
12597#endif
12598 CALL mp_timestop(handle)
12599 END SUBROUTINE mp_iallgather_l22
12600
12601! **************************************************************************************************
12602!> \brief Gathers rank-2 data from all processes and all processes receive the
12603!> same data
12604!> \param[in] msgout Rank-2 data to send
12605!> \param msgin ...
12606!> \param comm ...
12607!> \param request ...
12608!> \note see mp_allgather_l12
12609! **************************************************************************************************
12610 SUBROUTINE mp_iallgather_l24(msgout, msgin, comm, request)
12611 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :)
12612 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :, :)
12613 CLASS(mp_comm_type), INTENT(IN) :: comm
12614 TYPE(mp_request_type), INTENT(OUT) :: request
12615
12616 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l24'
12617
12618 INTEGER :: handle
12619#if defined(__parallel)
12620 INTEGER :: ierr, rcount, scount
12621#endif
12622
12623 CALL mp_timeset(routinen, handle)
12624
12625#if defined(__parallel)
12626#if !defined(__GNUC__) || __GNUC__ >= 9
12627 cpassert(is_contiguous(msgout))
12628 cpassert(is_contiguous(msgin))
12629#endif
12630
12631 scount = SIZE(msgout(:, :))
12632 rcount = scount
12633 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12634 msgin, rcount, mpi_integer8, &
12635 comm%handle, request%handle, ierr)
12636 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12637#else
12638 mark_used(comm)
12639 msgin(:, :, 1, 1) = msgout(:, :)
12640 request = mp_request_null
12641#endif
12642 CALL mp_timestop(handle)
12643 END SUBROUTINE mp_iallgather_l24
12644
12645! **************************************************************************************************
12646!> \brief Gathers rank-3 data from all processes and all processes receive the
12647!> same data
12648!> \param[in] msgout Rank-3 data to send
12649!> \param msgin ...
12650!> \param comm ...
12651!> \param request ...
12652!> \note see mp_allgather_l12
12653! **************************************************************************************************
12654 SUBROUTINE mp_iallgather_l33(msgout, msgin, comm, request)
12655 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:, :, :)
12656 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:, :, :)
12657 CLASS(mp_comm_type), INTENT(IN) :: comm
12658 TYPE(mp_request_type), INTENT(OUT) :: request
12659
12660 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_l33'
12661
12662 INTEGER :: handle
12663#if defined(__parallel)
12664 INTEGER :: ierr, rcount, scount
12665#endif
12666
12667 CALL mp_timeset(routinen, handle)
12668
12669#if defined(__parallel)
12670#if !defined(__GNUC__) || __GNUC__ >= 9
12671 cpassert(is_contiguous(msgout))
12672 cpassert(is_contiguous(msgin))
12673#endif
12674
12675 scount = SIZE(msgout(:, :, :))
12676 rcount = scount
12677 CALL mpi_iallgather(msgout, scount, mpi_integer8, &
12678 msgin, rcount, mpi_integer8, &
12679 comm%handle, request%handle, ierr)
12680 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
12681#else
12682 mark_used(comm)
12683 msgin(:, :, :) = msgout(:, :, :)
12684 request = mp_request_null
12685#endif
12686 CALL mp_timestop(handle)
12687 END SUBROUTINE mp_iallgather_l33
12688
12689! **************************************************************************************************
12690!> \brief Gathers vector data from all processes and all processes receive the
12691!> same data
12692!> \param[in] msgout Rank-1 data to send
12693!> \param[out] msgin Received data
12694!> \param[in] rcount Size of sent data for every process
12695!> \param[in] rdispl Offset of sent data for every process
12696!> \param[in] comm Message passing environment identifier
12697!> \par Data size
12698!> Processes can send different-sized data
12699!> \par Ranks
12700!> The last rank counts the processes
12701!> \par Offsets
12702!> Offsets are from 0
12703!> \par MPI mapping
12704!> mpi_allgather
12705! **************************************************************************************************
12706 SUBROUTINE mp_allgatherv_lv(msgout, msgin, rcount, rdispl, comm)
12707 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
12708 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12709 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12710 CLASS(mp_comm_type), INTENT(IN) :: comm
12711
12712 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_lv'
12713
12714 INTEGER :: handle
12715#if defined(__parallel)
12716 INTEGER :: ierr, scount
12717#endif
12718
12719 CALL mp_timeset(routinen, handle)
12720
12721#if defined(__parallel)
12722 scount = SIZE(msgout)
12723 CALL mpi_allgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12724 rdispl, mpi_integer8, comm%handle, ierr)
12725 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
12726#else
12727 mark_used(rcount)
12728 mark_used(rdispl)
12729 mark_used(comm)
12730 msgin = msgout
12731#endif
12732 CALL mp_timestop(handle)
12733 END SUBROUTINE mp_allgatherv_lv
12734
12735! **************************************************************************************************
12736!> \brief Gathers vector data from all processes and all processes receive the
12737!> same data
12738!> \param[in] msgout Rank-1 data to send
12739!> \param[out] msgin Received data
12740!> \param[in] rcount Size of sent data for every process
12741!> \param[in] rdispl Offset of sent data for every process
12742!> \param[in] comm Message passing environment identifier
12743!> \par Data size
12744!> Processes can send different-sized data
12745!> \par Ranks
12746!> The last rank counts the processes
12747!> \par Offsets
12748!> Offsets are from 0
12749!> \par MPI mapping
12750!> mpi_allgather
12751! **************************************************************************************************
12752 SUBROUTINE mp_allgatherv_lm2(msgout, msgin, rcount, rdispl, comm)
12753 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
12754 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
12755 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12756 CLASS(mp_comm_type), INTENT(IN) :: comm
12757
12758 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_lv'
12759
12760 INTEGER :: handle
12761#if defined(__parallel)
12762 INTEGER :: ierr, scount
12763#endif
12764
12765 CALL mp_timeset(routinen, handle)
12766
12767#if defined(__parallel)
12768 scount = SIZE(msgout)
12769 CALL mpi_allgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12770 rdispl, mpi_integer8, comm%handle, ierr)
12771 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
12772#else
12773 mark_used(rcount)
12774 mark_used(rdispl)
12775 mark_used(comm)
12776 msgin = msgout
12777#endif
12778 CALL mp_timestop(handle)
12779 END SUBROUTINE mp_allgatherv_lm2
12780
12781! **************************************************************************************************
12782!> \brief Gathers vector data from all processes and all processes receive the
12783!> same data
12784!> \param[in] msgout Rank-1 data to send
12785!> \param[out] msgin Received data
12786!> \param[in] rcount Size of sent data for every process
12787!> \param[in] rdispl Offset of sent data for every process
12788!> \param[in] comm Message passing environment identifier
12789!> \par Data size
12790!> Processes can send different-sized data
12791!> \par Ranks
12792!> The last rank counts the processes
12793!> \par Offsets
12794!> Offsets are from 0
12795!> \par MPI mapping
12796!> mpi_allgather
12797! **************************************************************************************************
12798 SUBROUTINE mp_iallgatherv_lv(msgout, msgin, rcount, rdispl, comm, request)
12799 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12800 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12801 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
12802 CLASS(mp_comm_type), INTENT(IN) :: comm
12803 TYPE(mp_request_type), INTENT(OUT) :: request
12804
12805 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_lv'
12806
12807 INTEGER :: handle
12808#if defined(__parallel)
12809 INTEGER :: ierr, scount, rsize
12810#endif
12811
12812 CALL mp_timeset(routinen, handle)
12813
12814#if defined(__parallel)
12815#if !defined(__GNUC__) || __GNUC__ >= 9
12816 cpassert(is_contiguous(msgout))
12817 cpassert(is_contiguous(msgin))
12818 cpassert(is_contiguous(rcount))
12819 cpassert(is_contiguous(rdispl))
12820#endif
12821
12822 scount = SIZE(msgout)
12823 rsize = SIZE(rcount)
12824 CALL mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, &
12825 rdispl, comm, request, ierr)
12826 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
12827#else
12828 mark_used(rcount)
12829 mark_used(rdispl)
12830 mark_used(comm)
12831 msgin = msgout
12832 request = mp_request_null
12833#endif
12834 CALL mp_timestop(handle)
12835 END SUBROUTINE mp_iallgatherv_lv
12836
12837! **************************************************************************************************
12838!> \brief Gathers vector data from all processes and all processes receive the
12839!> same data
12840!> \param[in] msgout Rank-1 data to send
12841!> \param[out] msgin Received data
12842!> \param[in] rcount Size of sent data for every process
12843!> \param[in] rdispl Offset of sent data for every process
12844!> \param[in] comm Message passing environment identifier
12845!> \par Data size
12846!> Processes can send different-sized data
12847!> \par Ranks
12848!> The last rank counts the processes
12849!> \par Offsets
12850!> Offsets are from 0
12851!> \par MPI mapping
12852!> mpi_allgather
12853! **************************************************************************************************
12854 SUBROUTINE mp_iallgatherv_lv2(msgout, msgin, rcount, rdispl, comm, request)
12855 INTEGER(KIND=int_8), INTENT(IN) :: msgout(:)
12856 INTEGER(KIND=int_8), INTENT(OUT) :: msgin(:)
12857 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
12858 CLASS(mp_comm_type), INTENT(IN) :: comm
12859 TYPE(mp_request_type), INTENT(OUT) :: request
12860
12861 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_lv2'
12862
12863 INTEGER :: handle
12864#if defined(__parallel)
12865 INTEGER :: ierr, scount, rsize
12866#endif
12867
12868 CALL mp_timeset(routinen, handle)
12869
12870#if defined(__parallel)
12871#if !defined(__GNUC__) || __GNUC__ >= 9
12872 cpassert(is_contiguous(msgout))
12873 cpassert(is_contiguous(msgin))
12874 cpassert(is_contiguous(rcount))
12875 cpassert(is_contiguous(rdispl))
12876#endif
12877
12878 scount = SIZE(msgout)
12879 rsize = SIZE(rcount)
12880 CALL mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, &
12881 rdispl, comm, request, ierr)
12882 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
12883#else
12884 mark_used(rcount)
12885 mark_used(rdispl)
12886 mark_used(comm)
12887 msgin = msgout
12888 request = mp_request_null
12889#endif
12890 CALL mp_timestop(handle)
12891 END SUBROUTINE mp_iallgatherv_lv2
12892
12893! **************************************************************************************************
12894!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
12895!> the issue is with the rank of rcount and rdispl
12896!> \param count ...
12897!> \param array_of_requests ...
12898!> \param array_of_statuses ...
12899!> \param ierr ...
12900!> \author Alfio Lazzaro
12901! **************************************************************************************************
12902#if defined(__parallel)
12903 SUBROUTINE mp_iallgatherv_lv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
12904 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
12905 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12906 INTEGER, INTENT(IN) :: rsize
12907 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
12908 CLASS(mp_comm_type), INTENT(IN) :: comm
12909 TYPE(mp_request_type), INTENT(OUT) :: request
12910 INTEGER, INTENT(INOUT) :: ierr
12911
12912 CALL mpi_iallgatherv(msgout, scount, mpi_integer8, msgin, rcount, &
12913 rdispl, mpi_integer8, comm%handle, request%handle, ierr)
12914
12915 END SUBROUTINE mp_iallgatherv_lv_internal
12916#endif
12917
12918! **************************************************************************************************
12919!> \brief Sums a vector and partitions the result among processes
12920!> \param[in] msgout Data to sum
12921!> \param[out] msgin Received portion of summed data
12922!> \param[in] rcount Partition sizes of the summed data for
12923!> every process
12924!> \param[in] comm Message passing environment identifier
12925! **************************************************************************************************
12926 SUBROUTINE mp_sum_scatter_lv(msgout, msgin, rcount, comm)
12927 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
12928 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
12929 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
12930 CLASS(mp_comm_type), INTENT(IN) :: comm
12931
12932 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_lv'
12933
12934 INTEGER :: handle
12935#if defined(__parallel)
12936 INTEGER :: ierr
12937#endif
12938
12939 CALL mp_timeset(routinen, handle)
12940
12941#if defined(__parallel)
12942 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_integer8, mpi_sum, &
12943 comm%handle, ierr)
12944 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
12945
12946 CALL add_perf(perf_id=3, count=1, &
12947 msg_size=rcount(1)*2*int_8_size)
12948#else
12949 mark_used(rcount)
12950 mark_used(comm)
12951 msgin = msgout(:, 1)
12952#endif
12953 CALL mp_timestop(handle)
12954 END SUBROUTINE mp_sum_scatter_lv
12955
12956! **************************************************************************************************
12957!> \brief Sends and receives vector data
12958!> \param[in] msgin Data to send
12959!> \param[in] dest Process to send data to
12960!> \param[out] msgout Received data
12961!> \param[in] source Process from which to receive
12962!> \param[in] comm Message passing environment identifier
12963!> \param[in] tag Send and recv tag (default: 0)
12964! **************************************************************************************************
12965 SUBROUTINE mp_sendrecv_l (msgin, dest, msgout, source, comm, tag)
12966 INTEGER(KIND=int_8), INTENT(IN) :: msgin
12967 INTEGER, INTENT(IN) :: dest
12968 INTEGER(KIND=int_8), INTENT(OUT) :: msgout
12969 INTEGER, INTENT(IN) :: source
12970 CLASS(mp_comm_type), INTENT(IN) :: comm
12971 INTEGER, INTENT(IN), OPTIONAL :: tag
12972
12973 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_l'
12974
12975 INTEGER :: handle
12976#if defined(__parallel)
12977 INTEGER :: ierr, msglen_in, msglen_out, &
12978 recv_tag, send_tag
12979#endif
12980
12981 CALL mp_timeset(routinen, handle)
12982
12983#if defined(__parallel)
12984 msglen_in = 1
12985 msglen_out = 1
12986 send_tag = 0 ! cannot think of something better here, this might be dangerous
12987 recv_tag = 0 ! cannot think of something better here, this might be dangerous
12988 IF (PRESENT(tag)) THEN
12989 send_tag = tag
12990 recv_tag = tag
12991 END IF
12992 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
12993 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
12994 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
12995 CALL add_perf(perf_id=7, count=1, &
12996 msg_size=(msglen_in + msglen_out)*int_8_size/2)
12997#else
12998 mark_used(dest)
12999 mark_used(source)
13000 mark_used(comm)
13001 mark_used(tag)
13002 msgout = msgin
13003#endif
13004 CALL mp_timestop(handle)
13005 END SUBROUTINE mp_sendrecv_l
13006
13007! **************************************************************************************************
13008!> \brief Sends and receives vector data
13009!> \param[in] msgin Data to send
13010!> \param[in] dest Process to send data to
13011!> \param[out] msgout Received data
13012!> \param[in] source Process from which to receive
13013!> \param[in] comm Message passing environment identifier
13014!> \param[in] tag Send and recv tag (default: 0)
13015! **************************************************************************************************
13016 SUBROUTINE mp_sendrecv_lv(msgin, dest, msgout, source, comm, tag)
13017 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
13018 INTEGER, INTENT(IN) :: dest
13019 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
13020 INTEGER, INTENT(IN) :: source
13021 CLASS(mp_comm_type), INTENT(IN) :: comm
13022 INTEGER, INTENT(IN), OPTIONAL :: tag
13023
13024 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lv'
13025
13026 INTEGER :: handle
13027#if defined(__parallel)
13028 INTEGER :: ierr, msglen_in, msglen_out, &
13029 recv_tag, send_tag
13030#endif
13031
13032 CALL mp_timeset(routinen, handle)
13033
13034#if defined(__parallel)
13035 msglen_in = SIZE(msgin)
13036 msglen_out = SIZE(msgout)
13037 send_tag = 0 ! cannot think of something better here, this might be dangerous
13038 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13039 IF (PRESENT(tag)) THEN
13040 send_tag = tag
13041 recv_tag = tag
13042 END IF
13043 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13044 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13045 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13046 CALL add_perf(perf_id=7, count=1, &
13047 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13048#else
13049 mark_used(dest)
13050 mark_used(source)
13051 mark_used(comm)
13052 mark_used(tag)
13053 msgout = msgin
13054#endif
13055 CALL mp_timestop(handle)
13056 END SUBROUTINE mp_sendrecv_lv
13057
13058! **************************************************************************************************
13059!> \brief Sends and receives matrix data
13060!> \param msgin ...
13061!> \param dest ...
13062!> \param msgout ...
13063!> \param source ...
13064!> \param comm ...
13065!> \param tag ...
13066!> \note see mp_sendrecv_lv
13067! **************************************************************************************************
13068 SUBROUTINE mp_sendrecv_lm2(msgin, dest, msgout, source, comm, tag)
13069 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
13070 INTEGER, INTENT(IN) :: dest
13071 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
13072 INTEGER, INTENT(IN) :: source
13073 CLASS(mp_comm_type), INTENT(IN) :: comm
13074 INTEGER, INTENT(IN), OPTIONAL :: tag
13075
13076 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm2'
13077
13078 INTEGER :: handle
13079#if defined(__parallel)
13080 INTEGER :: ierr, msglen_in, msglen_out, &
13081 recv_tag, send_tag
13082#endif
13083
13084 CALL mp_timeset(routinen, handle)
13085
13086#if defined(__parallel)
13087 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
13088 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
13089 send_tag = 0 ! cannot think of something better here, this might be dangerous
13090 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13091 IF (PRESENT(tag)) THEN
13092 send_tag = tag
13093 recv_tag = tag
13094 END IF
13095 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13096 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13097 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13098 CALL add_perf(perf_id=7, count=1, &
13099 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13100#else
13101 mark_used(dest)
13102 mark_used(source)
13103 mark_used(comm)
13104 mark_used(tag)
13105 msgout = msgin
13106#endif
13107 CALL mp_timestop(handle)
13108 END SUBROUTINE mp_sendrecv_lm2
13109
13110! **************************************************************************************************
13111!> \brief Sends and receives rank-3 data
13112!> \param msgin ...
13113!> \param dest ...
13114!> \param msgout ...
13115!> \param source ...
13116!> \param comm ...
13117!> \note see mp_sendrecv_lv
13118! **************************************************************************************************
13119 SUBROUTINE mp_sendrecv_lm3(msgin, dest, msgout, source, comm, tag)
13120 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
13121 INTEGER, INTENT(IN) :: dest
13122 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
13123 INTEGER, INTENT(IN) :: source
13124 CLASS(mp_comm_type), INTENT(IN) :: comm
13125 INTEGER, INTENT(IN), OPTIONAL :: tag
13126
13127 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm3'
13128
13129 INTEGER :: handle
13130#if defined(__parallel)
13131 INTEGER :: ierr, msglen_in, msglen_out, &
13132 recv_tag, send_tag
13133#endif
13134
13135 CALL mp_timeset(routinen, handle)
13136
13137#if defined(__parallel)
13138 msglen_in = SIZE(msgin)
13139 msglen_out = SIZE(msgout)
13140 send_tag = 0 ! cannot think of something better here, this might be dangerous
13141 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13142 IF (PRESENT(tag)) THEN
13143 send_tag = tag
13144 recv_tag = tag
13145 END IF
13146 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13147 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13148 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13149 CALL add_perf(perf_id=7, count=1, &
13150 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13151#else
13152 mark_used(dest)
13153 mark_used(source)
13154 mark_used(comm)
13155 mark_used(tag)
13156 msgout = msgin
13157#endif
13158 CALL mp_timestop(handle)
13159 END SUBROUTINE mp_sendrecv_lm3
13160
13161! **************************************************************************************************
13162!> \brief Sends and receives rank-4 data
13163!> \param msgin ...
13164!> \param dest ...
13165!> \param msgout ...
13166!> \param source ...
13167!> \param comm ...
13168!> \note see mp_sendrecv_lv
13169! **************************************************************************************************
13170 SUBROUTINE mp_sendrecv_lm4(msgin, dest, msgout, source, comm, tag)
13171 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
13172 INTEGER, INTENT(IN) :: dest
13173 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
13174 INTEGER, INTENT(IN) :: source
13175 CLASS(mp_comm_type), INTENT(IN) :: comm
13176 INTEGER, INTENT(IN), OPTIONAL :: tag
13177
13178 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_lm4'
13179
13180 INTEGER :: handle
13181#if defined(__parallel)
13182 INTEGER :: ierr, msglen_in, msglen_out, &
13183 recv_tag, send_tag
13184#endif
13185
13186 CALL mp_timeset(routinen, handle)
13187
13188#if defined(__parallel)
13189 msglen_in = SIZE(msgin)
13190 msglen_out = SIZE(msgout)
13191 send_tag = 0 ! cannot think of something better here, this might be dangerous
13192 recv_tag = 0 ! cannot think of something better here, this might be dangerous
13193 IF (PRESENT(tag)) THEN
13194 send_tag = tag
13195 recv_tag = tag
13196 END IF
13197 CALL mpi_sendrecv(msgin, msglen_in, mpi_integer8, dest, send_tag, msgout, &
13198 msglen_out, mpi_integer8, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
13199 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
13200 CALL add_perf(perf_id=7, count=1, &
13201 msg_size=(msglen_in + msglen_out)*int_8_size/2)
13202#else
13203 mark_used(dest)
13204 mark_used(source)
13205 mark_used(comm)
13206 mark_used(tag)
13207 msgout = msgin
13208#endif
13209 CALL mp_timestop(handle)
13210 END SUBROUTINE mp_sendrecv_lm4
13211
13212! **************************************************************************************************
13213!> \brief Non-blocking send and receive of a scalar
13214!> \param[in] msgin Scalar data to send
13215!> \param[in] dest Which process to send to
13216!> \param[out] msgout Receive data into this pointer
13217!> \param[in] source Process to receive from
13218!> \param[in] comm Message passing environment identifier
13219!> \param[out] send_request Request handle for the send
13220!> \param[out] recv_request Request handle for the receive
13221!> \param[in] tag (optional) tag to differentiate requests
13222!> \par Implementation
13223!> Calls mpi_isend and mpi_irecv.
13224!> \par History
13225!> 02.2005 created [Alfio Lazzaro]
13226! **************************************************************************************************
13227 SUBROUTINE mp_isendrecv_l (msgin, dest, msgout, source, comm, send_request, &
13228 recv_request, tag)
13229 INTEGER(KIND=int_8), INTENT(IN) :: msgin
13230 INTEGER, INTENT(IN) :: dest
13231 INTEGER(KIND=int_8), INTENT(INOUT) :: msgout
13232 INTEGER, INTENT(IN) :: source
13233 CLASS(mp_comm_type), INTENT(IN) :: comm
13234 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
13235 INTEGER, INTENT(in), OPTIONAL :: tag
13236
13237 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_l'
13238
13239 INTEGER :: handle
13240#if defined(__parallel)
13241 INTEGER :: ierr, my_tag
13242#endif
13243
13244 CALL mp_timeset(routinen, handle)
13245
13246#if defined(__parallel)
13247 my_tag = 0
13248 IF (PRESENT(tag)) my_tag = tag
13249
13250 CALL mpi_irecv(msgout, 1, mpi_integer8, source, my_tag, &
13251 comm%handle, recv_request%handle, ierr)
13252 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13253
13254 CALL mpi_isend(msgin, 1, mpi_integer8, dest, my_tag, &
13255 comm%handle, send_request%handle, ierr)
13256 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13257
13258 CALL add_perf(perf_id=8, count=1, msg_size=2*int_8_size)
13259#else
13260 mark_used(dest)
13261 mark_used(source)
13262 mark_used(comm)
13263 mark_used(tag)
13264 send_request = mp_request_null
13265 recv_request = mp_request_null
13266 msgout = msgin
13267#endif
13268 CALL mp_timestop(handle)
13269 END SUBROUTINE mp_isendrecv_l
13270
13271! **************************************************************************************************
13272!> \brief Non-blocking send and receive of a vector
13273!> \param[in] msgin Vector data to send
13274!> \param[in] dest Which process to send to
13275!> \param[out] msgout Receive data into this pointer
13276!> \param[in] source Process to receive from
13277!> \param[in] comm Message passing environment identifier
13278!> \param[out] send_request Request handle for the send
13279!> \param[out] recv_request Request handle for the receive
13280!> \param[in] tag (optional) tag to differentiate requests
13281!> \par Implementation
13282!> Calls mpi_isend and mpi_irecv.
13283!> \par History
13284!> 11.2004 created [Joost VandeVondele]
13285!> \note
13286!> arrays can be pointers or assumed shape, but they must be contiguous!
13287! **************************************************************************************************
13288 SUBROUTINE mp_isendrecv_lv(msgin, dest, msgout, source, comm, send_request, &
13289 recv_request, tag)
13290 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: msgin
13291 INTEGER, INTENT(IN) :: dest
13292 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT) :: msgout
13293 INTEGER, INTENT(IN) :: source
13294 CLASS(mp_comm_type), INTENT(IN) :: comm
13295 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
13296 INTEGER, INTENT(in), OPTIONAL :: tag
13297
13298 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_lv'
13299
13300 INTEGER :: handle
13301#if defined(__parallel)
13302 INTEGER :: ierr, msglen, my_tag
13303 INTEGER(KIND=int_8) :: foo
13304#endif
13305
13306 CALL mp_timeset(routinen, handle)
13307
13308#if defined(__parallel)
13309#if !defined(__GNUC__) || __GNUC__ >= 9
13310 cpassert(is_contiguous(msgout))
13311 cpassert(is_contiguous(msgin))
13312#endif
13313
13314 my_tag = 0
13315 IF (PRESENT(tag)) my_tag = tag
13316
13317 msglen = SIZE(msgout, 1)
13318 IF (msglen > 0) THEN
13319 CALL mpi_irecv(msgout(1), msglen, mpi_integer8, source, my_tag, &
13320 comm%handle, recv_request%handle, ierr)
13321 ELSE
13322 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13323 comm%handle, recv_request%handle, ierr)
13324 END IF
13325 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13326
13327 msglen = SIZE(msgin, 1)
13328 IF (msglen > 0) THEN
13329 CALL mpi_isend(msgin(1), msglen, mpi_integer8, dest, my_tag, &
13330 comm%handle, send_request%handle, ierr)
13331 ELSE
13332 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13333 comm%handle, send_request%handle, ierr)
13334 END IF
13335 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13336
13337 msglen = (msglen + SIZE(msgout, 1) + 1)/2
13338 CALL add_perf(perf_id=8, count=1, msg_size=msglen*int_8_size)
13339#else
13340 mark_used(dest)
13341 mark_used(source)
13342 mark_used(comm)
13343 mark_used(tag)
13344 send_request = mp_request_null
13345 recv_request = mp_request_null
13346 msgout = msgin
13347#endif
13348 CALL mp_timestop(handle)
13349 END SUBROUTINE mp_isendrecv_lv
13350
13351! **************************************************************************************************
13352!> \brief Non-blocking send of vector data
13353!> \param msgin ...
13354!> \param dest ...
13355!> \param comm ...
13356!> \param request ...
13357!> \param tag ...
13358!> \par History
13359!> 08.2003 created [f&j]
13360!> \note see mp_isendrecv_lv
13361!> \note
13362!> arrays can be pointers or assumed shape, but they must be contiguous!
13363! **************************************************************************************************
13364 SUBROUTINE mp_isend_lv(msgin, dest, comm, request, tag)
13365 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: msgin
13366 INTEGER, INTENT(IN) :: dest
13367 CLASS(mp_comm_type), INTENT(IN) :: comm
13368 TYPE(mp_request_type), INTENT(out) :: request
13369 INTEGER, INTENT(in), OPTIONAL :: tag
13370
13371 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lv'
13372
13373 INTEGER :: handle, ierr
13374#if defined(__parallel)
13375 INTEGER :: msglen, my_tag
13376 INTEGER(KIND=int_8) :: foo(1)
13377#endif
13378
13379 CALL mp_timeset(routinen, handle)
13380
13381#if defined(__parallel)
13382#if !defined(__GNUC__) || __GNUC__ >= 9
13383 cpassert(is_contiguous(msgin))
13384#endif
13385 my_tag = 0
13386 IF (PRESENT(tag)) my_tag = tag
13387
13388 msglen = SIZE(msgin)
13389 IF (msglen > 0) THEN
13390 CALL mpi_isend(msgin(1), msglen, mpi_integer8, dest, my_tag, &
13391 comm%handle, request%handle, ierr)
13392 ELSE
13393 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13394 comm%handle, request%handle, ierr)
13395 END IF
13396 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13397
13398 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13399#else
13400 mark_used(msgin)
13401 mark_used(dest)
13402 mark_used(comm)
13403 mark_used(request)
13404 mark_used(tag)
13405 ierr = 1
13406 request = mp_request_null
13407 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13408#endif
13409 CALL mp_timestop(handle)
13410 END SUBROUTINE mp_isend_lv
13411
13412! **************************************************************************************************
13413!> \brief Non-blocking send of matrix data
13414!> \param msgin ...
13415!> \param dest ...
13416!> \param comm ...
13417!> \param request ...
13418!> \param tag ...
13419!> \par History
13420!> 2009-11-25 [UB] Made type-generic for templates
13421!> \author fawzi
13422!> \note see mp_isendrecv_lv
13423!> \note see mp_isend_lv
13424!> \note
13425!> arrays can be pointers or assumed shape, but they must be contiguous!
13426! **************************************************************************************************
13427 SUBROUTINE mp_isend_lm2(msgin, dest, comm, request, tag)
13428 INTEGER(KIND=int_8), DIMENSION(:, :), INTENT(IN) :: msgin
13429 INTEGER, INTENT(IN) :: dest
13430 CLASS(mp_comm_type), INTENT(IN) :: comm
13431 TYPE(mp_request_type), INTENT(out) :: request
13432 INTEGER, INTENT(in), OPTIONAL :: tag
13433
13434 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm2'
13435
13436 INTEGER :: handle, ierr
13437#if defined(__parallel)
13438 INTEGER :: msglen, my_tag
13439 INTEGER(KIND=int_8) :: foo(1)
13440#endif
13441
13442 CALL mp_timeset(routinen, handle)
13443
13444#if defined(__parallel)
13445#if !defined(__GNUC__) || __GNUC__ >= 9
13446 cpassert(is_contiguous(msgin))
13447#endif
13448
13449 my_tag = 0
13450 IF (PRESENT(tag)) my_tag = tag
13451
13452 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
13453 IF (msglen > 0) THEN
13454 CALL mpi_isend(msgin(1, 1), msglen, mpi_integer8, dest, my_tag, &
13455 comm%handle, request%handle, ierr)
13456 ELSE
13457 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13458 comm%handle, request%handle, ierr)
13459 END IF
13460 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13461
13462 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13463#else
13464 mark_used(msgin)
13465 mark_used(dest)
13466 mark_used(comm)
13467 mark_used(request)
13468 mark_used(tag)
13469 ierr = 1
13470 request = mp_request_null
13471 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13472#endif
13473 CALL mp_timestop(handle)
13474 END SUBROUTINE mp_isend_lm2
13475
13476! **************************************************************************************************
13477!> \brief Non-blocking send of rank-3 data
13478!> \param msgin ...
13479!> \param dest ...
13480!> \param comm ...
13481!> \param request ...
13482!> \param tag ...
13483!> \par History
13484!> 9.2008 added _rm3 subroutine [Iain Bethune]
13485!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
13486!> 2009-11-25 [UB] Made type-generic for templates
13487!> \author fawzi
13488!> \note see mp_isendrecv_lv
13489!> \note see mp_isend_lv
13490!> \note
13491!> arrays can be pointers or assumed shape, but they must be contiguous!
13492! **************************************************************************************************
13493 SUBROUTINE mp_isend_lm3(msgin, dest, comm, request, tag)
13494 INTEGER(KIND=int_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
13495 INTEGER, INTENT(IN) :: dest
13496 CLASS(mp_comm_type), INTENT(IN) :: comm
13497 TYPE(mp_request_type), INTENT(out) :: request
13498 INTEGER, INTENT(in), OPTIONAL :: tag
13499
13500 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm3'
13501
13502 INTEGER :: handle, ierr
13503#if defined(__parallel)
13504 INTEGER :: msglen, my_tag
13505 INTEGER(KIND=int_8) :: foo(1)
13506#endif
13507
13508 CALL mp_timeset(routinen, handle)
13509
13510#if defined(__parallel)
13511#if !defined(__GNUC__) || __GNUC__ >= 9
13512 cpassert(is_contiguous(msgin))
13513#endif
13514
13515 my_tag = 0
13516 IF (PRESENT(tag)) my_tag = tag
13517
13518 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
13519 IF (msglen > 0) THEN
13520 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_integer8, dest, my_tag, &
13521 comm%handle, request%handle, ierr)
13522 ELSE
13523 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13524 comm%handle, request%handle, ierr)
13525 END IF
13526 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13527
13528 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13529#else
13530 mark_used(msgin)
13531 mark_used(dest)
13532 mark_used(comm)
13533 mark_used(request)
13534 mark_used(tag)
13535 ierr = 1
13536 request = mp_request_null
13537 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13538#endif
13539 CALL mp_timestop(handle)
13540 END SUBROUTINE mp_isend_lm3
13541
13542! **************************************************************************************************
13543!> \brief Non-blocking send of rank-4 data
13544!> \param msgin the input message
13545!> \param dest the destination processor
13546!> \param comm the communicator object
13547!> \param request the communication request id
13548!> \param tag the message tag
13549!> \par History
13550!> 2.2016 added _lm4 subroutine [Nico Holmberg]
13551!> \author fawzi
13552!> \note see mp_isend_lv
13553!> \note
13554!> arrays can be pointers or assumed shape, but they must be contiguous!
13555! **************************************************************************************************
13556 SUBROUTINE mp_isend_lm4(msgin, dest, comm, request, tag)
13557 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
13558 INTEGER, INTENT(IN) :: dest
13559 CLASS(mp_comm_type), INTENT(IN) :: comm
13560 TYPE(mp_request_type), INTENT(out) :: request
13561 INTEGER, INTENT(in), OPTIONAL :: tag
13562
13563 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_lm4'
13564
13565 INTEGER :: handle, ierr
13566#if defined(__parallel)
13567 INTEGER :: msglen, my_tag
13568 INTEGER(KIND=int_8) :: foo(1)
13569#endif
13570
13571 CALL mp_timeset(routinen, handle)
13572
13573#if defined(__parallel)
13574#if !defined(__GNUC__) || __GNUC__ >= 9
13575 cpassert(is_contiguous(msgin))
13576#endif
13577
13578 my_tag = 0
13579 IF (PRESENT(tag)) my_tag = tag
13580
13581 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
13582 IF (msglen > 0) THEN
13583 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_integer8, dest, my_tag, &
13584 comm%handle, request%handle, ierr)
13585 ELSE
13586 CALL mpi_isend(foo, msglen, mpi_integer8, dest, my_tag, &
13587 comm%handle, request%handle, ierr)
13588 END IF
13589 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
13590
13591 CALL add_perf(perf_id=11, count=1, msg_size=msglen*int_8_size)
13592#else
13593 mark_used(msgin)
13594 mark_used(dest)
13595 mark_used(comm)
13596 mark_used(request)
13597 mark_used(tag)
13598 ierr = 1
13599 request = mp_request_null
13600 CALL mp_stop(ierr, "mp_isend called in non parallel case")
13601#endif
13602 CALL mp_timestop(handle)
13603 END SUBROUTINE mp_isend_lm4
13604
13605! **************************************************************************************************
13606!> \brief Non-blocking receive of vector data
13607!> \param msgout ...
13608!> \param source ...
13609!> \param comm ...
13610!> \param request ...
13611!> \param tag ...
13612!> \par History
13613!> 08.2003 created [f&j]
13614!> 2009-11-25 [UB] Made type-generic for templates
13615!> \note see mp_isendrecv_lv
13616!> \note
13617!> arrays can be pointers or assumed shape, but they must be contiguous!
13618! **************************************************************************************************
13619 SUBROUTINE mp_irecv_lv(msgout, source, comm, request, tag)
13620 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT) :: msgout
13621 INTEGER, INTENT(IN) :: source
13622 CLASS(mp_comm_type), INTENT(IN) :: comm
13623 TYPE(mp_request_type), INTENT(out) :: request
13624 INTEGER, INTENT(in), OPTIONAL :: tag
13625
13626 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lv'
13627
13628 INTEGER :: handle
13629#if defined(__parallel)
13630 INTEGER :: ierr, msglen, my_tag
13631 INTEGER(KIND=int_8) :: foo(1)
13632#endif
13633
13634 CALL mp_timeset(routinen, handle)
13635
13636#if defined(__parallel)
13637#if !defined(__GNUC__) || __GNUC__ >= 9
13638 cpassert(is_contiguous(msgout))
13639#endif
13640
13641 my_tag = 0
13642 IF (PRESENT(tag)) my_tag = tag
13643
13644 msglen = SIZE(msgout)
13645 IF (msglen > 0) THEN
13646 CALL mpi_irecv(msgout(1), msglen, mpi_integer8, source, my_tag, &
13647 comm%handle, request%handle, ierr)
13648 ELSE
13649 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13650 comm%handle, request%handle, ierr)
13651 END IF
13652 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13653
13654 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13655#else
13656 cpabort("mp_irecv called in non parallel case")
13657 mark_used(msgout)
13658 mark_used(source)
13659 mark_used(comm)
13660 mark_used(tag)
13661 request = mp_request_null
13662#endif
13663 CALL mp_timestop(handle)
13664 END SUBROUTINE mp_irecv_lv
13665
13666! **************************************************************************************************
13667!> \brief Non-blocking receive of matrix data
13668!> \param msgout ...
13669!> \param source ...
13670!> \param comm ...
13671!> \param request ...
13672!> \param tag ...
13673!> \par History
13674!> 2009-11-25 [UB] Made type-generic for templates
13675!> \author fawzi
13676!> \note see mp_isendrecv_lv
13677!> \note see mp_irecv_lv
13678!> \note
13679!> arrays can be pointers or assumed shape, but they must be contiguous!
13680! **************************************************************************************************
13681 SUBROUTINE mp_irecv_lm2(msgout, source, comm, request, tag)
13682 INTEGER(KIND=int_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
13683 INTEGER, INTENT(IN) :: source
13684 CLASS(mp_comm_type), INTENT(IN) :: comm
13685 TYPE(mp_request_type), INTENT(out) :: request
13686 INTEGER, INTENT(in), OPTIONAL :: tag
13687
13688 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm2'
13689
13690 INTEGER :: handle
13691#if defined(__parallel)
13692 INTEGER :: ierr, msglen, my_tag
13693 INTEGER(KIND=int_8) :: foo(1)
13694#endif
13695
13696 CALL mp_timeset(routinen, handle)
13697
13698#if defined(__parallel)
13699#if !defined(__GNUC__) || __GNUC__ >= 9
13700 cpassert(is_contiguous(msgout))
13701#endif
13702
13703 my_tag = 0
13704 IF (PRESENT(tag)) my_tag = tag
13705
13706 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
13707 IF (msglen > 0) THEN
13708 CALL mpi_irecv(msgout(1, 1), msglen, mpi_integer8, source, my_tag, &
13709 comm%handle, request%handle, ierr)
13710 ELSE
13711 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13712 comm%handle, request%handle, ierr)
13713 END IF
13714 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
13715
13716 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13717#else
13718 mark_used(msgout)
13719 mark_used(source)
13720 mark_used(comm)
13721 mark_used(tag)
13722 request = mp_request_null
13723 cpabort("mp_irecv called in non parallel case")
13724#endif
13725 CALL mp_timestop(handle)
13726 END SUBROUTINE mp_irecv_lm2
13727
13728! **************************************************************************************************
13729!> \brief Non-blocking send of rank-3 data
13730!> \param msgout ...
13731!> \param source ...
13732!> \param comm ...
13733!> \param request ...
13734!> \param tag ...
13735!> \par History
13736!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
13737!> 2009-11-25 [UB] Made type-generic for templates
13738!> \author fawzi
13739!> \note see mp_isendrecv_lv
13740!> \note see mp_irecv_lv
13741!> \note
13742!> arrays can be pointers or assumed shape, but they must be contiguous!
13743! **************************************************************************************************
13744 SUBROUTINE mp_irecv_lm3(msgout, source, comm, request, tag)
13745 INTEGER(KIND=int_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
13746 INTEGER, INTENT(IN) :: source
13747 CLASS(mp_comm_type), INTENT(IN) :: comm
13748 TYPE(mp_request_type), INTENT(out) :: request
13749 INTEGER, INTENT(in), OPTIONAL :: tag
13750
13751 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm3'
13752
13753 INTEGER :: handle
13754#if defined(__parallel)
13755 INTEGER :: ierr, msglen, my_tag
13756 INTEGER(KIND=int_8) :: foo(1)
13757#endif
13758
13759 CALL mp_timeset(routinen, handle)
13760
13761#if defined(__parallel)
13762#if !defined(__GNUC__) || __GNUC__ >= 9
13763 cpassert(is_contiguous(msgout))
13764#endif
13765
13766 my_tag = 0
13767 IF (PRESENT(tag)) my_tag = tag
13768
13769 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
13770 IF (msglen > 0) THEN
13771 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_integer8, source, my_tag, &
13772 comm%handle, request%handle, ierr)
13773 ELSE
13774 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13775 comm%handle, request%handle, ierr)
13776 END IF
13777 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
13778
13779 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13780#else
13781 mark_used(msgout)
13782 mark_used(source)
13783 mark_used(comm)
13784 mark_used(tag)
13785 request = mp_request_null
13786 cpabort("mp_irecv called in non parallel case")
13787#endif
13788 CALL mp_timestop(handle)
13789 END SUBROUTINE mp_irecv_lm3
13790
13791! **************************************************************************************************
13792!> \brief Non-blocking receive of rank-4 data
13793!> \param msgout the output message
13794!> \param source the source processor
13795!> \param comm the communicator object
13796!> \param request the communication request id
13797!> \param tag the message tag
13798!> \par History
13799!> 2.2016 added _lm4 subroutine [Nico Holmberg]
13800!> \author fawzi
13801!> \note see mp_irecv_lv
13802!> \note
13803!> arrays can be pointers or assumed shape, but they must be contiguous!
13804! **************************************************************************************************
13805 SUBROUTINE mp_irecv_lm4(msgout, source, comm, request, tag)
13806 INTEGER(KIND=int_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
13807 INTEGER, INTENT(IN) :: source
13808 CLASS(mp_comm_type), INTENT(IN) :: comm
13809 TYPE(mp_request_type), INTENT(out) :: request
13810 INTEGER, INTENT(in), OPTIONAL :: tag
13811
13812 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_lm4'
13813
13814 INTEGER :: handle
13815#if defined(__parallel)
13816 INTEGER :: ierr, msglen, my_tag
13817 INTEGER(KIND=int_8) :: foo(1)
13818#endif
13819
13820 CALL mp_timeset(routinen, handle)
13821
13822#if defined(__parallel)
13823#if !defined(__GNUC__) || __GNUC__ >= 9
13824 cpassert(is_contiguous(msgout))
13825#endif
13826
13827 my_tag = 0
13828 IF (PRESENT(tag)) my_tag = tag
13829
13830 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
13831 IF (msglen > 0) THEN
13832 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_integer8, source, my_tag, &
13833 comm%handle, request%handle, ierr)
13834 ELSE
13835 CALL mpi_irecv(foo, msglen, mpi_integer8, source, my_tag, &
13836 comm%handle, request%handle, ierr)
13837 END IF
13838 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
13839
13840 CALL add_perf(perf_id=12, count=1, msg_size=msglen*int_8_size)
13841#else
13842 mark_used(msgout)
13843 mark_used(source)
13844 mark_used(comm)
13845 mark_used(tag)
13846 request = mp_request_null
13847 cpabort("mp_irecv called in non parallel case")
13848#endif
13849 CALL mp_timestop(handle)
13850 END SUBROUTINE mp_irecv_lm4
13851
13852! **************************************************************************************************
13853!> \brief Window initialization function for vector data
13854!> \param base ...
13855!> \param comm ...
13856!> \param win ...
13857!> \par History
13858!> 02.2015 created [Alfio Lazzaro]
13859!> \note
13860!> arrays can be pointers or assumed shape, but they must be contiguous!
13861! **************************************************************************************************
13862 SUBROUTINE mp_win_create_lv(base, comm, win)
13863 INTEGER(KIND=int_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
13864 TYPE(mp_comm_type), INTENT(IN) :: comm
13865 CLASS(mp_win_type), INTENT(INOUT) :: win
13866
13867 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_lv'
13868
13869 INTEGER :: handle
13870#if defined(__parallel)
13871 INTEGER :: ierr
13872 INTEGER(kind=mpi_address_kind) :: len
13873 INTEGER(KIND=int_8) :: foo(1)
13874#endif
13875
13876 CALL mp_timeset(routinen, handle)
13877
13878#if defined(__parallel)
13879
13880 len = SIZE(base)*int_8_size
13881 IF (len > 0) THEN
13882 CALL mpi_win_create(base(1), len, int_8_size, mpi_info_null, comm%handle, win%handle, ierr)
13883 ELSE
13884 CALL mpi_win_create(foo, len, int_8_size, mpi_info_null, comm%handle, win%handle, ierr)
13885 END IF
13886 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
13887
13888 CALL add_perf(perf_id=20, count=1)
13889#else
13890 mark_used(base)
13891 mark_used(comm)
13892 win%handle = mp_win_null_handle
13893#endif
13894 CALL mp_timestop(handle)
13895 END SUBROUTINE mp_win_create_lv
13896
13897! **************************************************************************************************
13898!> \brief Single-sided get function for vector data
13899!> \param base ...
13900!> \param comm ...
13901!> \param win ...
13902!> \par History
13903!> 02.2015 created [Alfio Lazzaro]
13904!> \note
13905!> arrays can be pointers or assumed shape, but they must be contiguous!
13906! **************************************************************************************************
13907 SUBROUTINE mp_rget_lv(base, source, win, win_data, myproc, disp, request, &
13908 origin_datatype, target_datatype)
13909 INTEGER(KIND=int_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
13910 INTEGER, INTENT(IN) :: source
13911 CLASS(mp_win_type), INTENT(IN) :: win
13912 INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: win_data
13913 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
13914 TYPE(mp_request_type), INTENT(OUT) :: request
13915 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
13916
13917 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_lv'
13918
13919 INTEGER :: handle
13920#if defined(__parallel)
13921 INTEGER :: ierr, len, &
13922 origin_len, target_len
13923 LOGICAL :: do_local_copy
13924 INTEGER(kind=mpi_address_kind) :: disp_aint
13925 mpi_data_type :: handle_origin_datatype, handle_target_datatype
13926#endif
13927
13928 CALL mp_timeset(routinen, handle)
13929
13930#if defined(__parallel)
13931 len = SIZE(base)
13932 disp_aint = 0
13933 IF (PRESENT(disp)) THEN
13934 disp_aint = int(disp, kind=mpi_address_kind)
13935 END IF
13936 handle_origin_datatype = mpi_integer8
13937 origin_len = len
13938 IF (PRESENT(origin_datatype)) THEN
13939 handle_origin_datatype = origin_datatype%type_handle
13940 origin_len = 1
13941 END IF
13942 handle_target_datatype = mpi_integer8
13943 target_len = len
13944 IF (PRESENT(target_datatype)) THEN
13945 handle_target_datatype = target_datatype%type_handle
13946 target_len = 1
13947 END IF
13948 IF (len > 0) THEN
13949 do_local_copy = .false.
13950 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
13951 IF (myproc .EQ. source) do_local_copy = .true.
13952 END IF
13953 IF (do_local_copy) THEN
13954 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
13955 base(:) = win_data(disp_aint + 1:disp_aint + len)
13956 !$OMP END PARALLEL WORKSHARE
13957 request = mp_request_null
13958 ierr = 0
13959 ELSE
13960 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
13961 target_len, handle_target_datatype, win%handle, request%handle, ierr)
13962 END IF
13963 ELSE
13964 request = mp_request_null
13965 ierr = 0
13966 END IF
13967 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
13968
13969 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*int_8_size)
13970#else
13971 mark_used(source)
13972 mark_used(win)
13973 mark_used(myproc)
13974 mark_used(origin_datatype)
13975 mark_used(target_datatype)
13976
13977 request = mp_request_null
13978 !
13979 IF (PRESENT(disp)) THEN
13980 base(:) = win_data(disp + 1:disp + SIZE(base))
13981 ELSE
13982 base(:) = win_data(:SIZE(base))
13983 END IF
13984
13985#endif
13986 CALL mp_timestop(handle)
13987 END SUBROUTINE mp_rget_lv
13988
13989! **************************************************************************************************
13990!> \brief ...
13991!> \param count ...
13992!> \param lengths ...
13993!> \param displs ...
13994!> \return ...
13995! ***************************************************************************
13996 FUNCTION mp_type_indexed_make_l (count, lengths, displs) &
13997 result(type_descriptor)
13998 INTEGER, INTENT(IN) :: count
13999 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
14000 TYPE(mp_type_descriptor_type) :: type_descriptor
14001
14002 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_l'
14003
14004 INTEGER :: handle
14005#if defined(__parallel)
14006 INTEGER :: ierr
14007#endif
14008
14009 CALL mp_timeset(routinen, handle)
14010
14011#if defined(__parallel)
14012 CALL mpi_type_indexed(count, lengths, displs, mpi_integer8, &
14013 type_descriptor%type_handle, ierr)
14014 IF (ierr /= 0) &
14015 cpabort("MPI_Type_Indexed @ "//routinen)
14016 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
14017 IF (ierr /= 0) &
14018 cpabort("MPI_Type_commit @ "//routinen)
14019#else
14020 type_descriptor%type_handle = 19
14021#endif
14022 type_descriptor%length = count
14023 NULLIFY (type_descriptor%subtype)
14024 type_descriptor%vector_descriptor(1:2) = 1
14025 type_descriptor%has_indexing = .true.
14026 type_descriptor%index_descriptor%index => lengths
14027 type_descriptor%index_descriptor%chunks => displs
14028
14029 CALL mp_timestop(handle)
14030
14031 END FUNCTION mp_type_indexed_make_l
14032
14033! **************************************************************************************************
14034!> \brief Allocates special parallel memory
14035!> \param[in] DATA pointer to integer array to allocate
14036!> \param[in] len number of integers to allocate
14037!> \param[out] stat (optional) allocation status result
14038!> \author UB
14039! **************************************************************************************************
14040 SUBROUTINE mp_allocate_l (DATA, len, stat)
14041 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
14042 INTEGER, INTENT(IN) :: len
14043 INTEGER, INTENT(OUT), OPTIONAL :: stat
14044
14045 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_l'
14046
14047 INTEGER :: handle, ierr
14048
14049 CALL mp_timeset(routinen, handle)
14050
14051#if defined(__parallel)
14052 NULLIFY (data)
14053 CALL mp_alloc_mem(DATA, len, stat=ierr)
14054 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
14055 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
14056 CALL add_perf(perf_id=15, count=1)
14057#else
14058 ALLOCATE (DATA(len), stat=ierr)
14059 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
14060 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
14061#endif
14062 IF (PRESENT(stat)) stat = ierr
14063 CALL mp_timestop(handle)
14064 END SUBROUTINE mp_allocate_l
14065
14066! **************************************************************************************************
14067!> \brief Deallocates special parallel memory
14068!> \param[in] DATA pointer to special memory to deallocate
14069!> \param stat ...
14070!> \author UB
14071! **************************************************************************************************
14072 SUBROUTINE mp_deallocate_l (DATA, stat)
14073 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
14074 INTEGER, INTENT(OUT), OPTIONAL :: stat
14075
14076 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_l'
14077
14078 INTEGER :: handle
14079#if defined(__parallel)
14080 INTEGER :: ierr
14081#endif
14082
14083 CALL mp_timeset(routinen, handle)
14084
14085#if defined(__parallel)
14086 CALL mp_free_mem(DATA, ierr)
14087 IF (PRESENT(stat)) THEN
14088 stat = ierr
14089 ELSE
14090 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
14091 END IF
14092 NULLIFY (data)
14093 CALL add_perf(perf_id=15, count=1)
14094#else
14095 DEALLOCATE (data)
14096 IF (PRESENT(stat)) stat = 0
14097#endif
14098 CALL mp_timestop(handle)
14099 END SUBROUTINE mp_deallocate_l
14100
14101! **************************************************************************************************
14102!> \brief (parallel) Blocking individual file write using explicit offsets
14103!> (serial) Unformatted stream write
14104!> \param[in] fh file handle (file storage unit)
14105!> \param[in] offset file offset (position)
14106!> \param[in] msg data to be written to the file
14107!> \param msglen ...
14108!> \par MPI-I/O mapping mpi_file_write_at
14109!> \par STREAM-I/O mapping WRITE
14110!> \param[in](optional) msglen number of the elements of data
14111! **************************************************************************************************
14112 SUBROUTINE mp_file_write_at_lv(fh, offset, msg, msglen)
14113 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
14114 CLASS(mp_file_type), INTENT(IN) :: fh
14115 INTEGER, INTENT(IN), OPTIONAL :: msglen
14116 INTEGER(kind=file_offset), INTENT(IN) :: offset
14117
14118 INTEGER :: msg_len
14119#if defined(__parallel)
14120 INTEGER :: ierr
14121#endif
14122
14123 msg_len = SIZE(msg)
14124 IF (PRESENT(msglen)) msg_len = msglen
14125#if defined(__parallel)
14126 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14127 IF (ierr .NE. 0) &
14128 cpabort("mpi_file_write_at_lv @ mp_file_write_at_lv")
14129#else
14130 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14131#endif
14132 END SUBROUTINE mp_file_write_at_lv
14133
14134! **************************************************************************************************
14135!> \brief ...
14136!> \param fh ...
14137!> \param offset ...
14138!> \param msg ...
14139! **************************************************************************************************
14140 SUBROUTINE mp_file_write_at_l (fh, offset, msg)
14141 INTEGER(KIND=int_8), INTENT(IN) :: msg
14142 CLASS(mp_file_type), INTENT(IN) :: fh
14143 INTEGER(kind=file_offset), INTENT(IN) :: offset
14144
14145#if defined(__parallel)
14146 INTEGER :: ierr
14147
14148 ierr = 0
14149 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14150 IF (ierr .NE. 0) &
14151 cpabort("mpi_file_write_at_l @ mp_file_write_at_l")
14152#else
14153 WRITE (unit=fh%handle, pos=offset + 1) msg
14154#endif
14155 END SUBROUTINE mp_file_write_at_l
14156
14157! **************************************************************************************************
14158!> \brief (parallel) Blocking collective file write using explicit offsets
14159!> (serial) Unformatted stream write
14160!> \param fh ...
14161!> \param offset ...
14162!> \param msg ...
14163!> \param msglen ...
14164!> \par MPI-I/O mapping mpi_file_write_at_all
14165!> \par STREAM-I/O mapping WRITE
14166! **************************************************************************************************
14167 SUBROUTINE mp_file_write_at_all_lv(fh, offset, msg, msglen)
14168 INTEGER(KIND=int_8), CONTIGUOUS, INTENT(IN) :: msg(:)
14169 CLASS(mp_file_type), INTENT(IN) :: fh
14170 INTEGER, INTENT(IN), OPTIONAL :: msglen
14171 INTEGER(kind=file_offset), INTENT(IN) :: offset
14172
14173 INTEGER :: msg_len
14174#if defined(__parallel)
14175 INTEGER :: ierr
14176#endif
14177
14178 msg_len = SIZE(msg)
14179 IF (PRESENT(msglen)) msg_len = msglen
14180#if defined(__parallel)
14181 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14182 IF (ierr .NE. 0) &
14183 cpabort("mpi_file_write_at_all_lv @ mp_file_write_at_all_lv")
14184#else
14185 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14186#endif
14187 END SUBROUTINE mp_file_write_at_all_lv
14188
14189! **************************************************************************************************
14190!> \brief ...
14191!> \param fh ...
14192!> \param offset ...
14193!> \param msg ...
14194! **************************************************************************************************
14195 SUBROUTINE mp_file_write_at_all_l (fh, offset, msg)
14196 INTEGER(KIND=int_8), INTENT(IN) :: msg
14197 CLASS(mp_file_type), INTENT(IN) :: fh
14198 INTEGER(kind=file_offset), INTENT(IN) :: offset
14199
14200#if defined(__parallel)
14201 INTEGER :: ierr
14202
14203 ierr = 0
14204 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14205 IF (ierr .NE. 0) &
14206 cpabort("mpi_file_write_at_all_l @ mp_file_write_at_all_l")
14207#else
14208 WRITE (unit=fh%handle, pos=offset + 1) msg
14209#endif
14210 END SUBROUTINE mp_file_write_at_all_l
14211
14212! **************************************************************************************************
14213!> \brief (parallel) Blocking individual file read using explicit offsets
14214!> (serial) Unformatted stream read
14215!> \param[in] fh file handle (file storage unit)
14216!> \param[in] offset file offset (position)
14217!> \param[out] msg data to be read from the file
14218!> \param msglen ...
14219!> \par MPI-I/O mapping mpi_file_read_at
14220!> \par STREAM-I/O mapping READ
14221!> \param[in](optional) msglen number of elements of data
14222! **************************************************************************************************
14223 SUBROUTINE mp_file_read_at_lv(fh, offset, msg, msglen)
14224 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msg(:)
14225 CLASS(mp_file_type), INTENT(IN) :: fh
14226 INTEGER, INTENT(IN), OPTIONAL :: msglen
14227 INTEGER(kind=file_offset), INTENT(IN) :: offset
14228
14229 INTEGER :: msg_len
14230#if defined(__parallel)
14231 INTEGER :: ierr
14232#endif
14233
14234 msg_len = SIZE(msg)
14235 IF (PRESENT(msglen)) msg_len = msglen
14236#if defined(__parallel)
14237 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14238 IF (ierr .NE. 0) &
14239 cpabort("mpi_file_read_at_lv @ mp_file_read_at_lv")
14240#else
14241 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14242#endif
14243 END SUBROUTINE mp_file_read_at_lv
14244
14245! **************************************************************************************************
14246!> \brief ...
14247!> \param fh ...
14248!> \param offset ...
14249!> \param msg ...
14250! **************************************************************************************************
14251 SUBROUTINE mp_file_read_at_l (fh, offset, msg)
14252 INTEGER(KIND=int_8), INTENT(OUT) :: msg
14253 CLASS(mp_file_type), INTENT(IN) :: fh
14254 INTEGER(kind=file_offset), INTENT(IN) :: offset
14255
14256#if defined(__parallel)
14257 INTEGER :: ierr
14258
14259 ierr = 0
14260 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14261 IF (ierr .NE. 0) &
14262 cpabort("mpi_file_read_at_l @ mp_file_read_at_l")
14263#else
14264 READ (unit=fh%handle, pos=offset + 1) msg
14265#endif
14266 END SUBROUTINE mp_file_read_at_l
14267
14268! **************************************************************************************************
14269!> \brief (parallel) Blocking collective file read using explicit offsets
14270!> (serial) Unformatted stream read
14271!> \param fh ...
14272!> \param offset ...
14273!> \param msg ...
14274!> \param msglen ...
14275!> \par MPI-I/O mapping mpi_file_read_at_all
14276!> \par STREAM-I/O mapping READ
14277! **************************************************************************************************
14278 SUBROUTINE mp_file_read_at_all_lv(fh, offset, msg, msglen)
14279 INTEGER(KIND=int_8), INTENT(OUT), CONTIGUOUS :: msg(:)
14280 CLASS(mp_file_type), INTENT(IN) :: fh
14281 INTEGER, INTENT(IN), OPTIONAL :: msglen
14282 INTEGER(kind=file_offset), INTENT(IN) :: offset
14283
14284 INTEGER :: msg_len
14285#if defined(__parallel)
14286 INTEGER :: ierr
14287#endif
14288
14289 msg_len = SIZE(msg)
14290 IF (PRESENT(msglen)) msg_len = msglen
14291#if defined(__parallel)
14292 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_integer8, mpi_status_ignore, ierr)
14293 IF (ierr .NE. 0) &
14294 cpabort("mpi_file_read_at_all_lv @ mp_file_read_at_all_lv")
14295#else
14296 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
14297#endif
14298 END SUBROUTINE mp_file_read_at_all_lv
14299
14300! **************************************************************************************************
14301!> \brief ...
14302!> \param fh ...
14303!> \param offset ...
14304!> \param msg ...
14305! **************************************************************************************************
14306 SUBROUTINE mp_file_read_at_all_l (fh, offset, msg)
14307 INTEGER(KIND=int_8), INTENT(OUT) :: msg
14308 CLASS(mp_file_type), INTENT(IN) :: fh
14309 INTEGER(kind=file_offset), INTENT(IN) :: offset
14310
14311#if defined(__parallel)
14312 INTEGER :: ierr
14313
14314 ierr = 0
14315 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_integer8, mpi_status_ignore, ierr)
14316 IF (ierr .NE. 0) &
14317 cpabort("mpi_file_read_at_all_l @ mp_file_read_at_all_l")
14318#else
14319 READ (unit=fh%handle, pos=offset + 1) msg
14320#endif
14321 END SUBROUTINE mp_file_read_at_all_l
14322
14323! **************************************************************************************************
14324!> \brief ...
14325!> \param ptr ...
14326!> \param vector_descriptor ...
14327!> \param index_descriptor ...
14328!> \return ...
14329! **************************************************************************************************
14330 FUNCTION mp_type_make_l (ptr, &
14331 vector_descriptor, index_descriptor) &
14332 result(type_descriptor)
14333 INTEGER(KIND=int_8), DIMENSION(:), TARGET, asynchronous :: ptr
14334 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
14335 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
14336 TYPE(mp_type_descriptor_type) :: type_descriptor
14337
14338 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_l'
14339
14340#if defined(__parallel)
14341 INTEGER :: ierr
14342#endif
14343
14344 NULLIFY (type_descriptor%subtype)
14345 type_descriptor%length = SIZE(ptr)
14346#if defined(__parallel)
14347 type_descriptor%type_handle = mpi_integer8
14348 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
14349 IF (ierr /= 0) &
14350 cpabort("MPI_Get_address @ "//routinen)
14351#else
14352 type_descriptor%type_handle = 19
14353#endif
14354 type_descriptor%vector_descriptor(1:2) = 1
14355 type_descriptor%has_indexing = .false.
14356 type_descriptor%data_l => ptr
14357 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
14358 cpabort(routinen//": Vectors and indices NYI")
14359 END IF
14360 END FUNCTION mp_type_make_l
14361
14362! **************************************************************************************************
14363!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
14364!> as the Fortran version returns an integer, which we take to be a C_PTR
14365!> \param DATA data array to allocate
14366!> \param[in] len length (in data elements) of data array allocation
14367!> \param[out] stat (optional) allocation status result
14368! **************************************************************************************************
14369 SUBROUTINE mp_alloc_mem_l (DATA, len, stat)
14370 INTEGER(KIND=int_8), CONTIGUOUS, DIMENSION(:), POINTER :: data
14371 INTEGER, INTENT(IN) :: len
14372 INTEGER, INTENT(OUT), OPTIONAL :: stat
14373
14374#if defined(__parallel)
14375 INTEGER :: size, ierr, length, &
14376 mp_res
14377 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
14378 TYPE(c_ptr) :: mp_baseptr
14379 mpi_info_type :: mp_info
14380
14381 length = max(len, 1)
14382 CALL mpi_type_size(mpi_integer8, size, ierr)
14383 mp_size = int(length, kind=mpi_address_kind)*size
14384 IF (mp_size .GT. mp_max_memory_size) THEN
14385 cpabort("MPI cannot allocate more than 2 GiByte")
14386 END IF
14387 mp_info = mpi_info_null
14388 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
14389 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
14390 IF (PRESENT(stat)) stat = mp_res
14391#else
14392 INTEGER :: length, mystat
14393 length = max(len, 1)
14394 IF (PRESENT(stat)) THEN
14395 ALLOCATE (DATA(length), stat=mystat)
14396 stat = mystat ! show to convention checker that stat is used
14397 ELSE
14398 ALLOCATE (DATA(length))
14399 END IF
14400#endif
14401 END SUBROUTINE mp_alloc_mem_l
14402
14403! **************************************************************************************************
14404!> \brief Deallocates am array, ... this is hackish
14405!> as the Fortran version takes an integer, which we hope to get by reference
14406!> \param DATA data array to allocate
14407!> \param[out] stat (optional) allocation status result
14408! **************************************************************************************************
14409 SUBROUTINE mp_free_mem_l (DATA, stat)
14410 INTEGER(KIND=int_8), DIMENSION(:), &
14411 POINTER, asynchronous :: data
14412 INTEGER, INTENT(OUT), OPTIONAL :: stat
14413
14414#if defined(__parallel)
14415 INTEGER :: mp_res
14416 CALL mpi_free_mem(DATA, mp_res)
14417 IF (PRESENT(stat)) stat = mp_res
14418#else
14419 DEALLOCATE (data)
14420 IF (PRESENT(stat)) stat = 0
14421#endif
14422 END SUBROUTINE mp_free_mem_l
14423! **************************************************************************************************
14424!> \brief Shift around the data in msg
14425!> \param[in,out] msg Rank-2 data to shift
14426!> \param[in] comm message passing environment identifier
14427!> \param[in] displ_in displacements (?)
14428!> \par Example
14429!> msg will be moved from rank to rank+displ_in (in a circular way)
14430!> \par Limitations
14431!> * displ_in will be 1 by default (others not tested)
14432!> * the message array needs to be the same size on all processes
14433! **************************************************************************************************
14434 SUBROUTINE mp_shift_dm(msg, comm, displ_in)
14435
14436 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
14437 CLASS(mp_comm_type), INTENT(IN) :: comm
14438 INTEGER, INTENT(IN), OPTIONAL :: displ_in
14439
14440 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_dm'
14441
14442 INTEGER :: handle, ierror
14443#if defined(__parallel)
14444 INTEGER :: displ, left, &
14445 msglen, myrank, nprocs, &
14446 right, tag
14447#endif
14448
14449 ierror = 0
14450 CALL mp_timeset(routinen, handle)
14451
14452#if defined(__parallel)
14453 CALL mpi_comm_rank(comm%handle, myrank, ierror)
14454 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
14455 CALL mpi_comm_size(comm%handle, nprocs, ierror)
14456 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
14457 IF (PRESENT(displ_in)) THEN
14458 displ = displ_in
14459 ELSE
14460 displ = 1
14461 END IF
14462 right = modulo(myrank + displ, nprocs)
14463 left = modulo(myrank - displ, nprocs)
14464 tag = 17
14465 msglen = SIZE(msg)
14466 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_precision, right, tag, left, tag, &
14467 comm%handle, mpi_status_ignore, ierror)
14468 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
14469 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_8_size)
14470#else
14471 mark_used(msg)
14472 mark_used(comm)
14473 mark_used(displ_in)
14474#endif
14475 CALL mp_timestop(handle)
14476
14477 END SUBROUTINE mp_shift_dm
14478
14479! **************************************************************************************************
14480!> \brief Shift around the data in msg
14481!> \param[in,out] msg Data to shift
14482!> \param[in] comm message passing environment identifier
14483!> \param[in] displ_in displacements (?)
14484!> \par Example
14485!> msg will be moved from rank to rank+displ_in (in a circular way)
14486!> \par Limitations
14487!> * displ_in will be 1 by default (others not tested)
14488!> * the message array needs to be the same size on all processes
14489! **************************************************************************************************
14490 SUBROUTINE mp_shift_d (msg, comm, displ_in)
14491
14492 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
14493 CLASS(mp_comm_type), INTENT(IN) :: comm
14494 INTEGER, INTENT(IN), OPTIONAL :: displ_in
14495
14496 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_d'
14497
14498 INTEGER :: handle, ierror
14499#if defined(__parallel)
14500 INTEGER :: displ, left, &
14501 msglen, myrank, nprocs, &
14502 right, tag
14503#endif
14504
14505 ierror = 0
14506 CALL mp_timeset(routinen, handle)
14507
14508#if defined(__parallel)
14509 CALL mpi_comm_rank(comm%handle, myrank, ierror)
14510 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
14511 CALL mpi_comm_size(comm%handle, nprocs, ierror)
14512 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
14513 IF (PRESENT(displ_in)) THEN
14514 displ = displ_in
14515 ELSE
14516 displ = 1
14517 END IF
14518 right = modulo(myrank + displ, nprocs)
14519 left = modulo(myrank - displ, nprocs)
14520 tag = 19
14521 msglen = SIZE(msg)
14522 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_precision, right, tag, left, &
14523 tag, comm%handle, mpi_status_ignore, ierror)
14524 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
14525 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_8_size)
14526#else
14527 mark_used(msg)
14528 mark_used(comm)
14529 mark_used(displ_in)
14530#endif
14531 CALL mp_timestop(handle)
14532
14533 END SUBROUTINE mp_shift_d
14534
14535! **************************************************************************************************
14536!> \brief All-to-all data exchange, rank-1 data of different sizes
14537!> \param[in] sb Data to send
14538!> \param[in] scount Data counts for data sent to other processes
14539!> \param[in] sdispl Respective data offsets for data sent to process
14540!> \param[in,out] rb Buffer into which to receive data
14541!> \param[in] rcount Data counts for data received from other
14542!> processes
14543!> \param[in] rdispl Respective data offsets for data received from
14544!> other processes
14545!> \param[in] comm Message passing environment identifier
14546!> \par MPI mapping
14547!> mpi_alltoallv
14548!> \par Array sizes
14549!> The scount, rcount, and the sdispl and rdispl arrays have a
14550!> size equal to the number of processes.
14551!> \par Offsets
14552!> Values in sdispl and rdispl start with 0.
14553! **************************************************************************************************
14554 SUBROUTINE mp_alltoall_d11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
14555
14556 REAL(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
14557 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
14558 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
14559 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
14560 CLASS(mp_comm_type), INTENT(IN) :: comm
14561
14562 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d11v'
14563
14564 INTEGER :: handle
14565#if defined(__parallel)
14566 INTEGER :: ierr, msglen
14567#else
14568 INTEGER :: i
14569#endif
14570
14571 CALL mp_timeset(routinen, handle)
14572
14573#if defined(__parallel)
14574 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_precision, &
14575 rb, rcount, rdispl, mpi_double_precision, comm%handle, ierr)
14576 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
14577 msglen = sum(scount) + sum(rcount)
14578 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14579#else
14580 mark_used(comm)
14581 mark_used(scount)
14582 mark_used(sdispl)
14583 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
14584 DO i = 1, rcount(1)
14585 rb(rdispl(1) + i) = sb(sdispl(1) + i)
14586 END DO
14587#endif
14588 CALL mp_timestop(handle)
14589
14590 END SUBROUTINE mp_alltoall_d11v
14591
14592! **************************************************************************************************
14593!> \brief All-to-all data exchange, rank-2 data of different sizes
14594!> \param sb ...
14595!> \param scount ...
14596!> \param sdispl ...
14597!> \param rb ...
14598!> \param rcount ...
14599!> \param rdispl ...
14600!> \param comm ...
14601!> \par MPI mapping
14602!> mpi_alltoallv
14603!> \note see mp_alltoall_d11v
14604! **************************************************************************************************
14605 SUBROUTINE mp_alltoall_d22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
14606
14607 REAL(kind=real_8), DIMENSION(:, :), &
14608 INTENT(IN), CONTIGUOUS :: sb
14609 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
14610 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, &
14611 INTENT(INOUT) :: rb
14612 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
14613 CLASS(mp_comm_type), INTENT(IN) :: comm
14614
14615 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d22v'
14616
14617 INTEGER :: handle
14618#if defined(__parallel)
14619 INTEGER :: ierr, msglen
14620#endif
14621
14622 CALL mp_timeset(routinen, handle)
14623
14624#if defined(__parallel)
14625 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_precision, &
14626 rb, rcount, rdispl, mpi_double_precision, comm%handle, ierr)
14627 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
14628 msglen = sum(scount) + sum(rcount)
14629 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*real_8_size)
14630#else
14631 mark_used(comm)
14632 mark_used(scount)
14633 mark_used(sdispl)
14634 mark_used(rcount)
14635 mark_used(rdispl)
14636 rb = sb
14637#endif
14638 CALL mp_timestop(handle)
14639
14640 END SUBROUTINE mp_alltoall_d22v
14641
14642! **************************************************************************************************
14643!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
14644!> \param[in] sb array with data to send
14645!> \param[out] rb array into which data is received
14646!> \param[in] count number of elements to send/receive (product of the
14647!> extents of the first two dimensions)
14648!> \param[in] comm Message passing environment identifier
14649!> \par Index meaning
14650!> \par The first two indices specify the data while the last index counts
14651!> the processes
14652!> \par Sizes of ranks
14653!> All processes have the same data size.
14654!> \par MPI mapping
14655!> mpi_alltoall
14656! **************************************************************************************************
14657 SUBROUTINE mp_alltoall_d (sb, rb, count, comm)
14658
14659 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
14660 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
14661 INTEGER, INTENT(IN) :: count
14662 CLASS(mp_comm_type), INTENT(IN) :: comm
14663
14664 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d'
14665
14666 INTEGER :: handle
14667#if defined(__parallel)
14668 INTEGER :: ierr, msglen, np
14669#endif
14670
14671 CALL mp_timeset(routinen, handle)
14672
14673#if defined(__parallel)
14674 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14675 rb, count, mpi_double_precision, comm%handle, ierr)
14676 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14677 CALL mpi_comm_size(comm%handle, np, ierr)
14678 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14679 msglen = 2*count*np
14680 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14681#else
14682 mark_used(count)
14683 mark_used(comm)
14684 rb = sb
14685#endif
14686 CALL mp_timestop(handle)
14687
14688 END SUBROUTINE mp_alltoall_d
14689
14690! **************************************************************************************************
14691!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
14692!> \param sb ...
14693!> \param rb ...
14694!> \param count ...
14695!> \param commp ...
14696!> \note see mp_alltoall_d
14697! **************************************************************************************************
14698 SUBROUTINE mp_alltoall_d22(sb, rb, count, comm)
14699
14700 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
14701 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
14702 INTEGER, INTENT(IN) :: count
14703 CLASS(mp_comm_type), INTENT(IN) :: comm
14704
14705 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d22'
14706
14707 INTEGER :: handle
14708#if defined(__parallel)
14709 INTEGER :: ierr, msglen, np
14710#endif
14711
14712 CALL mp_timeset(routinen, handle)
14713
14714#if defined(__parallel)
14715 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14716 rb, count, mpi_double_precision, comm%handle, ierr)
14717 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14718 CALL mpi_comm_size(comm%handle, np, ierr)
14719 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14720 msglen = 2*SIZE(sb)*np
14721 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14722#else
14723 mark_used(count)
14724 mark_used(comm)
14725 rb = sb
14726#endif
14727 CALL mp_timestop(handle)
14728
14729 END SUBROUTINE mp_alltoall_d22
14730
14731! **************************************************************************************************
14732!> \brief All-to-all data exchange, rank-3 data with equal sizes
14733!> \param sb ...
14734!> \param rb ...
14735!> \param count ...
14736!> \param comm ...
14737!> \note see mp_alltoall_d
14738! **************************************************************************************************
14739 SUBROUTINE mp_alltoall_d33(sb, rb, count, comm)
14740
14741 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
14742 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
14743 INTEGER, INTENT(IN) :: count
14744 CLASS(mp_comm_type), INTENT(IN) :: comm
14745
14746 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d33'
14747
14748 INTEGER :: handle
14749#if defined(__parallel)
14750 INTEGER :: ierr, msglen, np
14751#endif
14752
14753 CALL mp_timeset(routinen, handle)
14754
14755#if defined(__parallel)
14756 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14757 rb, count, mpi_double_precision, comm%handle, ierr)
14758 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14759 CALL mpi_comm_size(comm%handle, np, ierr)
14760 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14761 msglen = 2*count*np
14762 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14763#else
14764 mark_used(count)
14765 mark_used(comm)
14766 rb = sb
14767#endif
14768 CALL mp_timestop(handle)
14769
14770 END SUBROUTINE mp_alltoall_d33
14771
14772! **************************************************************************************************
14773!> \brief All-to-all data exchange, rank 4 data, equal sizes
14774!> \param sb ...
14775!> \param rb ...
14776!> \param count ...
14777!> \param comm ...
14778!> \note see mp_alltoall_d
14779! **************************************************************************************************
14780 SUBROUTINE mp_alltoall_d44(sb, rb, count, comm)
14781
14782 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14783 INTENT(IN) :: sb
14784 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14785 INTENT(OUT) :: rb
14786 INTEGER, INTENT(IN) :: count
14787 CLASS(mp_comm_type), INTENT(IN) :: comm
14788
14789 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d44'
14790
14791 INTEGER :: handle
14792#if defined(__parallel)
14793 INTEGER :: ierr, msglen, np
14794#endif
14795
14796 CALL mp_timeset(routinen, handle)
14797
14798#if defined(__parallel)
14799 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14800 rb, count, mpi_double_precision, comm%handle, ierr)
14801 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14802 CALL mpi_comm_size(comm%handle, np, ierr)
14803 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14804 msglen = 2*count*np
14805 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14806#else
14807 mark_used(count)
14808 mark_used(comm)
14809 rb = sb
14810#endif
14811 CALL mp_timestop(handle)
14812
14813 END SUBROUTINE mp_alltoall_d44
14814
14815! **************************************************************************************************
14816!> \brief All-to-all data exchange, rank 5 data, equal sizes
14817!> \param sb ...
14818!> \param rb ...
14819!> \param count ...
14820!> \param comm ...
14821!> \note see mp_alltoall_d
14822! **************************************************************************************************
14823 SUBROUTINE mp_alltoall_d55(sb, rb, count, comm)
14824
14825 REAL(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
14826 INTENT(IN) :: sb
14827 REAL(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
14828 INTENT(OUT) :: rb
14829 INTEGER, INTENT(IN) :: count
14830 CLASS(mp_comm_type), INTENT(IN) :: comm
14831
14832 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d55'
14833
14834 INTEGER :: handle
14835#if defined(__parallel)
14836 INTEGER :: ierr, msglen, np
14837#endif
14838
14839 CALL mp_timeset(routinen, handle)
14840
14841#if defined(__parallel)
14842 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14843 rb, count, mpi_double_precision, comm%handle, ierr)
14844 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14845 CALL mpi_comm_size(comm%handle, np, ierr)
14846 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14847 msglen = 2*count*np
14848 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14849#else
14850 mark_used(count)
14851 mark_used(comm)
14852 rb = sb
14853#endif
14854 CALL mp_timestop(handle)
14855
14856 END SUBROUTINE mp_alltoall_d55
14857
14858! **************************************************************************************************
14859!> \brief All-to-all data exchange, rank-4 data to rank-5 data
14860!> \param sb ...
14861!> \param rb ...
14862!> \param count ...
14863!> \param comm ...
14864!> \note see mp_alltoall_d
14865!> \note User must ensure size consistency.
14866! **************************************************************************************************
14867 SUBROUTINE mp_alltoall_d45(sb, rb, count, comm)
14868
14869 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14870 INTENT(IN) :: sb
14871 REAL(kind=real_8), &
14872 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
14873 INTEGER, INTENT(IN) :: count
14874 CLASS(mp_comm_type), INTENT(IN) :: comm
14875
14876 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d45'
14877
14878 INTEGER :: handle
14879#if defined(__parallel)
14880 INTEGER :: ierr, msglen, np
14881#endif
14882
14883 CALL mp_timeset(routinen, handle)
14884
14885#if defined(__parallel)
14886 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14887 rb, count, mpi_double_precision, comm%handle, ierr)
14888 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14889 CALL mpi_comm_size(comm%handle, np, ierr)
14890 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14891 msglen = 2*count*np
14892 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14893#else
14894 mark_used(count)
14895 mark_used(comm)
14896 rb = reshape(sb, shape(rb))
14897#endif
14898 CALL mp_timestop(handle)
14899
14900 END SUBROUTINE mp_alltoall_d45
14901
14902! **************************************************************************************************
14903!> \brief All-to-all data exchange, rank-3 data to rank-4 data
14904!> \param sb ...
14905!> \param rb ...
14906!> \param count ...
14907!> \param comm ...
14908!> \note see mp_alltoall_d
14909!> \note User must ensure size consistency.
14910! **************************************************************************************************
14911 SUBROUTINE mp_alltoall_d34(sb, rb, count, comm)
14912
14913 REAL(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, &
14914 INTENT(IN) :: sb
14915 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14916 INTENT(OUT) :: rb
14917 INTEGER, INTENT(IN) :: count
14918 CLASS(mp_comm_type), INTENT(IN) :: comm
14919
14920 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d34'
14921
14922 INTEGER :: handle
14923#if defined(__parallel)
14924 INTEGER :: ierr, msglen, np
14925#endif
14926
14927 CALL mp_timeset(routinen, handle)
14928
14929#if defined(__parallel)
14930 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14931 rb, count, mpi_double_precision, comm%handle, ierr)
14932 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14933 CALL mpi_comm_size(comm%handle, np, ierr)
14934 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14935 msglen = 2*count*np
14936 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14937#else
14938 mark_used(count)
14939 mark_used(comm)
14940 rb = reshape(sb, shape(rb))
14941#endif
14942 CALL mp_timestop(handle)
14943
14944 END SUBROUTINE mp_alltoall_d34
14945
14946! **************************************************************************************************
14947!> \brief All-to-all data exchange, rank-5 data to rank-4 data
14948!> \param sb ...
14949!> \param rb ...
14950!> \param count ...
14951!> \param comm ...
14952!> \note see mp_alltoall_d
14953!> \note User must ensure size consistency.
14954! **************************************************************************************************
14955 SUBROUTINE mp_alltoall_d54(sb, rb, count, comm)
14956
14957 REAL(kind=real_8), &
14958 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
14959 REAL(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
14960 INTENT(OUT) :: rb
14961 INTEGER, INTENT(IN) :: count
14962 CLASS(mp_comm_type), INTENT(IN) :: comm
14963
14964 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_d54'
14965
14966 INTEGER :: handle
14967#if defined(__parallel)
14968 INTEGER :: ierr, msglen, np
14969#endif
14970
14971 CALL mp_timeset(routinen, handle)
14972
14973#if defined(__parallel)
14974 CALL mpi_alltoall(sb, count, mpi_double_precision, &
14975 rb, count, mpi_double_precision, comm%handle, ierr)
14976 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
14977 CALL mpi_comm_size(comm%handle, np, ierr)
14978 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
14979 msglen = 2*count*np
14980 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_8_size)
14981#else
14982 mark_used(count)
14983 mark_used(comm)
14984 rb = reshape(sb, shape(rb))
14985#endif
14986 CALL mp_timestop(handle)
14987
14988 END SUBROUTINE mp_alltoall_d54
14989
14990! **************************************************************************************************
14991!> \brief Send one datum to another process
14992!> \param[in] msg Scalar to send
14993!> \param[in] dest Destination process
14994!> \param[in] tag Transfer identifier
14995!> \param[in] comm Message passing environment identifier
14996!> \par MPI mapping
14997!> mpi_send
14998! **************************************************************************************************
14999 SUBROUTINE mp_send_d (msg, dest, tag, comm)
15000 REAL(kind=real_8), INTENT(IN) :: msg
15001 INTEGER, INTENT(IN) :: dest, tag
15002 CLASS(mp_comm_type), INTENT(IN) :: comm
15003
15004 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_d'
15005
15006 INTEGER :: handle
15007#if defined(__parallel)
15008 INTEGER :: ierr, msglen
15009#endif
15010
15011 CALL mp_timeset(routinen, handle)
15012
15013#if defined(__parallel)
15014 msglen = 1
15015 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15016 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15017 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15018#else
15019 mark_used(msg)
15020 mark_used(dest)
15021 mark_used(tag)
15022 mark_used(comm)
15023 ! only defined in parallel
15024 cpabort("not in parallel mode")
15025#endif
15026 CALL mp_timestop(handle)
15027 END SUBROUTINE mp_send_d
15028
15029! **************************************************************************************************
15030!> \brief Send rank-1 data to another process
15031!> \param[in] msg Rank-1 data to send
15032!> \param dest ...
15033!> \param tag ...
15034!> \param comm ...
15035!> \note see mp_send_d
15036! **************************************************************************************************
15037 SUBROUTINE mp_send_dv(msg, dest, tag, comm)
15038 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
15039 INTEGER, INTENT(IN) :: dest, tag
15040 CLASS(mp_comm_type), INTENT(IN) :: comm
15041
15042 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_dv'
15043
15044 INTEGER :: handle
15045#if defined(__parallel)
15046 INTEGER :: ierr, msglen
15047#endif
15048
15049 CALL mp_timeset(routinen, handle)
15050
15051#if defined(__parallel)
15052 msglen = SIZE(msg)
15053 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15054 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15055 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15056#else
15057 mark_used(msg)
15058 mark_used(dest)
15059 mark_used(tag)
15060 mark_used(comm)
15061 ! only defined in parallel
15062 cpabort("not in parallel mode")
15063#endif
15064 CALL mp_timestop(handle)
15065 END SUBROUTINE mp_send_dv
15066
15067! **************************************************************************************************
15068!> \brief Send rank-2 data to another process
15069!> \param[in] msg Rank-2 data to send
15070!> \param dest ...
15071!> \param tag ...
15072!> \param comm ...
15073!> \note see mp_send_d
15074! **************************************************************************************************
15075 SUBROUTINE mp_send_dm2(msg, dest, tag, comm)
15076 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
15077 INTEGER, INTENT(IN) :: dest, tag
15078 CLASS(mp_comm_type), INTENT(IN) :: comm
15079
15080 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_dm2'
15081
15082 INTEGER :: handle
15083#if defined(__parallel)
15084 INTEGER :: ierr, msglen
15085#endif
15086
15087 CALL mp_timeset(routinen, handle)
15088
15089#if defined(__parallel)
15090 msglen = SIZE(msg)
15091 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15092 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15093 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15094#else
15095 mark_used(msg)
15096 mark_used(dest)
15097 mark_used(tag)
15098 mark_used(comm)
15099 ! only defined in parallel
15100 cpabort("not in parallel mode")
15101#endif
15102 CALL mp_timestop(handle)
15103 END SUBROUTINE mp_send_dm2
15104
15105! **************************************************************************************************
15106!> \brief Send rank-3 data to another process
15107!> \param[in] msg Rank-3 data to send
15108!> \param dest ...
15109!> \param tag ...
15110!> \param comm ...
15111!> \note see mp_send_d
15112! **************************************************************************************************
15113 SUBROUTINE mp_send_dm3(msg, dest, tag, comm)
15114 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
15115 INTEGER, INTENT(IN) :: dest, tag
15116 CLASS(mp_comm_type), INTENT(IN) :: comm
15117
15118 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
15119
15120 INTEGER :: handle
15121#if defined(__parallel)
15122 INTEGER :: ierr, msglen
15123#endif
15124
15125 CALL mp_timeset(routinen, handle)
15126
15127#if defined(__parallel)
15128 msglen = SIZE(msg)
15129 CALL mpi_send(msg, msglen, mpi_double_precision, dest, tag, comm%handle, ierr)
15130 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
15131 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_8_size)
15132#else
15133 mark_used(msg)
15134 mark_used(dest)
15135 mark_used(tag)
15136 mark_used(comm)
15137 ! only defined in parallel
15138 cpabort("not in parallel mode")
15139#endif
15140 CALL mp_timestop(handle)
15141 END SUBROUTINE mp_send_dm3
15142
15143! **************************************************************************************************
15144!> \brief Receive one datum from another process
15145!> \param[in,out] msg Place received data into this variable
15146!> \param[in,out] source Process to receive from
15147!> \param[in,out] tag Transfer identifier
15148!> \param[in] comm Message passing environment identifier
15149!> \par MPI mapping
15150!> mpi_send
15151! **************************************************************************************************
15152 SUBROUTINE mp_recv_d (msg, source, tag, comm)
15153 REAL(kind=real_8), INTENT(INOUT) :: msg
15154 INTEGER, INTENT(INOUT) :: source, tag
15155 CLASS(mp_comm_type), INTENT(IN) :: comm
15156
15157 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_d'
15158
15159 INTEGER :: handle
15160#if defined(__parallel)
15161 INTEGER :: ierr, msglen
15162 mpi_status_type :: status
15163#endif
15164
15165 CALL mp_timeset(routinen, handle)
15166
15167#if defined(__parallel)
15168 msglen = 1
15169 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15170 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15171 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15172 ELSE
15173 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15174 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15175 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15176 source = status mpi_status_extract(mpi_source)
15177 tag = status mpi_status_extract(mpi_tag)
15178 END IF
15179#else
15180 mark_used(msg)
15181 mark_used(source)
15182 mark_used(tag)
15183 mark_used(comm)
15184 ! only defined in parallel
15185 cpabort("not in parallel mode")
15186#endif
15187 CALL mp_timestop(handle)
15188 END SUBROUTINE mp_recv_d
15189
15190! **************************************************************************************************
15191!> \brief Receive rank-1 data from another process
15192!> \param[in,out] msg Place received data into this rank-1 array
15193!> \param source ...
15194!> \param tag ...
15195!> \param comm ...
15196!> \note see mp_recv_d
15197! **************************************************************************************************
15198 SUBROUTINE mp_recv_dv(msg, source, tag, comm)
15199 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15200 INTEGER, INTENT(INOUT) :: source, tag
15201 CLASS(mp_comm_type), INTENT(IN) :: comm
15202
15203 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dv'
15204
15205 INTEGER :: handle
15206#if defined(__parallel)
15207 INTEGER :: ierr, msglen
15208 mpi_status_type :: status
15209#endif
15210
15211 CALL mp_timeset(routinen, handle)
15212
15213#if defined(__parallel)
15214 msglen = SIZE(msg)
15215 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15216 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15217 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15218 ELSE
15219 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15220 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15221 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15222 source = status mpi_status_extract(mpi_source)
15223 tag = status mpi_status_extract(mpi_tag)
15224 END IF
15225#else
15226 mark_used(msg)
15227 mark_used(source)
15228 mark_used(tag)
15229 mark_used(comm)
15230 ! only defined in parallel
15231 cpabort("not in parallel mode")
15232#endif
15233 CALL mp_timestop(handle)
15234 END SUBROUTINE mp_recv_dv
15235
15236! **************************************************************************************************
15237!> \brief Receive rank-2 data from another process
15238!> \param[in,out] msg Place received data into this rank-2 array
15239!> \param source ...
15240!> \param tag ...
15241!> \param comm ...
15242!> \note see mp_recv_d
15243! **************************************************************************************************
15244 SUBROUTINE mp_recv_dm2(msg, source, tag, comm)
15245 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15246 INTEGER, INTENT(INOUT) :: source, tag
15247 CLASS(mp_comm_type), INTENT(IN) :: comm
15248
15249 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dm2'
15250
15251 INTEGER :: handle
15252#if defined(__parallel)
15253 INTEGER :: ierr, msglen
15254 mpi_status_type :: status
15255#endif
15256
15257 CALL mp_timeset(routinen, handle)
15258
15259#if defined(__parallel)
15260 msglen = SIZE(msg)
15261 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15262 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15263 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15264 ELSE
15265 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15266 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15267 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15268 source = status mpi_status_extract(mpi_source)
15269 tag = status mpi_status_extract(mpi_tag)
15270 END IF
15271#else
15272 mark_used(msg)
15273 mark_used(source)
15274 mark_used(tag)
15275 mark_used(comm)
15276 ! only defined in parallel
15277 cpabort("not in parallel mode")
15278#endif
15279 CALL mp_timestop(handle)
15280 END SUBROUTINE mp_recv_dm2
15281
15282! **************************************************************************************************
15283!> \brief Receive rank-3 data from another process
15284!> \param[in,out] msg Place received data into this rank-3 array
15285!> \param source ...
15286!> \param tag ...
15287!> \param comm ...
15288!> \note see mp_recv_d
15289! **************************************************************************************************
15290 SUBROUTINE mp_recv_dm3(msg, source, tag, comm)
15291 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
15292 INTEGER, INTENT(INOUT) :: source, tag
15293 CLASS(mp_comm_type), INTENT(IN) :: comm
15294
15295 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_dm3'
15296
15297 INTEGER :: handle
15298#if defined(__parallel)
15299 INTEGER :: ierr, msglen
15300 mpi_status_type :: status
15301#endif
15302
15303 CALL mp_timeset(routinen, handle)
15304
15305#if defined(__parallel)
15306 msglen = SIZE(msg)
15307 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
15308 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, mpi_status_ignore, ierr)
15309 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15310 ELSE
15311 CALL mpi_recv(msg, msglen, mpi_double_precision, source, tag, comm%handle, status, ierr)
15312 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
15313 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_8_size)
15314 source = status mpi_status_extract(mpi_source)
15315 tag = status mpi_status_extract(mpi_tag)
15316 END IF
15317#else
15318 mark_used(msg)
15319 mark_used(source)
15320 mark_used(tag)
15321 mark_used(comm)
15322 ! only defined in parallel
15323 cpabort("not in parallel mode")
15324#endif
15325 CALL mp_timestop(handle)
15326 END SUBROUTINE mp_recv_dm3
15327
15328! **************************************************************************************************
15329!> \brief Broadcasts a datum to all processes.
15330!> \param[in] msg Datum to broadcast
15331!> \param[in] source Processes which broadcasts
15332!> \param[in] comm Message passing environment identifier
15333!> \par MPI mapping
15334!> mpi_bcast
15335! **************************************************************************************************
15336 SUBROUTINE mp_bcast_d (msg, source, comm)
15337 REAL(kind=real_8), INTENT(INOUT) :: msg
15338 INTEGER, INTENT(IN) :: source
15339 CLASS(mp_comm_type), INTENT(IN) :: comm
15340
15341 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d'
15342
15343 INTEGER :: handle
15344#if defined(__parallel)
15345 INTEGER :: ierr, msglen
15346#endif
15347
15348 CALL mp_timeset(routinen, handle)
15349
15350#if defined(__parallel)
15351 msglen = 1
15352 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15353 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15354 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15355#else
15356 mark_used(msg)
15357 mark_used(source)
15358 mark_used(comm)
15359#endif
15360 CALL mp_timestop(handle)
15361 END SUBROUTINE mp_bcast_d
15362
15363! **************************************************************************************************
15364!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
15365!> \param[in] msg Datum to broadcast
15366!> \param[in] comm Message passing environment identifier
15367!> \par MPI mapping
15368!> mpi_bcast
15369! **************************************************************************************************
15370 SUBROUTINE mp_bcast_d_src(msg, comm)
15371 REAL(kind=real_8), INTENT(INOUT) :: msg
15372 CLASS(mp_comm_type), INTENT(IN) :: comm
15373
15374 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d_src'
15375
15376 INTEGER :: handle
15377#if defined(__parallel)
15378 INTEGER :: ierr, msglen
15379#endif
15380
15381 CALL mp_timeset(routinen, handle)
15382
15383#if defined(__parallel)
15384 msglen = 1
15385 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15386 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15387 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15388#else
15389 mark_used(msg)
15390 mark_used(comm)
15391#endif
15392 CALL mp_timestop(handle)
15393 END SUBROUTINE mp_bcast_d_src
15394
15395! **************************************************************************************************
15396!> \brief Broadcasts a datum to all processes.
15397!> \param[in] msg Datum to broadcast
15398!> \param[in] source Processes which broadcasts
15399!> \param[in] comm Message passing environment identifier
15400!> \par MPI mapping
15401!> mpi_bcast
15402! **************************************************************************************************
15403 SUBROUTINE mp_ibcast_d (msg, source, comm, request)
15404 REAL(kind=real_8), INTENT(INOUT) :: msg
15405 INTEGER, INTENT(IN) :: source
15406 CLASS(mp_comm_type), INTENT(IN) :: comm
15407 TYPE(mp_request_type), INTENT(OUT) :: request
15408
15409 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_d'
15410
15411 INTEGER :: handle
15412#if defined(__parallel)
15413 INTEGER :: ierr, msglen
15414#endif
15415
15416 CALL mp_timeset(routinen, handle)
15417
15418#if defined(__parallel)
15419 msglen = 1
15420 CALL mpi_ibcast(msg, msglen, mpi_double_precision, source, comm%handle, request%handle, ierr)
15421 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
15422 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_8_size)
15423#else
15424 mark_used(msg)
15425 mark_used(source)
15426 mark_used(comm)
15427 request = mp_request_null
15428#endif
15429 CALL mp_timestop(handle)
15430 END SUBROUTINE mp_ibcast_d
15431
15432! **************************************************************************************************
15433!> \brief Broadcasts rank-1 data to all processes
15434!> \param[in] msg Data to broadcast
15435!> \param source ...
15436!> \param comm ...
15437!> \note see mp_bcast_d1
15438! **************************************************************************************************
15439 SUBROUTINE mp_bcast_dv(msg, source, comm)
15440 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15441 INTEGER, INTENT(IN) :: source
15442 CLASS(mp_comm_type), INTENT(IN) :: comm
15443
15444 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dv'
15445
15446 INTEGER :: handle
15447#if defined(__parallel)
15448 INTEGER :: ierr, msglen
15449#endif
15450
15451 CALL mp_timeset(routinen, handle)
15452
15453#if defined(__parallel)
15454 msglen = SIZE(msg)
15455 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15456 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15457 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15458#else
15459 mark_used(msg)
15460 mark_used(source)
15461 mark_used(comm)
15462#endif
15463 CALL mp_timestop(handle)
15464 END SUBROUTINE mp_bcast_dv
15465
15466! **************************************************************************************************
15467!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
15468!> \param[in] msg Data to broadcast
15469!> \param comm ...
15470!> \note see mp_bcast_d1
15471! **************************************************************************************************
15472 SUBROUTINE mp_bcast_dv_src(msg, comm)
15473 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15474 CLASS(mp_comm_type), INTENT(IN) :: comm
15475
15476 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dv_src'
15477
15478 INTEGER :: handle
15479#if defined(__parallel)
15480 INTEGER :: ierr, msglen
15481#endif
15482
15483 CALL mp_timeset(routinen, handle)
15484
15485#if defined(__parallel)
15486 msglen = SIZE(msg)
15487 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15488 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15489 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15490#else
15491 mark_used(msg)
15492 mark_used(comm)
15493#endif
15494 CALL mp_timestop(handle)
15495 END SUBROUTINE mp_bcast_dv_src
15496
15497! **************************************************************************************************
15498!> \brief Broadcasts rank-1 data to all processes
15499!> \param[in] msg Data to broadcast
15500!> \param source ...
15501!> \param comm ...
15502!> \note see mp_bcast_d1
15503! **************************************************************************************************
15504 SUBROUTINE mp_ibcast_dv(msg, source, comm, request)
15505 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
15506 INTEGER, INTENT(IN) :: source
15507 CLASS(mp_comm_type), INTENT(IN) :: comm
15508 TYPE(mp_request_type) :: request
15509
15510 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_dv'
15511
15512 INTEGER :: handle
15513#if defined(__parallel)
15514 INTEGER :: ierr, msglen
15515#endif
15516
15517 CALL mp_timeset(routinen, handle)
15518
15519#if defined(__parallel)
15520#if !defined(__GNUC__) || __GNUC__ >= 9
15521 cpassert(is_contiguous(msg))
15522#endif
15523 msglen = SIZE(msg)
15524 CALL mpi_ibcast(msg, msglen, mpi_double_precision, source, comm%handle, request%handle, ierr)
15525 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
15526 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_8_size)
15527#else
15528 mark_used(msg)
15529 mark_used(source)
15530 mark_used(comm)
15531 request = mp_request_null
15532#endif
15533 CALL mp_timestop(handle)
15534 END SUBROUTINE mp_ibcast_dv
15535
15536! **************************************************************************************************
15537!> \brief Broadcasts rank-2 data to all processes
15538!> \param[in] msg Data to broadcast
15539!> \param source ...
15540!> \param comm ...
15541!> \note see mp_bcast_d1
15542! **************************************************************************************************
15543 SUBROUTINE mp_bcast_dm(msg, source, comm)
15544 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15545 INTEGER, INTENT(IN) :: source
15546 CLASS(mp_comm_type), INTENT(IN) :: comm
15547
15548 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dm'
15549
15550 INTEGER :: handle
15551#if defined(__parallel)
15552 INTEGER :: ierr, msglen
15553#endif
15554
15555 CALL mp_timeset(routinen, handle)
15556
15557#if defined(__parallel)
15558 msglen = SIZE(msg)
15559 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15560 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15561 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15562#else
15563 mark_used(msg)
15564 mark_used(source)
15565 mark_used(comm)
15566#endif
15567 CALL mp_timestop(handle)
15568 END SUBROUTINE mp_bcast_dm
15569
15570! **************************************************************************************************
15571!> \brief Broadcasts rank-2 data to all processes
15572!> \param[in] msg Data to broadcast
15573!> \param source ...
15574!> \param comm ...
15575!> \note see mp_bcast_d1
15576! **************************************************************************************************
15577 SUBROUTINE mp_bcast_dm_src(msg, comm)
15578 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15579 CLASS(mp_comm_type), INTENT(IN) :: comm
15580
15581 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_dm_src'
15582
15583 INTEGER :: handle
15584#if defined(__parallel)
15585 INTEGER :: ierr, msglen
15586#endif
15587
15588 CALL mp_timeset(routinen, handle)
15589
15590#if defined(__parallel)
15591 msglen = SIZE(msg)
15592 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15593 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15594 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15595#else
15596 mark_used(msg)
15597 mark_used(comm)
15598#endif
15599 CALL mp_timestop(handle)
15600 END SUBROUTINE mp_bcast_dm_src
15601
15602! **************************************************************************************************
15603!> \brief Broadcasts rank-3 data to all processes
15604!> \param[in] msg Data to broadcast
15605!> \param source ...
15606!> \param comm ...
15607!> \note see mp_bcast_d1
15608! **************************************************************************************************
15609 SUBROUTINE mp_bcast_d3(msg, source, comm)
15610 REAL(kind=real_8), CONTIGUOUS :: msg(:, :, :)
15611 INTEGER, INTENT(IN) :: source
15612 CLASS(mp_comm_type), INTENT(IN) :: comm
15613
15614 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d3'
15615
15616 INTEGER :: handle
15617#if defined(__parallel)
15618 INTEGER :: ierr, msglen
15619#endif
15620
15621 CALL mp_timeset(routinen, handle)
15622
15623#if defined(__parallel)
15624 msglen = SIZE(msg)
15625 CALL mpi_bcast(msg, msglen, mpi_double_precision, source, comm%handle, ierr)
15626 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15627 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15628#else
15629 mark_used(msg)
15630 mark_used(source)
15631 mark_used(comm)
15632#endif
15633 CALL mp_timestop(handle)
15634 END SUBROUTINE mp_bcast_d3
15635
15636! **************************************************************************************************
15637!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
15638!> \param[in] msg Data to broadcast
15639!> \param source ...
15640!> \param comm ...
15641!> \note see mp_bcast_d1
15642! **************************************************************************************************
15643 SUBROUTINE mp_bcast_d3_src(msg, comm)
15644 REAL(kind=real_8), CONTIGUOUS :: msg(:, :, :)
15645 CLASS(mp_comm_type), INTENT(IN) :: comm
15646
15647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_d3_src'
15648
15649 INTEGER :: handle
15650#if defined(__parallel)
15651 INTEGER :: ierr, msglen
15652#endif
15653
15654 CALL mp_timeset(routinen, handle)
15655
15656#if defined(__parallel)
15657 msglen = SIZE(msg)
15658 CALL mpi_bcast(msg, msglen, mpi_double_precision, comm%source, comm%handle, ierr)
15659 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
15660 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_8_size)
15661#else
15662 mark_used(msg)
15663 mark_used(comm)
15664#endif
15665 CALL mp_timestop(handle)
15666 END SUBROUTINE mp_bcast_d3_src
15667
15668! **************************************************************************************************
15669!> \brief Sums a datum from all processes with result left on all processes.
15670!> \param[in,out] msg Datum to sum (input) and result (output)
15671!> \param[in] comm Message passing environment identifier
15672!> \par MPI mapping
15673!> mpi_allreduce
15674! **************************************************************************************************
15675 SUBROUTINE mp_sum_d (msg, comm)
15676 REAL(kind=real_8), INTENT(INOUT) :: msg
15677 CLASS(mp_comm_type), INTENT(IN) :: comm
15678
15679 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_d'
15680
15681 INTEGER :: handle
15682#if defined(__parallel)
15683 INTEGER :: ierr, msglen
15684#endif
15685
15686 CALL mp_timeset(routinen, handle)
15687
15688#if defined(__parallel)
15689 msglen = 1
15690 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15691 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15692 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15693#else
15694 mark_used(msg)
15695 mark_used(comm)
15696#endif
15697 CALL mp_timestop(handle)
15698 END SUBROUTINE mp_sum_d
15699
15700! **************************************************************************************************
15701!> \brief Element-wise sum of a rank-1 array on all processes.
15702!> \param[in,out] msg Vector to sum and result
15703!> \param comm ...
15704!> \note see mp_sum_d
15705! **************************************************************************************************
15706 SUBROUTINE mp_sum_dv(msg, comm)
15707 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15708 CLASS(mp_comm_type), INTENT(IN) :: comm
15709
15710 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dv'
15711
15712 INTEGER :: handle
15713#if defined(__parallel)
15714 INTEGER :: ierr, msglen
15715#endif
15716
15717 CALL mp_timeset(routinen, handle)
15718
15719#if defined(__parallel)
15720 msglen = SIZE(msg)
15721 IF (msglen > 0) THEN
15722 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15723 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15724 END IF
15725 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15726#else
15727 mark_used(msg)
15728 mark_used(comm)
15729#endif
15730 CALL mp_timestop(handle)
15731 END SUBROUTINE mp_sum_dv
15732
15733! **************************************************************************************************
15734!> \brief Element-wise sum of a rank-1 array on all processes.
15735!> \param[in,out] msg Vector to sum and result
15736!> \param comm ...
15737!> \note see mp_sum_d
15738! **************************************************************************************************
15739 SUBROUTINE mp_isum_dv(msg, comm, request)
15740 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
15741 CLASS(mp_comm_type), INTENT(IN) :: comm
15742 TYPE(mp_request_type), INTENT(OUT) :: request
15743
15744 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_dv'
15745
15746 INTEGER :: handle
15747#if defined(__parallel)
15748 INTEGER :: ierr, msglen
15749#endif
15750
15751 CALL mp_timeset(routinen, handle)
15752
15753#if defined(__parallel)
15754#if !defined(__GNUC__) || __GNUC__ >= 9
15755 cpassert(is_contiguous(msg))
15756#endif
15757 msglen = SIZE(msg)
15758 IF (msglen > 0) THEN
15759 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, request%handle, ierr)
15760 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
15761 ELSE
15762 request = mp_request_null
15763 END IF
15764 CALL add_perf(perf_id=23, count=1, msg_size=msglen*real_8_size)
15765#else
15766 mark_used(msg)
15767 mark_used(comm)
15768 request = mp_request_null
15769#endif
15770 CALL mp_timestop(handle)
15771 END SUBROUTINE mp_isum_dv
15772
15773! **************************************************************************************************
15774!> \brief Element-wise sum of a rank-2 array on all processes.
15775!> \param[in] msg Matrix to sum and result
15776!> \param comm ...
15777!> \note see mp_sum_d
15778! **************************************************************************************************
15779 SUBROUTINE mp_sum_dm(msg, comm)
15780 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15781 CLASS(mp_comm_type), INTENT(IN) :: comm
15782
15783 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm'
15784
15785 INTEGER :: handle
15786#if defined(__parallel)
15787 INTEGER, PARAMETER :: max_msg = 2**25
15788 INTEGER :: ierr, m1, msglen, step, msglensum
15789#endif
15790
15791 CALL mp_timeset(routinen, handle)
15792
15793#if defined(__parallel)
15794 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
15795 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
15796 msglensum = 0
15797 DO m1 = lbound(msg, 2), ubound(msg, 2), step
15798 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
15799 msglensum = msglensum + msglen
15800 IF (msglen > 0) THEN
15801 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15802 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15803 END IF
15804 END DO
15805 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_8_size)
15806#else
15807 mark_used(msg)
15808 mark_used(comm)
15809#endif
15810 CALL mp_timestop(handle)
15811 END SUBROUTINE mp_sum_dm
15812
15813! **************************************************************************************************
15814!> \brief Element-wise sum of a rank-3 array on all processes.
15815!> \param[in] msg Array to sum and result
15816!> \param comm ...
15817!> \note see mp_sum_d
15818! **************************************************************************************************
15819 SUBROUTINE mp_sum_dm3(msg, comm)
15820 REAL(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
15821 CLASS(mp_comm_type), INTENT(IN) :: comm
15822
15823 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm3'
15824
15825 INTEGER :: handle
15826#if defined(__parallel)
15827 INTEGER :: ierr, msglen
15828#endif
15829
15830 CALL mp_timeset(routinen, handle)
15831
15832#if defined(__parallel)
15833 msglen = SIZE(msg)
15834 IF (msglen > 0) THEN
15835 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15836 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15837 END IF
15838 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15839#else
15840 mark_used(msg)
15841 mark_used(comm)
15842#endif
15843 CALL mp_timestop(handle)
15844 END SUBROUTINE mp_sum_dm3
15845
15846! **************************************************************************************************
15847!> \brief Element-wise sum of a rank-4 array on all processes.
15848!> \param[in] msg Array to sum and result
15849!> \param comm ...
15850!> \note see mp_sum_d
15851! **************************************************************************************************
15852 SUBROUTINE mp_sum_dm4(msg, comm)
15853 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
15854 CLASS(mp_comm_type), INTENT(IN) :: comm
15855
15856 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_dm4'
15857
15858 INTEGER :: handle
15859#if defined(__parallel)
15860 INTEGER :: ierr, msglen
15861#endif
15862
15863 CALL mp_timeset(routinen, handle)
15864
15865#if defined(__parallel)
15866 msglen = SIZE(msg)
15867 IF (msglen > 0) THEN
15868 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
15869 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
15870 END IF
15871 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15872#else
15873 mark_used(msg)
15874 mark_used(comm)
15875#endif
15876 CALL mp_timestop(handle)
15877 END SUBROUTINE mp_sum_dm4
15878
15879! **************************************************************************************************
15880!> \brief Element-wise sum of data from all processes with result left only on
15881!> one.
15882!> \param[in,out] msg Vector to sum (input) and (only on process root)
15883!> result (output)
15884!> \param root ...
15885!> \param[in] comm Message passing environment identifier
15886!> \par MPI mapping
15887!> mpi_reduce
15888! **************************************************************************************************
15889 SUBROUTINE mp_sum_root_dv(msg, root, comm)
15890 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
15891 INTEGER, INTENT(IN) :: root
15892 CLASS(mp_comm_type), INTENT(IN) :: comm
15893
15894 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_dv'
15895
15896 INTEGER :: handle
15897#if defined(__parallel)
15898 INTEGER :: ierr, m1, msglen, taskid
15899 REAL(kind=real_8), ALLOCATABLE :: res(:)
15900#endif
15901
15902 CALL mp_timeset(routinen, handle)
15903
15904#if defined(__parallel)
15905 msglen = SIZE(msg)
15906 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15907 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
15908 IF (msglen > 0) THEN
15909 m1 = SIZE(msg, 1)
15910 ALLOCATE (res(m1))
15911 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_sum, &
15912 root, comm%handle, ierr)
15913 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
15914 IF (taskid == root) THEN
15915 msg = res
15916 END IF
15917 DEALLOCATE (res)
15918 END IF
15919 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15920#else
15921 mark_used(msg)
15922 mark_used(root)
15923 mark_used(comm)
15924#endif
15925 CALL mp_timestop(handle)
15926 END SUBROUTINE mp_sum_root_dv
15927
15928! **************************************************************************************************
15929!> \brief Element-wise sum of data from all processes with result left only on
15930!> one.
15931!> \param[in,out] msg Matrix to sum (input) and (only on process root)
15932!> result (output)
15933!> \param root ...
15934!> \param comm ...
15935!> \note see mp_sum_root_dv
15936! **************************************************************************************************
15937 SUBROUTINE mp_sum_root_dm(msg, root, comm)
15938 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
15939 INTEGER, INTENT(IN) :: root
15940 CLASS(mp_comm_type), INTENT(IN) :: comm
15941
15942 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
15943
15944 INTEGER :: handle
15945#if defined(__parallel)
15946 INTEGER :: ierr, m1, m2, msglen, taskid
15947 REAL(kind=real_8), ALLOCATABLE :: res(:, :)
15948#endif
15949
15950 CALL mp_timeset(routinen, handle)
15951
15952#if defined(__parallel)
15953 msglen = SIZE(msg)
15954 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15955 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
15956 IF (msglen > 0) THEN
15957 m1 = SIZE(msg, 1)
15958 m2 = SIZE(msg, 2)
15959 ALLOCATE (res(m1, m2))
15960 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_sum, root, comm%handle, ierr)
15961 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
15962 IF (taskid == root) THEN
15963 msg = res
15964 END IF
15965 DEALLOCATE (res)
15966 END IF
15967 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
15968#else
15969 mark_used(root)
15970 mark_used(msg)
15971 mark_used(comm)
15972#endif
15973 CALL mp_timestop(handle)
15974 END SUBROUTINE mp_sum_root_dm
15975
15976! **************************************************************************************************
15977!> \brief Partial sum of data from all processes with result on each process.
15978!> \param[in] msg Matrix to sum (input)
15979!> \param[out] res Matrix containing result (output)
15980!> \param[in] comm Message passing environment identifier
15981! **************************************************************************************************
15982 SUBROUTINE mp_sum_partial_dm(msg, res, comm)
15983 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
15984 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
15985 CLASS(mp_comm_type), INTENT(IN) :: comm
15986
15987 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_dm'
15988
15989 INTEGER :: handle
15990#if defined(__parallel)
15991 INTEGER :: ierr, msglen, taskid
15992#endif
15993
15994 CALL mp_timeset(routinen, handle)
15995
15996#if defined(__parallel)
15997 msglen = SIZE(msg)
15998 CALL mpi_comm_rank(comm%handle, taskid, ierr)
15999 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
16000 IF (msglen > 0) THEN
16001 CALL mpi_scan(msg, res, msglen, mpi_double_precision, mpi_sum, comm%handle, ierr)
16002 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
16003 END IF
16004 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16005 ! perf_id is same as for other summation routines
16006#else
16007 res = msg
16008 mark_used(comm)
16009#endif
16010 CALL mp_timestop(handle)
16011 END SUBROUTINE mp_sum_partial_dm
16012
16013! **************************************************************************************************
16014!> \brief Finds the maximum of a datum with the result left on all processes.
16015!> \param[in,out] msg Find maximum among these data (input) and
16016!> maximum (output)
16017!> \param[in] comm Message passing environment identifier
16018!> \par MPI mapping
16019!> mpi_allreduce
16020! **************************************************************************************************
16021 SUBROUTINE mp_max_d (msg, comm)
16022 REAL(kind=real_8), INTENT(INOUT) :: msg
16023 CLASS(mp_comm_type), INTENT(IN) :: comm
16024
16025 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_d'
16026
16027 INTEGER :: handle
16028#if defined(__parallel)
16029 INTEGER :: ierr, msglen
16030#endif
16031
16032 CALL mp_timeset(routinen, handle)
16033
16034#if defined(__parallel)
16035 msglen = 1
16036 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
16037 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
16043 CALL mp_timestop(handle)
16044 END SUBROUTINE mp_max_d
16045
16046! **************************************************************************************************
16047!> \brief Finds the maximum of a datum with the result left on all processes.
16048!> \param[in,out] msg Find maximum among these data (input) and
16049!> maximum (output)
16050!> \param[in] comm Message passing environment identifier
16051!> \par MPI mapping
16052!> mpi_allreduce
16053! **************************************************************************************************
16054 SUBROUTINE mp_max_root_d (msg, root, comm)
16055 REAL(kind=real_8), INTENT(INOUT) :: msg
16056 INTEGER, INTENT(IN) :: root
16057 CLASS(mp_comm_type), INTENT(IN) :: comm
16058
16059 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_d'
16060
16061 INTEGER :: handle
16062#if defined(__parallel)
16063 INTEGER :: ierr, msglen
16064 REAL(kind=real_8) :: res
16065#endif
16066
16067 CALL mp_timeset(routinen, handle)
16068
16069#if defined(__parallel)
16070 msglen = 1
16071 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_max, root, comm%handle, ierr)
16072 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
16073 IF (root == comm%mepos) msg = res
16074 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16075#else
16076 mark_used(msg)
16077 mark_used(comm)
16078 mark_used(root)
16079#endif
16080 CALL mp_timestop(handle)
16081 END SUBROUTINE mp_max_root_d
16082
16083! **************************************************************************************************
16084!> \brief Finds the element-wise maximum of a vector with the result left on
16085!> all processes.
16086!> \param[in,out] msg Find maximum among these data (input) and
16087!> maximum (output)
16088!> \param comm ...
16089!> \note see mp_max_d
16090! **************************************************************************************************
16091 SUBROUTINE mp_max_dv(msg, comm)
16092 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
16093 CLASS(mp_comm_type), INTENT(IN) :: comm
16094
16095 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_dv'
16096
16097 INTEGER :: handle
16098#if defined(__parallel)
16099 INTEGER :: ierr, msglen
16100#endif
16101
16102 CALL mp_timeset(routinen, handle)
16103
16104#if defined(__parallel)
16105 msglen = SIZE(msg)
16106 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_max, comm%handle, ierr)
16107 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
16113 CALL mp_timestop(handle)
16114 END SUBROUTINE mp_max_dv
16115
16116! **************************************************************************************************
16117!> \brief Finds the element-wise maximum of a vector with the result left on
16118!> all processes.
16119!> \param[in,out] msg Find maximum among these data (input) and
16120!> maximum (output)
16121!> \param comm ...
16122!> \note see mp_max_d
16123! **************************************************************************************************
16124 SUBROUTINE mp_max_root_dm(msg, root, comm)
16125 REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
16126 INTEGER :: root
16127 CLASS(mp_comm_type), INTENT(IN) :: comm
16128
16129 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_dm'
16130
16131 INTEGER :: handle
16132#if defined(__parallel)
16133 INTEGER :: ierr, msglen
16134 REAL(kind=real_8) :: res(SIZE(msg, 1), SIZE(msg, 2))
16135#endif
16136
16137 CALL mp_timeset(routinen, handle)
16138
16139#if defined(__parallel)
16140 msglen = SIZE(msg)
16141 CALL mpi_reduce(msg, res, msglen, mpi_double_precision, mpi_max, root, comm%handle, ierr)
16142 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16143 IF (root == comm%mepos) msg = res
16144 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16145#else
16146 mark_used(msg)
16147 mark_used(comm)
16148 mark_used(root)
16149#endif
16150 CALL mp_timestop(handle)
16151 END SUBROUTINE mp_max_root_dm
16152
16153! **************************************************************************************************
16154!> \brief Finds the minimum of a datum with the result left on all processes.
16155!> \param[in,out] msg Find minimum among these data (input) and
16156!> maximum (output)
16157!> \param[in] comm Message passing environment identifier
16158!> \par MPI mapping
16159!> mpi_allreduce
16160! **************************************************************************************************
16161 SUBROUTINE mp_min_d (msg, comm)
16162 REAL(kind=real_8), INTENT(INOUT) :: msg
16163 CLASS(mp_comm_type), INTENT(IN) :: comm
16164
16165 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_d'
16166
16167 INTEGER :: handle
16168#if defined(__parallel)
16169 INTEGER :: ierr, msglen
16170#endif
16171
16172 CALL mp_timeset(routinen, handle)
16173
16174#if defined(__parallel)
16175 msglen = 1
16176 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
16177 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16178 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16179#else
16180 mark_used(msg)
16181 mark_used(comm)
16182#endif
16183 CALL mp_timestop(handle)
16184 END SUBROUTINE mp_min_d
16185
16186! **************************************************************************************************
16187!> \brief Finds the element-wise minimum of vector with the result left on
16188!> all processes.
16189!> \param[in,out] msg Find minimum among these data (input) and
16190!> maximum (output)
16191!> \param comm ...
16192!> \par MPI mapping
16193!> mpi_allreduce
16194!> \note see mp_min_d
16195! **************************************************************************************************
16196 SUBROUTINE mp_min_dv(msg, comm)
16197 REAL(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
16198 CLASS(mp_comm_type), INTENT(IN) :: comm
16199
16200 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_dv'
16201
16202 INTEGER :: handle
16203#if defined(__parallel)
16204 INTEGER :: ierr, msglen
16205#endif
16206
16207 CALL mp_timeset(routinen, handle)
16208
16209#if defined(__parallel)
16210 msglen = SIZE(msg)
16211 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_min, comm%handle, ierr)
16212 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16213 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16214#else
16215 mark_used(msg)
16216 mark_used(comm)
16217#endif
16218 CALL mp_timestop(handle)
16219 END SUBROUTINE mp_min_dv
16220
16221! **************************************************************************************************
16222!> \brief Multiplies a set of numbers scattered across a number of processes,
16223!> then replicates the result.
16224!> \param[in,out] msg a number to multiply (input) and result (output)
16225!> \param[in] comm message passing environment identifier
16226!> \par MPI mapping
16227!> mpi_allreduce
16228! **************************************************************************************************
16229 SUBROUTINE mp_prod_d (msg, comm)
16230 REAL(kind=real_8), INTENT(INOUT) :: msg
16231 CLASS(mp_comm_type), INTENT(IN) :: comm
16232
16233 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_d'
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 = 1
16244 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_precision, mpi_prod, comm%handle, ierr)
16245 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
16246 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
16247#else
16248 mark_used(msg)
16249 mark_used(comm)
16250#endif
16251 CALL mp_timestop(handle)
16252 END SUBROUTINE mp_prod_d
16253
16254! **************************************************************************************************
16255!> \brief Scatters data from one processes to all others
16256!> \param[in] msg_scatter Data to scatter (for root process)
16257!> \param[out] msg Received data
16258!> \param[in] root Process which scatters data
16259!> \param[in] comm Message passing environment identifier
16260!> \par MPI mapping
16261!> mpi_scatter
16262! **************************************************************************************************
16263 SUBROUTINE mp_scatter_dv(msg_scatter, msg, root, comm)
16264 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
16265 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
16266 INTEGER, INTENT(IN) :: root
16267 CLASS(mp_comm_type), INTENT(IN) :: comm
16268
16269 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_dv'
16270
16271 INTEGER :: handle
16272#if defined(__parallel)
16273 INTEGER :: ierr, msglen
16274#endif
16275
16276 CALL mp_timeset(routinen, handle)
16277
16278#if defined(__parallel)
16279 msglen = SIZE(msg)
16280 CALL mpi_scatter(msg_scatter, msglen, mpi_double_precision, msg, &
16281 msglen, mpi_double_precision, root, comm%handle, ierr)
16282 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
16283 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16284#else
16285 mark_used(root)
16286 mark_used(comm)
16287 msg = msg_scatter
16288#endif
16289 CALL mp_timestop(handle)
16290 END SUBROUTINE mp_scatter_dv
16291
16292! **************************************************************************************************
16293!> \brief Scatters data from one processes to all others
16294!> \param[in] msg_scatter Data to scatter (for root process)
16295!> \param[in] root Process which scatters data
16296!> \param[in] comm Message passing environment identifier
16297!> \par MPI mapping
16298!> mpi_scatter
16299! **************************************************************************************************
16300 SUBROUTINE mp_iscatter_d (msg_scatter, msg, root, comm, request)
16301 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:)
16302 REAL(kind=real_8), INTENT(INOUT) :: msg
16303 INTEGER, INTENT(IN) :: root
16304 CLASS(mp_comm_type), INTENT(IN) :: comm
16305 TYPE(mp_request_type), INTENT(OUT) :: request
16306
16307 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_d'
16308
16309 INTEGER :: handle
16310#if defined(__parallel)
16311 INTEGER :: ierr, msglen
16312#endif
16313
16314 CALL mp_timeset(routinen, handle)
16315
16316#if defined(__parallel)
16317#if !defined(__GNUC__) || __GNUC__ >= 9
16318 cpassert(is_contiguous(msg_scatter))
16319#endif
16320 msglen = 1
16321 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_precision, msg, &
16322 msglen, mpi_double_precision, root, comm%handle, request%handle, ierr)
16323 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
16324 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16325#else
16326 mark_used(root)
16327 mark_used(comm)
16328 msg = msg_scatter(1)
16329 request = mp_request_null
16330#endif
16331 CALL mp_timestop(handle)
16332 END SUBROUTINE mp_iscatter_d
16333
16334! **************************************************************************************************
16335!> \brief Scatters data from one processes to all others
16336!> \param[in] msg_scatter Data to scatter (for root process)
16337!> \param[in] root Process which scatters data
16338!> \param[in] comm Message passing environment identifier
16339!> \par MPI mapping
16340!> mpi_scatter
16341! **************************************************************************************************
16342 SUBROUTINE mp_iscatter_dv2(msg_scatter, msg, root, comm, request)
16343 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:, :)
16344 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
16345 INTEGER, INTENT(IN) :: root
16346 CLASS(mp_comm_type), INTENT(IN) :: comm
16347 TYPE(mp_request_type), INTENT(OUT) :: request
16348
16349 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_dv2'
16350
16351 INTEGER :: handle
16352#if defined(__parallel)
16353 INTEGER :: ierr, msglen
16354#endif
16355
16356 CALL mp_timeset(routinen, handle)
16357
16358#if defined(__parallel)
16359#if !defined(__GNUC__) || __GNUC__ >= 9
16360 cpassert(is_contiguous(msg_scatter))
16361#endif
16362 msglen = SIZE(msg)
16363 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_precision, msg, &
16364 msglen, mpi_double_precision, root, comm%handle, request%handle, ierr)
16365 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
16366 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16367#else
16368 mark_used(root)
16369 mark_used(comm)
16370 msg(:) = msg_scatter(:, 1)
16371 request = mp_request_null
16372#endif
16373 CALL mp_timestop(handle)
16374 END SUBROUTINE mp_iscatter_dv2
16375
16376! **************************************************************************************************
16377!> \brief Scatters data from one processes to all others
16378!> \param[in] msg_scatter Data to scatter (for root process)
16379!> \param[in] root Process which scatters data
16380!> \param[in] comm Message passing environment identifier
16381!> \par MPI mapping
16382!> mpi_scatter
16383! **************************************************************************************************
16384 SUBROUTINE mp_iscatterv_dv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
16385 REAL(kind=real_8), INTENT(IN) :: msg_scatter(:)
16386 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
16387 REAL(kind=real_8), INTENT(INOUT) :: msg(:)
16388 INTEGER, INTENT(IN) :: recvcount, root
16389 CLASS(mp_comm_type), INTENT(IN) :: comm
16390 TYPE(mp_request_type), INTENT(OUT) :: request
16391
16392 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_dv'
16393
16394 INTEGER :: handle
16395#if defined(__parallel)
16396 INTEGER :: ierr
16397#endif
16398
16399 CALL mp_timeset(routinen, handle)
16400
16401#if defined(__parallel)
16402#if !defined(__GNUC__) || __GNUC__ >= 9
16403 cpassert(is_contiguous(msg_scatter))
16404 cpassert(is_contiguous(msg))
16405 cpassert(is_contiguous(sendcounts))
16406 cpassert(is_contiguous(displs))
16407#endif
16408 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_double_precision, msg, &
16409 recvcount, mpi_double_precision, root, comm%handle, request%handle, ierr)
16410 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
16411 CALL add_perf(perf_id=24, count=1, msg_size=1*real_8_size)
16412#else
16413 mark_used(sendcounts)
16414 mark_used(displs)
16415 mark_used(recvcount)
16416 mark_used(root)
16417 mark_used(comm)
16418 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
16419 request = mp_request_null
16420#endif
16421 CALL mp_timestop(handle)
16422 END SUBROUTINE mp_iscatterv_dv
16423
16424! **************************************************************************************************
16425!> \brief Gathers a datum from all processes to one
16426!> \param[in] msg Datum to send to root
16427!> \param[out] msg_gather Received data (on root)
16428!> \param[in] root Process which gathers the data
16429!> \param[in] comm Message passing environment identifier
16430!> \par MPI mapping
16431!> mpi_gather
16432! **************************************************************************************************
16433 SUBROUTINE mp_gather_d (msg, msg_gather, root, comm)
16434 REAL(kind=real_8), INTENT(IN) :: msg
16435 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16436 INTEGER, INTENT(IN) :: root
16437 CLASS(mp_comm_type), INTENT(IN) :: comm
16438
16439 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_d'
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, root, 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(root)
16456 mark_used(comm)
16457 msg_gather(1) = msg
16458#endif
16459 CALL mp_timestop(handle)
16460 END SUBROUTINE mp_gather_d
16461
16462! **************************************************************************************************
16463!> \brief Gathers a datum from all processes to one, uses the source process of comm
16464!> \param[in] msg Datum to send to root
16465!> \param[out] msg_gather Received data (on root)
16466!> \param[in] comm Message passing environment identifier
16467!> \par MPI mapping
16468!> mpi_gather
16469! **************************************************************************************************
16470 SUBROUTINE mp_gather_d_src(msg, msg_gather, comm)
16471 REAL(kind=real_8), INTENT(IN) :: msg
16472 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16473 CLASS(mp_comm_type), INTENT(IN) :: comm
16474
16475 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_d_src'
16476
16477 INTEGER :: handle
16478#if defined(__parallel)
16479 INTEGER :: ierr, msglen
16480#endif
16481
16482 CALL mp_timeset(routinen, handle)
16483
16484#if defined(__parallel)
16485 msglen = 1
16486 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16487 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16488 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16489 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16490#else
16491 mark_used(comm)
16492 msg_gather(1) = msg
16493#endif
16494 CALL mp_timestop(handle)
16495 END SUBROUTINE mp_gather_d_src
16496
16497! **************************************************************************************************
16498!> \brief Gathers data from all processes to one
16499!> \param[in] msg Datum to send to root
16500!> \param msg_gather ...
16501!> \param root ...
16502!> \param comm ...
16503!> \par Data length
16504!> All data (msg) is equal-sized
16505!> \par MPI mapping
16506!> mpi_gather
16507!> \note see mp_gather_d
16508! **************************************************************************************************
16509 SUBROUTINE mp_gather_dv(msg, msg_gather, root, comm)
16510 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
16511 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16512 INTEGER, INTENT(IN) :: root
16513 CLASS(mp_comm_type), INTENT(IN) :: comm
16514
16515 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dv'
16516
16517 INTEGER :: handle
16518#if defined(__parallel)
16519 INTEGER :: ierr, msglen
16520#endif
16521
16522 CALL mp_timeset(routinen, handle)
16523
16524#if defined(__parallel)
16525 msglen = SIZE(msg)
16526 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16527 msglen, mpi_double_precision, root, comm%handle, ierr)
16528 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16529 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16530#else
16531 mark_used(root)
16532 mark_used(comm)
16533 msg_gather = msg
16534#endif
16535 CALL mp_timestop(handle)
16536 END SUBROUTINE mp_gather_dv
16537
16538! **************************************************************************************************
16539!> \brief Gathers data from all processes to one. Gathers from comm%source
16540!> \param[in] msg Datum to send to root
16541!> \param msg_gather ...
16542!> \param comm ...
16543!> \par Data length
16544!> All data (msg) is equal-sized
16545!> \par MPI mapping
16546!> mpi_gather
16547!> \note see mp_gather_d
16548! **************************************************************************************************
16549 SUBROUTINE mp_gather_dv_src(msg, msg_gather, comm)
16550 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
16551 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
16552 CLASS(mp_comm_type), INTENT(IN) :: comm
16553
16554 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dv_src'
16555
16556 INTEGER :: handle
16557#if defined(__parallel)
16558 INTEGER :: ierr, msglen
16559#endif
16560
16561 CALL mp_timeset(routinen, handle)
16562
16563#if defined(__parallel)
16564 msglen = SIZE(msg)
16565 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16566 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16567 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16568 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16569#else
16570 mark_used(comm)
16571 msg_gather = msg
16572#endif
16573 CALL mp_timestop(handle)
16574 END SUBROUTINE mp_gather_dv_src
16575
16576! **************************************************************************************************
16577!> \brief Gathers data from all processes to one
16578!> \param[in] msg Datum to send to root
16579!> \param msg_gather ...
16580!> \param root ...
16581!> \param comm ...
16582!> \par Data length
16583!> All data (msg) is equal-sized
16584!> \par MPI mapping
16585!> mpi_gather
16586!> \note see mp_gather_d
16587! **************************************************************************************************
16588 SUBROUTINE mp_gather_dm(msg, msg_gather, root, comm)
16589 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16590 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
16591 INTEGER, INTENT(IN) :: root
16592 CLASS(mp_comm_type), INTENT(IN) :: comm
16593
16594 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dm'
16595
16596 INTEGER :: handle
16597#if defined(__parallel)
16598 INTEGER :: ierr, msglen
16599#endif
16600
16601 CALL mp_timeset(routinen, handle)
16602
16603#if defined(__parallel)
16604 msglen = SIZE(msg)
16605 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16606 msglen, mpi_double_precision, root, comm%handle, ierr)
16607 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16608 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16609#else
16610 mark_used(root)
16611 mark_used(comm)
16612 msg_gather = msg
16613#endif
16614 CALL mp_timestop(handle)
16615 END SUBROUTINE mp_gather_dm
16616
16617! **************************************************************************************************
16618!> \brief Gathers data from all processes to one. Gathers from comm%source
16619!> \param[in] msg Datum to send to root
16620!> \param msg_gather ...
16621!> \param comm ...
16622!> \par Data length
16623!> All data (msg) is equal-sized
16624!> \par MPI mapping
16625!> mpi_gather
16626!> \note see mp_gather_d
16627! **************************************************************************************************
16628 SUBROUTINE mp_gather_dm_src(msg, msg_gather, comm)
16629 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
16630 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
16631 CLASS(mp_comm_type), INTENT(IN) :: comm
16632
16633 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_dm_src'
16634
16635 INTEGER :: handle
16636#if defined(__parallel)
16637 INTEGER :: ierr, msglen
16638#endif
16639
16640 CALL mp_timeset(routinen, handle)
16641
16642#if defined(__parallel)
16643 msglen = SIZE(msg)
16644 CALL mpi_gather(msg, msglen, mpi_double_precision, msg_gather, &
16645 msglen, mpi_double_precision, comm%source, comm%handle, ierr)
16646 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
16647 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_8_size)
16648#else
16649 mark_used(comm)
16650 msg_gather = msg
16651#endif
16652 CALL mp_timestop(handle)
16653 END SUBROUTINE mp_gather_dm_src
16654
16655! **************************************************************************************************
16656!> \brief Gathers data from all processes to one.
16657!> \param[in] sendbuf Data to send to root
16658!> \param[out] recvbuf Received data (on root)
16659!> \param[in] recvcounts Sizes of data received from processes
16660!> \param[in] displs Offsets of data received from processes
16661!> \param[in] root Process which gathers the data
16662!> \param[in] comm Message passing environment identifier
16663!> \par Data length
16664!> Data can have different lengths
16665!> \par Offsets
16666!> Offsets start at 0
16667!> \par MPI mapping
16668!> mpi_gather
16669! **************************************************************************************************
16670 SUBROUTINE mp_gatherv_dv(sendbuf, recvbuf, recvcounts, displs, root, comm)
16671
16672 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
16673 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
16674 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16675 INTEGER, INTENT(IN) :: root
16676 CLASS(mp_comm_type), INTENT(IN) :: comm
16677
16678 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dv'
16679
16680 INTEGER :: handle
16681#if defined(__parallel)
16682 INTEGER :: ierr, sendcount
16683#endif
16684
16685 CALL mp_timeset(routinen, handle)
16686
16687#if defined(__parallel)
16688 sendcount = SIZE(sendbuf)
16689 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16690 recvbuf, recvcounts, displs, mpi_double_precision, &
16691 root, comm%handle, ierr)
16692 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16693 CALL add_perf(perf_id=4, &
16694 count=1, &
16695 msg_size=sendcount*real_8_size)
16696#else
16697 mark_used(recvcounts)
16698 mark_used(root)
16699 mark_used(comm)
16700 recvbuf(1 + displs(1):) = sendbuf
16701#endif
16702 CALL mp_timestop(handle)
16703 END SUBROUTINE mp_gatherv_dv
16704
16705! **************************************************************************************************
16706!> \brief Gathers data from all processes to one. Gathers from comm%source
16707!> \param[in] sendbuf Data to send to root
16708!> \param[out] recvbuf Received data (on root)
16709!> \param[in] recvcounts Sizes of data received from processes
16710!> \param[in] displs Offsets of data received from processes
16711!> \param[in] comm Message passing environment identifier
16712!> \par Data length
16713!> Data can have different lengths
16714!> \par Offsets
16715!> Offsets start at 0
16716!> \par MPI mapping
16717!> mpi_gather
16718! **************************************************************************************************
16719 SUBROUTINE mp_gatherv_dv_src(sendbuf, recvbuf, recvcounts, displs, comm)
16720
16721 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
16722 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
16723 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16724 CLASS(mp_comm_type), INTENT(IN) :: comm
16725
16726 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dv_src'
16727
16728 INTEGER :: handle
16729#if defined(__parallel)
16730 INTEGER :: ierr, sendcount
16731#endif
16732
16733 CALL mp_timeset(routinen, handle)
16734
16735#if defined(__parallel)
16736 sendcount = SIZE(sendbuf)
16737 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16738 recvbuf, recvcounts, displs, mpi_double_precision, &
16739 comm%source, comm%handle, ierr)
16740 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16741 CALL add_perf(perf_id=4, &
16742 count=1, &
16743 msg_size=sendcount*real_8_size)
16744#else
16745 mark_used(recvcounts)
16746 mark_used(comm)
16747 recvbuf(1 + displs(1):) = sendbuf
16748#endif
16749 CALL mp_timestop(handle)
16750 END SUBROUTINE mp_gatherv_dv_src
16751
16752! **************************************************************************************************
16753!> \brief Gathers data from all processes to one.
16754!> \param[in] sendbuf Data to send to root
16755!> \param[out] recvbuf Received data (on root)
16756!> \param[in] recvcounts Sizes of data received from processes
16757!> \param[in] displs Offsets of data received from processes
16758!> \param[in] root Process which gathers the data
16759!> \param[in] comm Message passing environment identifier
16760!> \par Data length
16761!> Data can have different lengths
16762!> \par Offsets
16763!> Offsets start at 0
16764!> \par MPI mapping
16765!> mpi_gather
16766! **************************************************************************************************
16767 SUBROUTINE mp_gatherv_dm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
16768
16769 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
16770 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
16771 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16772 INTEGER, INTENT(IN) :: root
16773 CLASS(mp_comm_type), INTENT(IN) :: comm
16774
16775 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dm2'
16776
16777 INTEGER :: handle
16778#if defined(__parallel)
16779 INTEGER :: ierr, sendcount
16780#endif
16781
16782 CALL mp_timeset(routinen, handle)
16783
16784#if defined(__parallel)
16785 sendcount = SIZE(sendbuf)
16786 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16787 recvbuf, recvcounts, displs, mpi_double_precision, &
16788 root, comm%handle, ierr)
16789 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16790 CALL add_perf(perf_id=4, &
16791 count=1, &
16792 msg_size=sendcount*real_8_size)
16793#else
16794 mark_used(recvcounts)
16795 mark_used(root)
16796 mark_used(comm)
16797 recvbuf(:, 1 + displs(1):) = sendbuf
16798#endif
16799 CALL mp_timestop(handle)
16800 END SUBROUTINE mp_gatherv_dm2
16801
16802! **************************************************************************************************
16803!> \brief Gathers data from all processes to one.
16804!> \param[in] sendbuf Data to send to root
16805!> \param[out] recvbuf Received data (on root)
16806!> \param[in] recvcounts Sizes of data received from processes
16807!> \param[in] displs Offsets of data received from processes
16808!> \param[in] comm Message passing environment identifier
16809!> \par Data length
16810!> Data can have different lengths
16811!> \par Offsets
16812!> Offsets start at 0
16813!> \par MPI mapping
16814!> mpi_gather
16815! **************************************************************************************************
16816 SUBROUTINE mp_gatherv_dm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
16817
16818 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
16819 REAL(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
16820 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16821 CLASS(mp_comm_type), INTENT(IN) :: comm
16822
16823 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_dm2_src'
16824
16825 INTEGER :: handle
16826#if defined(__parallel)
16827 INTEGER :: ierr, sendcount
16828#endif
16829
16830 CALL mp_timeset(routinen, handle)
16831
16832#if defined(__parallel)
16833 sendcount = SIZE(sendbuf)
16834 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_precision, &
16835 recvbuf, recvcounts, displs, mpi_double_precision, &
16836 comm%source, comm%handle, ierr)
16837 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16838 CALL add_perf(perf_id=4, &
16839 count=1, &
16840 msg_size=sendcount*real_8_size)
16841#else
16842 mark_used(recvcounts)
16843 mark_used(comm)
16844 recvbuf(:, 1 + displs(1):) = sendbuf
16845#endif
16846 CALL mp_timestop(handle)
16847 END SUBROUTINE mp_gatherv_dm2_src
16848
16849! **************************************************************************************************
16850!> \brief Gathers data from all processes to one.
16851!> \param[in] sendbuf Data to send to root
16852!> \param[out] recvbuf Received data (on root)
16853!> \param[in] recvcounts Sizes of data received from processes
16854!> \param[in] displs Offsets of data received from processes
16855!> \param[in] root Process which gathers the data
16856!> \param[in] comm Message passing environment identifier
16857!> \par Data length
16858!> Data can have different lengths
16859!> \par Offsets
16860!> Offsets start at 0
16861!> \par MPI mapping
16862!> mpi_gather
16863! **************************************************************************************************
16864 SUBROUTINE mp_igatherv_dv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
16865 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: sendbuf
16866 REAL(kind=real_8), DIMENSION(:), INTENT(OUT) :: recvbuf
16867 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
16868 INTEGER, INTENT(IN) :: sendcount, root
16869 CLASS(mp_comm_type), INTENT(IN) :: comm
16870 TYPE(mp_request_type), INTENT(OUT) :: request
16871
16872 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_dv'
16873
16874 INTEGER :: handle
16875#if defined(__parallel)
16876 INTEGER :: ierr
16877#endif
16878
16879 CALL mp_timeset(routinen, handle)
16880
16881#if defined(__parallel)
16882#if !defined(__GNUC__) || __GNUC__ >= 9
16883 cpassert(is_contiguous(sendbuf))
16884 cpassert(is_contiguous(recvbuf))
16885 cpassert(is_contiguous(recvcounts))
16886 cpassert(is_contiguous(displs))
16887#endif
16888 CALL mpi_igatherv(sendbuf, sendcount, mpi_double_precision, &
16889 recvbuf, recvcounts, displs, mpi_double_precision, &
16890 root, comm%handle, request%handle, ierr)
16891 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
16892 CALL add_perf(perf_id=24, &
16893 count=1, &
16894 msg_size=sendcount*real_8_size)
16895#else
16896 mark_used(sendcount)
16897 mark_used(recvcounts)
16898 mark_used(root)
16899 mark_used(comm)
16900 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
16901 request = mp_request_null
16902#endif
16903 CALL mp_timestop(handle)
16904 END SUBROUTINE mp_igatherv_dv
16905
16906! **************************************************************************************************
16907!> \brief Gathers a datum from all processes and all processes receive the
16908!> same data
16909!> \param[in] msgout Datum to send
16910!> \param[out] msgin Received data
16911!> \param[in] comm Message passing environment identifier
16912!> \par Data size
16913!> All processes send equal-sized data
16914!> \par MPI mapping
16915!> mpi_allgather
16916! **************************************************************************************************
16917 SUBROUTINE mp_allgather_d (msgout, msgin, comm)
16918 REAL(kind=real_8), INTENT(IN) :: msgout
16919 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
16920 CLASS(mp_comm_type), INTENT(IN) :: comm
16921
16922 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d'
16923
16924 INTEGER :: handle
16925#if defined(__parallel)
16926 INTEGER :: ierr, rcount, scount
16927#endif
16928
16929 CALL mp_timeset(routinen, handle)
16930
16931#if defined(__parallel)
16932 scount = 1
16933 rcount = 1
16934 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16935 msgin, rcount, mpi_double_precision, &
16936 comm%handle, ierr)
16937 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16938#else
16939 mark_used(comm)
16940 msgin = msgout
16941#endif
16942 CALL mp_timestop(handle)
16943 END SUBROUTINE mp_allgather_d
16944
16945! **************************************************************************************************
16946!> \brief Gathers a datum from all processes and all processes receive the
16947!> same data
16948!> \param[in] msgout Datum to send
16949!> \param[out] msgin Received data
16950!> \param[in] comm Message passing environment identifier
16951!> \par Data size
16952!> All processes send equal-sized data
16953!> \par MPI mapping
16954!> mpi_allgather
16955! **************************************************************************************************
16956 SUBROUTINE mp_allgather_d2(msgout, msgin, comm)
16957 REAL(kind=real_8), INTENT(IN) :: msgout
16958 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
16959 CLASS(mp_comm_type), INTENT(IN) :: comm
16960
16961 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d2'
16962
16963 INTEGER :: handle
16964#if defined(__parallel)
16965 INTEGER :: ierr, rcount, scount
16966#endif
16967
16968 CALL mp_timeset(routinen, handle)
16969
16970#if defined(__parallel)
16971 scount = 1
16972 rcount = 1
16973 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
16974 msgin, rcount, mpi_double_precision, &
16975 comm%handle, ierr)
16976 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
16977#else
16978 mark_used(comm)
16979 msgin = msgout
16980#endif
16981 CALL mp_timestop(handle)
16982 END SUBROUTINE mp_allgather_d2
16983
16984! **************************************************************************************************
16985!> \brief Gathers a datum from all processes and all processes receive the
16986!> same data
16987!> \param[in] msgout Datum to send
16988!> \param[out] msgin Received data
16989!> \param[in] comm Message passing environment identifier
16990!> \par Data size
16991!> All processes send equal-sized data
16992!> \par MPI mapping
16993!> mpi_allgather
16994! **************************************************************************************************
16995 SUBROUTINE mp_iallgather_d (msgout, msgin, comm, request)
16996 REAL(kind=real_8), INTENT(IN) :: msgout
16997 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
16998 CLASS(mp_comm_type), INTENT(IN) :: comm
16999 TYPE(mp_request_type), INTENT(OUT) :: request
17000
17001 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d'
17002
17003 INTEGER :: handle
17004#if defined(__parallel)
17005 INTEGER :: ierr, rcount, scount
17006#endif
17007
17008 CALL mp_timeset(routinen, handle)
17009
17010#if defined(__parallel)
17011#if !defined(__GNUC__) || __GNUC__ >= 9
17012 cpassert(is_contiguous(msgin))
17013#endif
17014 scount = 1
17015 rcount = 1
17016 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17017 msgin, rcount, mpi_double_precision, &
17018 comm%handle, request%handle, ierr)
17019 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17020#else
17021 mark_used(comm)
17022 msgin = msgout
17023 request = mp_request_null
17024#endif
17025 CALL mp_timestop(handle)
17026 END SUBROUTINE mp_iallgather_d
17027
17028! **************************************************************************************************
17029!> \brief Gathers vector data from all processes and all processes receive the
17030!> same data
17031!> \param[in] msgout Rank-1 data to send
17032!> \param[out] msgin Received data
17033!> \param[in] comm Message passing environment identifier
17034!> \par Data size
17035!> All processes send equal-sized data
17036!> \par Ranks
17037!> The last rank counts the processes
17038!> \par MPI mapping
17039!> mpi_allgather
17040! **************************************************************************************************
17041 SUBROUTINE mp_allgather_d12(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_d12'
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_d12
17068
17069! **************************************************************************************************
17070!> \brief Gathers matrix data from all processes and all processes receive the
17071!> same data
17072!> \param[in] msgout Rank-2 data to send
17073!> \param msgin ...
17074!> \param comm ...
17075!> \note see mp_allgather_d12
17076! **************************************************************************************************
17077 SUBROUTINE mp_allgather_d23(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_d23'
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_d23
17104
17105! **************************************************************************************************
17106!> \brief Gathers rank-3 data from all processes and all processes receive the
17107!> same data
17108!> \param[in] msgout Rank-3 data to send
17109!> \param msgin ...
17110!> \param comm ...
17111!> \note see mp_allgather_d12
17112! **************************************************************************************************
17113 SUBROUTINE mp_allgather_d34(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_d34'
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(:, :, :, 1) = msgout(:, :, :)
17137#endif
17138 CALL mp_timestop(handle)
17139 END SUBROUTINE mp_allgather_d34
17140
17141! **************************************************************************************************
17142!> \brief Gathers rank-2 data from all processes and all processes receive the
17143!> same data
17144!> \param[in] msgout Rank-2 data to send
17145!> \param msgin ...
17146!> \param comm ...
17147!> \note see mp_allgather_d12
17148! **************************************************************************************************
17149 SUBROUTINE mp_allgather_d22(msgout, msgin, comm)
17150 REAL(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
17151 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
17152 CLASS(mp_comm_type), INTENT(IN) :: comm
17153
17154 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_d22'
17155
17156 INTEGER :: handle
17157#if defined(__parallel)
17158 INTEGER :: ierr, rcount, scount
17159#endif
17160
17161 CALL mp_timeset(routinen, handle)
17162
17163#if defined(__parallel)
17164 scount = SIZE(msgout(:, :))
17165 rcount = scount
17166 CALL mpi_allgather(msgout, scount, mpi_double_precision, &
17167 msgin, rcount, mpi_double_precision, &
17168 comm%handle, ierr)
17169 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
17170#else
17171 mark_used(comm)
17172 msgin(:, :) = msgout(:, :)
17173#endif
17174 CALL mp_timestop(handle)
17175 END SUBROUTINE mp_allgather_d22
17176
17177! **************************************************************************************************
17178!> \brief Gathers rank-1 data from all processes and all processes receive the
17179!> same data
17180!> \param[in] msgout Rank-1 data to send
17181!> \param msgin ...
17182!> \param comm ...
17183!> \param request ...
17184!> \note see mp_allgather_d11
17185! **************************************************************************************************
17186 SUBROUTINE mp_iallgather_d11(msgout, msgin, comm, request)
17187 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17188 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17189 CLASS(mp_comm_type), INTENT(IN) :: comm
17190 TYPE(mp_request_type), INTENT(OUT) :: request
17191
17192 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d11'
17193
17194 INTEGER :: handle
17195#if defined(__parallel)
17196 INTEGER :: ierr, rcount, scount
17197#endif
17198
17199 CALL mp_timeset(routinen, handle)
17200
17201#if defined(__parallel)
17202#if !defined(__GNUC__) || __GNUC__ >= 9
17203 cpassert(is_contiguous(msgout))
17204 cpassert(is_contiguous(msgin))
17205#endif
17206 scount = SIZE(msgout(:))
17207 rcount = scount
17208 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17209 msgin, rcount, mpi_double_precision, &
17210 comm%handle, request%handle, ierr)
17211 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17212#else
17213 mark_used(comm)
17214 msgin = msgout
17215 request = mp_request_null
17216#endif
17217 CALL mp_timestop(handle)
17218 END SUBROUTINE mp_iallgather_d11
17219
17220! **************************************************************************************************
17221!> \brief Gathers rank-2 data from all processes and all processes receive the
17222!> same data
17223!> \param[in] msgout Rank-2 data to send
17224!> \param msgin ...
17225!> \param comm ...
17226!> \param request ...
17227!> \note see mp_allgather_d12
17228! **************************************************************************************************
17229 SUBROUTINE mp_iallgather_d13(msgout, msgin, comm, request)
17230 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17231 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
17232 CLASS(mp_comm_type), INTENT(IN) :: comm
17233 TYPE(mp_request_type), INTENT(OUT) :: request
17234
17235 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d13'
17236
17237 INTEGER :: handle
17238#if defined(__parallel)
17239 INTEGER :: ierr, rcount, scount
17240#endif
17241
17242 CALL mp_timeset(routinen, handle)
17243
17244#if defined(__parallel)
17245#if !defined(__GNUC__) || __GNUC__ >= 9
17246 cpassert(is_contiguous(msgout))
17247 cpassert(is_contiguous(msgin))
17248#endif
17249
17250 scount = SIZE(msgout(:))
17251 rcount = scount
17252 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17253 msgin, rcount, mpi_double_precision, &
17254 comm%handle, request%handle, ierr)
17255 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17256#else
17257 mark_used(comm)
17258 msgin(:, 1, 1) = msgout(:)
17259 request = mp_request_null
17260#endif
17261 CALL mp_timestop(handle)
17262 END SUBROUTINE mp_iallgather_d13
17263
17264! **************************************************************************************************
17265!> \brief Gathers rank-2 data from all processes and all processes receive the
17266!> same data
17267!> \param[in] msgout Rank-2 data to send
17268!> \param msgin ...
17269!> \param comm ...
17270!> \param request ...
17271!> \note see mp_allgather_d12
17272! **************************************************************************************************
17273 SUBROUTINE mp_iallgather_d22(msgout, msgin, comm, request)
17274 REAL(kind=real_8), INTENT(IN) :: msgout(:, :)
17275 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :)
17276 CLASS(mp_comm_type), INTENT(IN) :: comm
17277 TYPE(mp_request_type), INTENT(OUT) :: request
17278
17279 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d22'
17280
17281 INTEGER :: handle
17282#if defined(__parallel)
17283 INTEGER :: ierr, rcount, scount
17284#endif
17285
17286 CALL mp_timeset(routinen, handle)
17287
17288#if defined(__parallel)
17289#if !defined(__GNUC__) || __GNUC__ >= 9
17290 cpassert(is_contiguous(msgout))
17291 cpassert(is_contiguous(msgin))
17292#endif
17293
17294 scount = SIZE(msgout(:, :))
17295 rcount = scount
17296 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17297 msgin, rcount, mpi_double_precision, &
17298 comm%handle, request%handle, ierr)
17299 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17300#else
17301 mark_used(comm)
17302 msgin(:, :) = msgout(:, :)
17303 request = mp_request_null
17304#endif
17305 CALL mp_timestop(handle)
17306 END SUBROUTINE mp_iallgather_d22
17307
17308! **************************************************************************************************
17309!> \brief Gathers rank-2 data from all processes and all processes receive the
17310!> same data
17311!> \param[in] msgout Rank-2 data to send
17312!> \param msgin ...
17313!> \param comm ...
17314!> \param request ...
17315!> \note see mp_allgather_d12
17316! **************************************************************************************************
17317 SUBROUTINE mp_iallgather_d24(msgout, msgin, comm, request)
17318 REAL(kind=real_8), INTENT(IN) :: msgout(:, :)
17319 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :, :)
17320 CLASS(mp_comm_type), INTENT(IN) :: comm
17321 TYPE(mp_request_type), INTENT(OUT) :: request
17322
17323 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d24'
17324
17325 INTEGER :: handle
17326#if defined(__parallel)
17327 INTEGER :: ierr, rcount, scount
17328#endif
17329
17330 CALL mp_timeset(routinen, handle)
17331
17332#if defined(__parallel)
17333#if !defined(__GNUC__) || __GNUC__ >= 9
17334 cpassert(is_contiguous(msgout))
17335 cpassert(is_contiguous(msgin))
17336#endif
17337
17338 scount = SIZE(msgout(:, :))
17339 rcount = scount
17340 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17341 msgin, rcount, mpi_double_precision, &
17342 comm%handle, request%handle, ierr)
17343 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17344#else
17345 mark_used(comm)
17346 msgin(:, :, 1, 1) = msgout(:, :)
17347 request = mp_request_null
17348#endif
17349 CALL mp_timestop(handle)
17350 END SUBROUTINE mp_iallgather_d24
17351
17352! **************************************************************************************************
17353!> \brief Gathers rank-3 data from all processes and all processes receive the
17354!> same data
17355!> \param[in] msgout Rank-3 data to send
17356!> \param msgin ...
17357!> \param comm ...
17358!> \param request ...
17359!> \note see mp_allgather_d12
17360! **************************************************************************************************
17361 SUBROUTINE mp_iallgather_d33(msgout, msgin, comm, request)
17362 REAL(kind=real_8), INTENT(IN) :: msgout(:, :, :)
17363 REAL(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
17364 CLASS(mp_comm_type), INTENT(IN) :: comm
17365 TYPE(mp_request_type), INTENT(OUT) :: request
17366
17367 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_d33'
17368
17369 INTEGER :: handle
17370#if defined(__parallel)
17371 INTEGER :: ierr, rcount, scount
17372#endif
17373
17374 CALL mp_timeset(routinen, handle)
17375
17376#if defined(__parallel)
17377#if !defined(__GNUC__) || __GNUC__ >= 9
17378 cpassert(is_contiguous(msgout))
17379 cpassert(is_contiguous(msgin))
17380#endif
17381
17382 scount = SIZE(msgout(:, :, :))
17383 rcount = scount
17384 CALL mpi_iallgather(msgout, scount, mpi_double_precision, &
17385 msgin, rcount, mpi_double_precision, &
17386 comm%handle, request%handle, ierr)
17387 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
17388#else
17389 mark_used(comm)
17390 msgin(:, :, :) = msgout(:, :, :)
17391 request = mp_request_null
17392#endif
17393 CALL mp_timestop(handle)
17394 END SUBROUTINE mp_iallgather_d33
17395
17396! **************************************************************************************************
17397!> \brief Gathers vector data from all processes and all processes receive the
17398!> same data
17399!> \param[in] msgout Rank-1 data to send
17400!> \param[out] msgin Received data
17401!> \param[in] rcount Size of sent data for every process
17402!> \param[in] rdispl Offset of sent data for every process
17403!> \param[in] comm Message passing environment identifier
17404!> \par Data size
17405!> Processes can send different-sized data
17406!> \par Ranks
17407!> The last rank counts the processes
17408!> \par Offsets
17409!> Offsets are from 0
17410!> \par MPI mapping
17411!> mpi_allgather
17412! **************************************************************************************************
17413 SUBROUTINE mp_allgatherv_dv(msgout, msgin, rcount, rdispl, comm)
17414 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
17415 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17416 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17417 CLASS(mp_comm_type), INTENT(IN) :: comm
17418
17419 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_dv'
17420
17421 INTEGER :: handle
17422#if defined(__parallel)
17423 INTEGER :: ierr, scount
17424#endif
17425
17426 CALL mp_timeset(routinen, handle)
17427
17428#if defined(__parallel)
17429 scount = SIZE(msgout)
17430 CALL mpi_allgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17431 rdispl, mpi_double_precision, comm%handle, ierr)
17432 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
17433#else
17434 mark_used(rcount)
17435 mark_used(rdispl)
17436 mark_used(comm)
17437 msgin = msgout
17438#endif
17439 CALL mp_timestop(handle)
17440 END SUBROUTINE mp_allgatherv_dv
17441
17442! **************************************************************************************************
17443!> \brief Gathers vector data from all processes and all processes receive the
17444!> same data
17445!> \param[in] msgout Rank-1 data to send
17446!> \param[out] msgin Received data
17447!> \param[in] rcount Size of sent data for every process
17448!> \param[in] rdispl Offset of sent data for every process
17449!> \param[in] comm Message passing environment identifier
17450!> \par Data size
17451!> Processes can send different-sized data
17452!> \par Ranks
17453!> The last rank counts the processes
17454!> \par Offsets
17455!> Offsets are from 0
17456!> \par MPI mapping
17457!> mpi_allgather
17458! **************************************************************************************************
17459 SUBROUTINE mp_allgatherv_dm2(msgout, msgin, rcount, rdispl, comm)
17460 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
17461 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
17462 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17463 CLASS(mp_comm_type), INTENT(IN) :: comm
17464
17465 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_dv'
17466
17467 INTEGER :: handle
17468#if defined(__parallel)
17469 INTEGER :: ierr, scount
17470#endif
17471
17472 CALL mp_timeset(routinen, handle)
17473
17474#if defined(__parallel)
17475 scount = SIZE(msgout)
17476 CALL mpi_allgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17477 rdispl, mpi_double_precision, comm%handle, ierr)
17478 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
17479#else
17480 mark_used(rcount)
17481 mark_used(rdispl)
17482 mark_used(comm)
17483 msgin = msgout
17484#endif
17485 CALL mp_timestop(handle)
17486 END SUBROUTINE mp_allgatherv_dm2
17487
17488! **************************************************************************************************
17489!> \brief Gathers vector data from all processes and all processes receive the
17490!> same data
17491!> \param[in] msgout Rank-1 data to send
17492!> \param[out] msgin Received data
17493!> \param[in] rcount Size of sent data for every process
17494!> \param[in] rdispl Offset of sent data for every process
17495!> \param[in] comm Message passing environment identifier
17496!> \par Data size
17497!> Processes can send different-sized data
17498!> \par Ranks
17499!> The last rank counts the processes
17500!> \par Offsets
17501!> Offsets are from 0
17502!> \par MPI mapping
17503!> mpi_allgather
17504! **************************************************************************************************
17505 SUBROUTINE mp_iallgatherv_dv(msgout, msgin, rcount, rdispl, comm, request)
17506 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17507 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17508 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
17509 CLASS(mp_comm_type), INTENT(IN) :: comm
17510 TYPE(mp_request_type), INTENT(OUT) :: request
17511
17512 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_dv'
17513
17514 INTEGER :: handle
17515#if defined(__parallel)
17516 INTEGER :: ierr, scount, rsize
17517#endif
17518
17519 CALL mp_timeset(routinen, handle)
17520
17521#if defined(__parallel)
17522#if !defined(__GNUC__) || __GNUC__ >= 9
17523 cpassert(is_contiguous(msgout))
17524 cpassert(is_contiguous(msgin))
17525 cpassert(is_contiguous(rcount))
17526 cpassert(is_contiguous(rdispl))
17527#endif
17528
17529 scount = SIZE(msgout)
17530 rsize = SIZE(rcount)
17531 CALL mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, &
17532 rdispl, comm, request, ierr)
17533 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
17534#else
17535 mark_used(rcount)
17536 mark_used(rdispl)
17537 mark_used(comm)
17538 msgin = msgout
17539 request = mp_request_null
17540#endif
17541 CALL mp_timestop(handle)
17542 END SUBROUTINE mp_iallgatherv_dv
17543
17544! **************************************************************************************************
17545!> \brief Gathers vector data from all processes and all processes receive the
17546!> same data
17547!> \param[in] msgout Rank-1 data to send
17548!> \param[out] msgin Received data
17549!> \param[in] rcount Size of sent data for every process
17550!> \param[in] rdispl Offset of sent data for every process
17551!> \param[in] comm Message passing environment identifier
17552!> \par Data size
17553!> Processes can send different-sized data
17554!> \par Ranks
17555!> The last rank counts the processes
17556!> \par Offsets
17557!> Offsets are from 0
17558!> \par MPI mapping
17559!> mpi_allgather
17560! **************************************************************************************************
17561 SUBROUTINE mp_iallgatherv_dv2(msgout, msgin, rcount, rdispl, comm, request)
17562 REAL(kind=real_8), INTENT(IN) :: msgout(:)
17563 REAL(kind=real_8), INTENT(OUT) :: msgin(:)
17564 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
17565 CLASS(mp_comm_type), INTENT(IN) :: comm
17566 TYPE(mp_request_type), INTENT(OUT) :: request
17567
17568 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_dv2'
17569
17570 INTEGER :: handle
17571#if defined(__parallel)
17572 INTEGER :: ierr, scount, rsize
17573#endif
17574
17575 CALL mp_timeset(routinen, handle)
17576
17577#if defined(__parallel)
17578#if !defined(__GNUC__) || __GNUC__ >= 9
17579 cpassert(is_contiguous(msgout))
17580 cpassert(is_contiguous(msgin))
17581 cpassert(is_contiguous(rcount))
17582 cpassert(is_contiguous(rdispl))
17583#endif
17584
17585 scount = SIZE(msgout)
17586 rsize = SIZE(rcount)
17587 CALL mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, &
17588 rdispl, comm, request, ierr)
17589 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
17590#else
17591 mark_used(rcount)
17592 mark_used(rdispl)
17593 mark_used(comm)
17594 msgin = msgout
17595 request = mp_request_null
17596#endif
17597 CALL mp_timestop(handle)
17598 END SUBROUTINE mp_iallgatherv_dv2
17599
17600! **************************************************************************************************
17601!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
17602!> the issue is with the rank of rcount and rdispl
17603!> \param count ...
17604!> \param array_of_requests ...
17605!> \param array_of_statuses ...
17606!> \param ierr ...
17607!> \author Alfio Lazzaro
17608! **************************************************************************************************
17609#if defined(__parallel)
17610 SUBROUTINE mp_iallgatherv_dv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
17611 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
17612 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17613 INTEGER, INTENT(IN) :: rsize
17614 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
17615 CLASS(mp_comm_type), INTENT(IN) :: comm
17616 TYPE(mp_request_type), INTENT(OUT) :: request
17617 INTEGER, INTENT(INOUT) :: ierr
17618
17619 CALL mpi_iallgatherv(msgout, scount, mpi_double_precision, msgin, rcount, &
17620 rdispl, mpi_double_precision, comm%handle, request%handle, ierr)
17621
17622 END SUBROUTINE mp_iallgatherv_dv_internal
17623#endif
17624
17625! **************************************************************************************************
17626!> \brief Sums a vector and partitions the result among processes
17627!> \param[in] msgout Data to sum
17628!> \param[out] msgin Received portion of summed data
17629!> \param[in] rcount Partition sizes of the summed data for
17630!> every process
17631!> \param[in] comm Message passing environment identifier
17632! **************************************************************************************************
17633 SUBROUTINE mp_sum_scatter_dv(msgout, msgin, rcount, comm)
17634 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
17635 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
17636 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
17637 CLASS(mp_comm_type), INTENT(IN) :: comm
17638
17639 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_dv'
17640
17641 INTEGER :: handle
17642#if defined(__parallel)
17643 INTEGER :: ierr
17644#endif
17645
17646 CALL mp_timeset(routinen, handle)
17647
17648#if defined(__parallel)
17649 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_double_precision, mpi_sum, &
17650 comm%handle, ierr)
17651 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
17652
17653 CALL add_perf(perf_id=3, count=1, &
17654 msg_size=rcount(1)*2*real_8_size)
17655#else
17656 mark_used(rcount)
17657 mark_used(comm)
17658 msgin = msgout(:, 1)
17659#endif
17660 CALL mp_timestop(handle)
17661 END SUBROUTINE mp_sum_scatter_dv
17662
17663! **************************************************************************************************
17664!> \brief Sends and receives vector data
17665!> \param[in] msgin Data to send
17666!> \param[in] dest Process to send data to
17667!> \param[out] msgout Received data
17668!> \param[in] source Process from which to receive
17669!> \param[in] comm Message passing environment identifier
17670!> \param[in] tag Send and recv tag (default: 0)
17671! **************************************************************************************************
17672 SUBROUTINE mp_sendrecv_d (msgin, dest, msgout, source, comm, tag)
17673 REAL(kind=real_8), INTENT(IN) :: msgin
17674 INTEGER, INTENT(IN) :: dest
17675 REAL(kind=real_8), INTENT(OUT) :: msgout
17676 INTEGER, INTENT(IN) :: source
17677 CLASS(mp_comm_type), INTENT(IN) :: comm
17678 INTEGER, INTENT(IN), OPTIONAL :: tag
17679
17680 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_d'
17681
17682 INTEGER :: handle
17683#if defined(__parallel)
17684 INTEGER :: ierr, msglen_in, msglen_out, &
17685 recv_tag, send_tag
17686#endif
17687
17688 CALL mp_timeset(routinen, handle)
17689
17690#if defined(__parallel)
17691 msglen_in = 1
17692 msglen_out = 1
17693 send_tag = 0 ! cannot think of something better here, this might be dangerous
17694 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17695 IF (PRESENT(tag)) THEN
17696 send_tag = tag
17697 recv_tag = tag
17698 END IF
17699 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17700 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17701 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17702 CALL add_perf(perf_id=7, count=1, &
17703 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17704#else
17705 mark_used(dest)
17706 mark_used(source)
17707 mark_used(comm)
17708 mark_used(tag)
17709 msgout = msgin
17710#endif
17711 CALL mp_timestop(handle)
17712 END SUBROUTINE mp_sendrecv_d
17713
17714! **************************************************************************************************
17715!> \brief Sends and receives vector data
17716!> \param[in] msgin Data to send
17717!> \param[in] dest Process to send data to
17718!> \param[out] msgout Received data
17719!> \param[in] source Process from which to receive
17720!> \param[in] comm Message passing environment identifier
17721!> \param[in] tag Send and recv tag (default: 0)
17722! **************************************************************************************************
17723 SUBROUTINE mp_sendrecv_dv(msgin, dest, msgout, source, comm, tag)
17724 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
17725 INTEGER, INTENT(IN) :: dest
17726 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
17727 INTEGER, INTENT(IN) :: source
17728 CLASS(mp_comm_type), INTENT(IN) :: comm
17729 INTEGER, INTENT(IN), OPTIONAL :: tag
17730
17731 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dv'
17732
17733 INTEGER :: handle
17734#if defined(__parallel)
17735 INTEGER :: ierr, msglen_in, msglen_out, &
17736 recv_tag, send_tag
17737#endif
17738
17739 CALL mp_timeset(routinen, handle)
17740
17741#if defined(__parallel)
17742 msglen_in = SIZE(msgin)
17743 msglen_out = SIZE(msgout)
17744 send_tag = 0 ! cannot think of something better here, this might be dangerous
17745 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17746 IF (PRESENT(tag)) THEN
17747 send_tag = tag
17748 recv_tag = tag
17749 END IF
17750 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17751 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17752 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17753 CALL add_perf(perf_id=7, count=1, &
17754 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17755#else
17756 mark_used(dest)
17757 mark_used(source)
17758 mark_used(comm)
17759 mark_used(tag)
17760 msgout = msgin
17761#endif
17762 CALL mp_timestop(handle)
17763 END SUBROUTINE mp_sendrecv_dv
17764
17765! **************************************************************************************************
17766!> \brief Sends and receives matrix data
17767!> \param msgin ...
17768!> \param dest ...
17769!> \param msgout ...
17770!> \param source ...
17771!> \param comm ...
17772!> \param tag ...
17773!> \note see mp_sendrecv_dv
17774! **************************************************************************************************
17775 SUBROUTINE mp_sendrecv_dm2(msgin, dest, msgout, source, comm, tag)
17776 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
17777 INTEGER, INTENT(IN) :: dest
17778 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
17779 INTEGER, INTENT(IN) :: source
17780 CLASS(mp_comm_type), INTENT(IN) :: comm
17781 INTEGER, INTENT(IN), OPTIONAL :: tag
17782
17783 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm2'
17784
17785 INTEGER :: handle
17786#if defined(__parallel)
17787 INTEGER :: ierr, msglen_in, msglen_out, &
17788 recv_tag, send_tag
17789#endif
17790
17791 CALL mp_timeset(routinen, handle)
17792
17793#if defined(__parallel)
17794 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
17795 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
17796 send_tag = 0 ! cannot think of something better here, this might be dangerous
17797 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17798 IF (PRESENT(tag)) THEN
17799 send_tag = tag
17800 recv_tag = tag
17801 END IF
17802 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17803 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17804 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17805 CALL add_perf(perf_id=7, count=1, &
17806 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17807#else
17808 mark_used(dest)
17809 mark_used(source)
17810 mark_used(comm)
17811 mark_used(tag)
17812 msgout = msgin
17813#endif
17814 CALL mp_timestop(handle)
17815 END SUBROUTINE mp_sendrecv_dm2
17816
17817! **************************************************************************************************
17818!> \brief Sends and receives rank-3 data
17819!> \param msgin ...
17820!> \param dest ...
17821!> \param msgout ...
17822!> \param source ...
17823!> \param comm ...
17824!> \note see mp_sendrecv_dv
17825! **************************************************************************************************
17826 SUBROUTINE mp_sendrecv_dm3(msgin, dest, msgout, source, comm, tag)
17827 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
17828 INTEGER, INTENT(IN) :: dest
17829 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
17830 INTEGER, INTENT(IN) :: source
17831 CLASS(mp_comm_type), INTENT(IN) :: comm
17832 INTEGER, INTENT(IN), OPTIONAL :: tag
17833
17834 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm3'
17835
17836 INTEGER :: handle
17837#if defined(__parallel)
17838 INTEGER :: ierr, msglen_in, msglen_out, &
17839 recv_tag, send_tag
17840#endif
17841
17842 CALL mp_timeset(routinen, handle)
17843
17844#if defined(__parallel)
17845 msglen_in = SIZE(msgin)
17846 msglen_out = SIZE(msgout)
17847 send_tag = 0 ! cannot think of something better here, this might be dangerous
17848 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17849 IF (PRESENT(tag)) THEN
17850 send_tag = tag
17851 recv_tag = tag
17852 END IF
17853 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17854 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17855 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17856 CALL add_perf(perf_id=7, count=1, &
17857 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17858#else
17859 mark_used(dest)
17860 mark_used(source)
17861 mark_used(comm)
17862 mark_used(tag)
17863 msgout = msgin
17864#endif
17865 CALL mp_timestop(handle)
17866 END SUBROUTINE mp_sendrecv_dm3
17867
17868! **************************************************************************************************
17869!> \brief Sends and receives rank-4 data
17870!> \param msgin ...
17871!> \param dest ...
17872!> \param msgout ...
17873!> \param source ...
17874!> \param comm ...
17875!> \note see mp_sendrecv_dv
17876! **************************************************************************************************
17877 SUBROUTINE mp_sendrecv_dm4(msgin, dest, msgout, source, comm, tag)
17878 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
17879 INTEGER, INTENT(IN) :: dest
17880 REAL(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
17881 INTEGER, INTENT(IN) :: source
17882 CLASS(mp_comm_type), INTENT(IN) :: comm
17883 INTEGER, INTENT(IN), OPTIONAL :: tag
17884
17885 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_dm4'
17886
17887 INTEGER :: handle
17888#if defined(__parallel)
17889 INTEGER :: ierr, msglen_in, msglen_out, &
17890 recv_tag, send_tag
17891#endif
17892
17893 CALL mp_timeset(routinen, handle)
17894
17895#if defined(__parallel)
17896 msglen_in = SIZE(msgin)
17897 msglen_out = SIZE(msgout)
17898 send_tag = 0 ! cannot think of something better here, this might be dangerous
17899 recv_tag = 0 ! cannot think of something better here, this might be dangerous
17900 IF (PRESENT(tag)) THEN
17901 send_tag = tag
17902 recv_tag = tag
17903 END IF
17904 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_precision, dest, send_tag, msgout, &
17905 msglen_out, mpi_double_precision, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
17906 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
17907 CALL add_perf(perf_id=7, count=1, &
17908 msg_size=(msglen_in + msglen_out)*real_8_size/2)
17909#else
17910 mark_used(dest)
17911 mark_used(source)
17912 mark_used(comm)
17913 mark_used(tag)
17914 msgout = msgin
17915#endif
17916 CALL mp_timestop(handle)
17917 END SUBROUTINE mp_sendrecv_dm4
17918
17919! **************************************************************************************************
17920!> \brief Non-blocking send and receive of a scalar
17921!> \param[in] msgin Scalar data to send
17922!> \param[in] dest Which process to send to
17923!> \param[out] msgout Receive data into this pointer
17924!> \param[in] source Process to receive from
17925!> \param[in] comm Message passing environment identifier
17926!> \param[out] send_request Request handle for the send
17927!> \param[out] recv_request Request handle for the receive
17928!> \param[in] tag (optional) tag to differentiate requests
17929!> \par Implementation
17930!> Calls mpi_isend and mpi_irecv.
17931!> \par History
17932!> 02.2005 created [Alfio Lazzaro]
17933! **************************************************************************************************
17934 SUBROUTINE mp_isendrecv_d (msgin, dest, msgout, source, comm, send_request, &
17935 recv_request, tag)
17936 REAL(kind=real_8), INTENT(IN) :: msgin
17937 INTEGER, INTENT(IN) :: dest
17938 REAL(kind=real_8), INTENT(INOUT) :: msgout
17939 INTEGER, INTENT(IN) :: source
17940 CLASS(mp_comm_type), INTENT(IN) :: comm
17941 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
17942 INTEGER, INTENT(in), OPTIONAL :: tag
17943
17944 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_d'
17945
17946 INTEGER :: handle
17947#if defined(__parallel)
17948 INTEGER :: ierr, my_tag
17949#endif
17950
17951 CALL mp_timeset(routinen, handle)
17952
17953#if defined(__parallel)
17954 my_tag = 0
17955 IF (PRESENT(tag)) my_tag = tag
17956
17957 CALL mpi_irecv(msgout, 1, mpi_double_precision, source, my_tag, &
17958 comm%handle, recv_request%handle, ierr)
17959 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
17960
17961 CALL mpi_isend(msgin, 1, mpi_double_precision, dest, my_tag, &
17962 comm%handle, send_request%handle, ierr)
17963 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
17964
17965 CALL add_perf(perf_id=8, count=1, msg_size=2*real_8_size)
17966#else
17967 mark_used(dest)
17968 mark_used(source)
17969 mark_used(comm)
17970 mark_used(tag)
17971 send_request = mp_request_null
17972 recv_request = mp_request_null
17973 msgout = msgin
17974#endif
17975 CALL mp_timestop(handle)
17976 END SUBROUTINE mp_isendrecv_d
17977
17978! **************************************************************************************************
17979!> \brief Non-blocking send and receive of a vector
17980!> \param[in] msgin Vector data to send
17981!> \param[in] dest Which process to send to
17982!> \param[out] msgout Receive data into this pointer
17983!> \param[in] source Process to receive from
17984!> \param[in] comm Message passing environment identifier
17985!> \param[out] send_request Request handle for the send
17986!> \param[out] recv_request Request handle for the receive
17987!> \param[in] tag (optional) tag to differentiate requests
17988!> \par Implementation
17989!> Calls mpi_isend and mpi_irecv.
17990!> \par History
17991!> 11.2004 created [Joost VandeVondele]
17992!> \note
17993!> arrays can be pointers or assumed shape, but they must be contiguous!
17994! **************************************************************************************************
17995 SUBROUTINE mp_isendrecv_dv(msgin, dest, msgout, source, comm, send_request, &
17996 recv_request, tag)
17997 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
17998 INTEGER, INTENT(IN) :: dest
17999 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
18000 INTEGER, INTENT(IN) :: source
18001 CLASS(mp_comm_type), INTENT(IN) :: comm
18002 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
18003 INTEGER, INTENT(in), OPTIONAL :: tag
18004
18005 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_dv'
18006
18007 INTEGER :: handle
18008#if defined(__parallel)
18009 INTEGER :: ierr, msglen, my_tag
18010 REAL(kind=real_8) :: foo
18011#endif
18012
18013 CALL mp_timeset(routinen, handle)
18014
18015#if defined(__parallel)
18016#if !defined(__GNUC__) || __GNUC__ >= 9
18017 cpassert(is_contiguous(msgout))
18018 cpassert(is_contiguous(msgin))
18019#endif
18020
18021 my_tag = 0
18022 IF (PRESENT(tag)) my_tag = tag
18023
18024 msglen = SIZE(msgout, 1)
18025 IF (msglen > 0) THEN
18026 CALL mpi_irecv(msgout(1), msglen, mpi_double_precision, source, my_tag, &
18027 comm%handle, recv_request%handle, ierr)
18028 ELSE
18029 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18030 comm%handle, recv_request%handle, ierr)
18031 END IF
18032 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18033
18034 msglen = SIZE(msgin, 1)
18035 IF (msglen > 0) THEN
18036 CALL mpi_isend(msgin(1), msglen, mpi_double_precision, dest, my_tag, &
18037 comm%handle, send_request%handle, ierr)
18038 ELSE
18039 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18040 comm%handle, send_request%handle, ierr)
18041 END IF
18042 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18043
18044 msglen = (msglen + SIZE(msgout, 1) + 1)/2
18045 CALL add_perf(perf_id=8, count=1, msg_size=msglen*real_8_size)
18046#else
18047 mark_used(dest)
18048 mark_used(source)
18049 mark_used(comm)
18050 mark_used(tag)
18051 send_request = mp_request_null
18052 recv_request = mp_request_null
18053 msgout = msgin
18054#endif
18055 CALL mp_timestop(handle)
18056 END SUBROUTINE mp_isendrecv_dv
18057
18058! **************************************************************************************************
18059!> \brief Non-blocking send of vector data
18060!> \param msgin ...
18061!> \param dest ...
18062!> \param comm ...
18063!> \param request ...
18064!> \param tag ...
18065!> \par History
18066!> 08.2003 created [f&j]
18067!> \note see mp_isendrecv_dv
18068!> \note
18069!> arrays can be pointers or assumed shape, but they must be contiguous!
18070! **************************************************************************************************
18071 SUBROUTINE mp_isend_dv(msgin, dest, comm, request, tag)
18072 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
18073 INTEGER, INTENT(IN) :: dest
18074 CLASS(mp_comm_type), INTENT(IN) :: comm
18075 TYPE(mp_request_type), INTENT(out) :: request
18076 INTEGER, INTENT(in), OPTIONAL :: tag
18077
18078 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dv'
18079
18080 INTEGER :: handle, ierr
18081#if defined(__parallel)
18082 INTEGER :: msglen, my_tag
18083 REAL(kind=real_8) :: foo(1)
18084#endif
18085
18086 CALL mp_timeset(routinen, handle)
18087
18088#if defined(__parallel)
18089#if !defined(__GNUC__) || __GNUC__ >= 9
18090 cpassert(is_contiguous(msgin))
18091#endif
18092 my_tag = 0
18093 IF (PRESENT(tag)) my_tag = tag
18094
18095 msglen = SIZE(msgin)
18096 IF (msglen > 0) THEN
18097 CALL mpi_isend(msgin(1), msglen, mpi_double_precision, dest, my_tag, &
18098 comm%handle, request%handle, ierr)
18099 ELSE
18100 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18101 comm%handle, request%handle, ierr)
18102 END IF
18103 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18104
18105 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18106#else
18107 mark_used(msgin)
18108 mark_used(dest)
18109 mark_used(comm)
18110 mark_used(request)
18111 mark_used(tag)
18112 ierr = 1
18113 request = mp_request_null
18114 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18115#endif
18116 CALL mp_timestop(handle)
18117 END SUBROUTINE mp_isend_dv
18118
18119! **************************************************************************************************
18120!> \brief Non-blocking send of matrix data
18121!> \param msgin ...
18122!> \param dest ...
18123!> \param comm ...
18124!> \param request ...
18125!> \param tag ...
18126!> \par History
18127!> 2009-11-25 [UB] Made type-generic for templates
18128!> \author fawzi
18129!> \note see mp_isendrecv_dv
18130!> \note see mp_isend_dv
18131!> \note
18132!> arrays can be pointers or assumed shape, but they must be contiguous!
18133! **************************************************************************************************
18134 SUBROUTINE mp_isend_dm2(msgin, dest, comm, request, tag)
18135 REAL(kind=real_8), DIMENSION(:, :), INTENT(IN) :: msgin
18136 INTEGER, INTENT(IN) :: dest
18137 CLASS(mp_comm_type), INTENT(IN) :: comm
18138 TYPE(mp_request_type), INTENT(out) :: request
18139 INTEGER, INTENT(in), OPTIONAL :: tag
18140
18141 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm2'
18142
18143 INTEGER :: handle, ierr
18144#if defined(__parallel)
18145 INTEGER :: msglen, my_tag
18146 REAL(kind=real_8) :: foo(1)
18147#endif
18148
18149 CALL mp_timeset(routinen, handle)
18150
18151#if defined(__parallel)
18152#if !defined(__GNUC__) || __GNUC__ >= 9
18153 cpassert(is_contiguous(msgin))
18154#endif
18155
18156 my_tag = 0
18157 IF (PRESENT(tag)) my_tag = tag
18158
18159 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
18160 IF (msglen > 0) THEN
18161 CALL mpi_isend(msgin(1, 1), msglen, mpi_double_precision, dest, my_tag, &
18162 comm%handle, request%handle, ierr)
18163 ELSE
18164 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18165 comm%handle, request%handle, ierr)
18166 END IF
18167 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18168
18169 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18170#else
18171 mark_used(msgin)
18172 mark_used(dest)
18173 mark_used(comm)
18174 mark_used(request)
18175 mark_used(tag)
18176 ierr = 1
18177 request = mp_request_null
18178 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18179#endif
18180 CALL mp_timestop(handle)
18181 END SUBROUTINE mp_isend_dm2
18182
18183! **************************************************************************************************
18184!> \brief Non-blocking send of rank-3 data
18185!> \param msgin ...
18186!> \param dest ...
18187!> \param comm ...
18188!> \param request ...
18189!> \param tag ...
18190!> \par History
18191!> 9.2008 added _rm3 subroutine [Iain Bethune]
18192!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
18193!> 2009-11-25 [UB] Made type-generic for templates
18194!> \author fawzi
18195!> \note see mp_isendrecv_dv
18196!> \note see mp_isend_dv
18197!> \note
18198!> arrays can be pointers or assumed shape, but they must be contiguous!
18199! **************************************************************************************************
18200 SUBROUTINE mp_isend_dm3(msgin, dest, comm, request, tag)
18201 REAL(kind=real_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
18202 INTEGER, INTENT(IN) :: dest
18203 CLASS(mp_comm_type), INTENT(IN) :: comm
18204 TYPE(mp_request_type), INTENT(out) :: request
18205 INTEGER, INTENT(in), OPTIONAL :: tag
18206
18207 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm3'
18208
18209 INTEGER :: handle, ierr
18210#if defined(__parallel)
18211 INTEGER :: msglen, my_tag
18212 REAL(kind=real_8) :: foo(1)
18213#endif
18214
18215 CALL mp_timeset(routinen, handle)
18216
18217#if defined(__parallel)
18218#if !defined(__GNUC__) || __GNUC__ >= 9
18219 cpassert(is_contiguous(msgin))
18220#endif
18221
18222 my_tag = 0
18223 IF (PRESENT(tag)) my_tag = tag
18224
18225 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
18226 IF (msglen > 0) THEN
18227 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_double_precision, dest, my_tag, &
18228 comm%handle, request%handle, ierr)
18229 ELSE
18230 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18231 comm%handle, request%handle, ierr)
18232 END IF
18233 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18234
18235 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18236#else
18237 mark_used(msgin)
18238 mark_used(dest)
18239 mark_used(comm)
18240 mark_used(request)
18241 mark_used(tag)
18242 ierr = 1
18243 request = mp_request_null
18244 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18245#endif
18246 CALL mp_timestop(handle)
18247 END SUBROUTINE mp_isend_dm3
18248
18249! **************************************************************************************************
18250!> \brief Non-blocking send of rank-4 data
18251!> \param msgin the input message
18252!> \param dest the destination processor
18253!> \param comm the communicator object
18254!> \param request the communication request id
18255!> \param tag the message tag
18256!> \par History
18257!> 2.2016 added _dm4 subroutine [Nico Holmberg]
18258!> \author fawzi
18259!> \note see mp_isend_dv
18260!> \note
18261!> arrays can be pointers or assumed shape, but they must be contiguous!
18262! **************************************************************************************************
18263 SUBROUTINE mp_isend_dm4(msgin, dest, comm, request, tag)
18264 REAL(kind=real_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
18265 INTEGER, INTENT(IN) :: dest
18266 CLASS(mp_comm_type), INTENT(IN) :: comm
18267 TYPE(mp_request_type), INTENT(out) :: request
18268 INTEGER, INTENT(in), OPTIONAL :: tag
18269
18270 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_dm4'
18271
18272 INTEGER :: handle, ierr
18273#if defined(__parallel)
18274 INTEGER :: msglen, my_tag
18275 REAL(kind=real_8) :: foo(1)
18276#endif
18277
18278 CALL mp_timeset(routinen, handle)
18279
18280#if defined(__parallel)
18281#if !defined(__GNUC__) || __GNUC__ >= 9
18282 cpassert(is_contiguous(msgin))
18283#endif
18284
18285 my_tag = 0
18286 IF (PRESENT(tag)) my_tag = tag
18287
18288 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
18289 IF (msglen > 0) THEN
18290 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_double_precision, dest, my_tag, &
18291 comm%handle, request%handle, ierr)
18292 ELSE
18293 CALL mpi_isend(foo, msglen, mpi_double_precision, dest, my_tag, &
18294 comm%handle, request%handle, ierr)
18295 END IF
18296 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
18297
18298 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_8_size)
18299#else
18300 mark_used(msgin)
18301 mark_used(dest)
18302 mark_used(comm)
18303 mark_used(request)
18304 mark_used(tag)
18305 ierr = 1
18306 request = mp_request_null
18307 CALL mp_stop(ierr, "mp_isend called in non parallel case")
18308#endif
18309 CALL mp_timestop(handle)
18310 END SUBROUTINE mp_isend_dm4
18311
18312! **************************************************************************************************
18313!> \brief Non-blocking receive of vector data
18314!> \param msgout ...
18315!> \param source ...
18316!> \param comm ...
18317!> \param request ...
18318!> \param tag ...
18319!> \par History
18320!> 08.2003 created [f&j]
18321!> 2009-11-25 [UB] Made type-generic for templates
18322!> \note see mp_isendrecv_dv
18323!> \note
18324!> arrays can be pointers or assumed shape, but they must be contiguous!
18325! **************************************************************************************************
18326 SUBROUTINE mp_irecv_dv(msgout, source, comm, request, tag)
18327 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
18328 INTEGER, INTENT(IN) :: source
18329 CLASS(mp_comm_type), INTENT(IN) :: comm
18330 TYPE(mp_request_type), INTENT(out) :: request
18331 INTEGER, INTENT(in), OPTIONAL :: tag
18332
18333 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dv'
18334
18335 INTEGER :: handle
18336#if defined(__parallel)
18337 INTEGER :: ierr, msglen, my_tag
18338 REAL(kind=real_8) :: foo(1)
18339#endif
18340
18341 CALL mp_timeset(routinen, handle)
18342
18343#if defined(__parallel)
18344#if !defined(__GNUC__) || __GNUC__ >= 9
18345 cpassert(is_contiguous(msgout))
18346#endif
18347
18348 my_tag = 0
18349 IF (PRESENT(tag)) my_tag = tag
18350
18351 msglen = SIZE(msgout)
18352 IF (msglen > 0) THEN
18353 CALL mpi_irecv(msgout(1), msglen, mpi_double_precision, source, my_tag, &
18354 comm%handle, request%handle, ierr)
18355 ELSE
18356 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18357 comm%handle, request%handle, ierr)
18358 END IF
18359 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18360
18361 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18362#else
18363 cpabort("mp_irecv called in non parallel case")
18364 mark_used(msgout)
18365 mark_used(source)
18366 mark_used(comm)
18367 mark_used(tag)
18368 request = mp_request_null
18369#endif
18370 CALL mp_timestop(handle)
18371 END SUBROUTINE mp_irecv_dv
18372
18373! **************************************************************************************************
18374!> \brief Non-blocking receive of matrix data
18375!> \param msgout ...
18376!> \param source ...
18377!> \param comm ...
18378!> \param request ...
18379!> \param tag ...
18380!> \par History
18381!> 2009-11-25 [UB] Made type-generic for templates
18382!> \author fawzi
18383!> \note see mp_isendrecv_dv
18384!> \note see mp_irecv_dv
18385!> \note
18386!> arrays can be pointers or assumed shape, but they must be contiguous!
18387! **************************************************************************************************
18388 SUBROUTINE mp_irecv_dm2(msgout, source, comm, request, tag)
18389 REAL(kind=real_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
18390 INTEGER, INTENT(IN) :: source
18391 CLASS(mp_comm_type), INTENT(IN) :: comm
18392 TYPE(mp_request_type), INTENT(out) :: request
18393 INTEGER, INTENT(in), OPTIONAL :: tag
18394
18395 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm2'
18396
18397 INTEGER :: handle
18398#if defined(__parallel)
18399 INTEGER :: ierr, msglen, my_tag
18400 REAL(kind=real_8) :: foo(1)
18401#endif
18402
18403 CALL mp_timeset(routinen, handle)
18404
18405#if defined(__parallel)
18406#if !defined(__GNUC__) || __GNUC__ >= 9
18407 cpassert(is_contiguous(msgout))
18408#endif
18409
18410 my_tag = 0
18411 IF (PRESENT(tag)) my_tag = tag
18412
18413 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
18414 IF (msglen > 0) THEN
18415 CALL mpi_irecv(msgout(1, 1), msglen, mpi_double_precision, source, my_tag, &
18416 comm%handle, request%handle, ierr)
18417 ELSE
18418 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18419 comm%handle, request%handle, ierr)
18420 END IF
18421 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
18422
18423 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18424#else
18425 mark_used(msgout)
18426 mark_used(source)
18427 mark_used(comm)
18428 mark_used(tag)
18429 request = mp_request_null
18430 cpabort("mp_irecv called in non parallel case")
18431#endif
18432 CALL mp_timestop(handle)
18433 END SUBROUTINE mp_irecv_dm2
18434
18435! **************************************************************************************************
18436!> \brief Non-blocking send of rank-3 data
18437!> \param msgout ...
18438!> \param source ...
18439!> \param comm ...
18440!> \param request ...
18441!> \param tag ...
18442!> \par History
18443!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
18444!> 2009-11-25 [UB] Made type-generic for templates
18445!> \author fawzi
18446!> \note see mp_isendrecv_dv
18447!> \note see mp_irecv_dv
18448!> \note
18449!> arrays can be pointers or assumed shape, but they must be contiguous!
18450! **************************************************************************************************
18451 SUBROUTINE mp_irecv_dm3(msgout, source, comm, request, tag)
18452 REAL(kind=real_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
18453 INTEGER, INTENT(IN) :: source
18454 CLASS(mp_comm_type), INTENT(IN) :: comm
18455 TYPE(mp_request_type), INTENT(out) :: request
18456 INTEGER, INTENT(in), OPTIONAL :: tag
18457
18458 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm3'
18459
18460 INTEGER :: handle
18461#if defined(__parallel)
18462 INTEGER :: ierr, msglen, my_tag
18463 REAL(kind=real_8) :: foo(1)
18464#endif
18465
18466 CALL mp_timeset(routinen, handle)
18467
18468#if defined(__parallel)
18469#if !defined(__GNUC__) || __GNUC__ >= 9
18470 cpassert(is_contiguous(msgout))
18471#endif
18472
18473 my_tag = 0
18474 IF (PRESENT(tag)) my_tag = tag
18475
18476 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
18477 IF (msglen > 0) THEN
18478 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_double_precision, source, my_tag, &
18479 comm%handle, request%handle, ierr)
18480 ELSE
18481 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18482 comm%handle, request%handle, ierr)
18483 END IF
18484 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
18485
18486 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18487#else
18488 mark_used(msgout)
18489 mark_used(source)
18490 mark_used(comm)
18491 mark_used(tag)
18492 request = mp_request_null
18493 cpabort("mp_irecv called in non parallel case")
18494#endif
18495 CALL mp_timestop(handle)
18496 END SUBROUTINE mp_irecv_dm3
18497
18498! **************************************************************************************************
18499!> \brief Non-blocking receive of rank-4 data
18500!> \param msgout the output message
18501!> \param source the source processor
18502!> \param comm the communicator object
18503!> \param request the communication request id
18504!> \param tag the message tag
18505!> \par History
18506!> 2.2016 added _dm4 subroutine [Nico Holmberg]
18507!> \author fawzi
18508!> \note see mp_irecv_dv
18509!> \note
18510!> arrays can be pointers or assumed shape, but they must be contiguous!
18511! **************************************************************************************************
18512 SUBROUTINE mp_irecv_dm4(msgout, source, comm, request, tag)
18513 REAL(kind=real_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
18514 INTEGER, INTENT(IN) :: source
18515 CLASS(mp_comm_type), INTENT(IN) :: comm
18516 TYPE(mp_request_type), INTENT(out) :: request
18517 INTEGER, INTENT(in), OPTIONAL :: tag
18518
18519 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_dm4'
18520
18521 INTEGER :: handle
18522#if defined(__parallel)
18523 INTEGER :: ierr, msglen, my_tag
18524 REAL(kind=real_8) :: foo(1)
18525#endif
18526
18527 CALL mp_timeset(routinen, handle)
18528
18529#if defined(__parallel)
18530#if !defined(__GNUC__) || __GNUC__ >= 9
18531 cpassert(is_contiguous(msgout))
18532#endif
18533
18534 my_tag = 0
18535 IF (PRESENT(tag)) my_tag = tag
18536
18537 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
18538 IF (msglen > 0) THEN
18539 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_double_precision, source, my_tag, &
18540 comm%handle, request%handle, ierr)
18541 ELSE
18542 CALL mpi_irecv(foo, msglen, mpi_double_precision, source, my_tag, &
18543 comm%handle, request%handle, ierr)
18544 END IF
18545 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
18546
18547 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_8_size)
18548#else
18549 mark_used(msgout)
18550 mark_used(source)
18551 mark_used(comm)
18552 mark_used(tag)
18553 request = mp_request_null
18554 cpabort("mp_irecv called in non parallel case")
18555#endif
18556 CALL mp_timestop(handle)
18557 END SUBROUTINE mp_irecv_dm4
18558
18559! **************************************************************************************************
18560!> \brief Window initialization function for vector data
18561!> \param base ...
18562!> \param comm ...
18563!> \param win ...
18564!> \par History
18565!> 02.2015 created [Alfio Lazzaro]
18566!> \note
18567!> arrays can be pointers or assumed shape, but they must be contiguous!
18568! **************************************************************************************************
18569 SUBROUTINE mp_win_create_dv(base, comm, win)
18570 REAL(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
18571 TYPE(mp_comm_type), INTENT(IN) :: comm
18572 CLASS(mp_win_type), INTENT(INOUT) :: win
18573
18574 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_dv'
18575
18576 INTEGER :: handle
18577#if defined(__parallel)
18578 INTEGER :: ierr
18579 INTEGER(kind=mpi_address_kind) :: len
18580 REAL(kind=real_8) :: foo(1)
18581#endif
18582
18583 CALL mp_timeset(routinen, handle)
18584
18585#if defined(__parallel)
18586
18587 len = SIZE(base)*real_8_size
18588 IF (len > 0) THEN
18589 CALL mpi_win_create(base(1), len, real_8_size, mpi_info_null, comm%handle, win%handle, ierr)
18590 ELSE
18591 CALL mpi_win_create(foo, len, real_8_size, mpi_info_null, comm%handle, win%handle, ierr)
18592 END IF
18593 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
18594
18595 CALL add_perf(perf_id=20, count=1)
18596#else
18597 mark_used(base)
18598 mark_used(comm)
18599 win%handle = mp_win_null_handle
18600#endif
18601 CALL mp_timestop(handle)
18602 END SUBROUTINE mp_win_create_dv
18603
18604! **************************************************************************************************
18605!> \brief Single-sided get function for vector data
18606!> \param base ...
18607!> \param comm ...
18608!> \param win ...
18609!> \par History
18610!> 02.2015 created [Alfio Lazzaro]
18611!> \note
18612!> arrays can be pointers or assumed shape, but they must be contiguous!
18613! **************************************************************************************************
18614 SUBROUTINE mp_rget_dv(base, source, win, win_data, myproc, disp, request, &
18615 origin_datatype, target_datatype)
18616 REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
18617 INTEGER, INTENT(IN) :: source
18618 CLASS(mp_win_type), INTENT(IN) :: win
18619 REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: win_data
18620 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
18621 TYPE(mp_request_type), INTENT(OUT) :: request
18622 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
18623
18624 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_dv'
18625
18626 INTEGER :: handle
18627#if defined(__parallel)
18628 INTEGER :: ierr, len, &
18629 origin_len, target_len
18630 LOGICAL :: do_local_copy
18631 INTEGER(kind=mpi_address_kind) :: disp_aint
18632 mpi_data_type :: handle_origin_datatype, handle_target_datatype
18633#endif
18634
18635 CALL mp_timeset(routinen, handle)
18636
18637#if defined(__parallel)
18638 len = SIZE(base)
18639 disp_aint = 0
18640 IF (PRESENT(disp)) THEN
18641 disp_aint = int(disp, kind=mpi_address_kind)
18642 END IF
18643 handle_origin_datatype = mpi_double_precision
18644 origin_len = len
18645 IF (PRESENT(origin_datatype)) THEN
18646 handle_origin_datatype = origin_datatype%type_handle
18647 origin_len = 1
18648 END IF
18649 handle_target_datatype = mpi_double_precision
18650 target_len = len
18651 IF (PRESENT(target_datatype)) THEN
18652 handle_target_datatype = target_datatype%type_handle
18653 target_len = 1
18654 END IF
18655 IF (len > 0) THEN
18656 do_local_copy = .false.
18657 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
18658 IF (myproc .EQ. source) do_local_copy = .true.
18659 END IF
18660 IF (do_local_copy) THEN
18661 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
18662 base(:) = win_data(disp_aint + 1:disp_aint + len)
18663 !$OMP END PARALLEL WORKSHARE
18664 request = mp_request_null
18665 ierr = 0
18666 ELSE
18667 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
18668 target_len, handle_target_datatype, win%handle, request%handle, ierr)
18669 END IF
18670 ELSE
18671 request = mp_request_null
18672 ierr = 0
18673 END IF
18674 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
18675
18676 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*real_8_size)
18677#else
18678 mark_used(source)
18679 mark_used(win)
18680 mark_used(myproc)
18681 mark_used(origin_datatype)
18682 mark_used(target_datatype)
18683
18684 request = mp_request_null
18685 !
18686 IF (PRESENT(disp)) THEN
18687 base(:) = win_data(disp + 1:disp + SIZE(base))
18688 ELSE
18689 base(:) = win_data(:SIZE(base))
18690 END IF
18691
18692#endif
18693 CALL mp_timestop(handle)
18694 END SUBROUTINE mp_rget_dv
18695
18696! **************************************************************************************************
18697!> \brief ...
18698!> \param count ...
18699!> \param lengths ...
18700!> \param displs ...
18701!> \return ...
18702! ***************************************************************************
18703 FUNCTION mp_type_indexed_make_d (count, lengths, displs) &
18704 result(type_descriptor)
18705 INTEGER, INTENT(IN) :: count
18706 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
18707 TYPE(mp_type_descriptor_type) :: type_descriptor
18708
18709 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_d'
18710
18711 INTEGER :: handle
18712#if defined(__parallel)
18713 INTEGER :: ierr
18714#endif
18715
18716 CALL mp_timeset(routinen, handle)
18717
18718#if defined(__parallel)
18719 CALL mpi_type_indexed(count, lengths, displs, mpi_double_precision, &
18720 type_descriptor%type_handle, ierr)
18721 IF (ierr /= 0) &
18722 cpabort("MPI_Type_Indexed @ "//routinen)
18723 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
18724 IF (ierr /= 0) &
18725 cpabort("MPI_Type_commit @ "//routinen)
18726#else
18727 type_descriptor%type_handle = 3
18728#endif
18729 type_descriptor%length = count
18730 NULLIFY (type_descriptor%subtype)
18731 type_descriptor%vector_descriptor(1:2) = 1
18732 type_descriptor%has_indexing = .true.
18733 type_descriptor%index_descriptor%index => lengths
18734 type_descriptor%index_descriptor%chunks => displs
18735
18736 CALL mp_timestop(handle)
18737
18738 END FUNCTION mp_type_indexed_make_d
18739
18740! **************************************************************************************************
18741!> \brief Allocates special parallel memory
18742!> \param[in] DATA pointer to integer array to allocate
18743!> \param[in] len number of integers to allocate
18744!> \param[out] stat (optional) allocation status result
18745!> \author UB
18746! **************************************************************************************************
18747 SUBROUTINE mp_allocate_d (DATA, len, stat)
18748 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
18749 INTEGER, INTENT(IN) :: len
18750 INTEGER, INTENT(OUT), OPTIONAL :: stat
18751
18752 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_d'
18753
18754 INTEGER :: handle, ierr
18755
18756 CALL mp_timeset(routinen, handle)
18757
18758#if defined(__parallel)
18759 NULLIFY (data)
18760 CALL mp_alloc_mem(DATA, len, stat=ierr)
18761 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
18762 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
18763 CALL add_perf(perf_id=15, count=1)
18764#else
18765 ALLOCATE (DATA(len), stat=ierr)
18766 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
18767 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
18768#endif
18769 IF (PRESENT(stat)) stat = ierr
18770 CALL mp_timestop(handle)
18771 END SUBROUTINE mp_allocate_d
18772
18773! **************************************************************************************************
18774!> \brief Deallocates special parallel memory
18775!> \param[in] DATA pointer to special memory to deallocate
18776!> \param stat ...
18777!> \author UB
18778! **************************************************************************************************
18779 SUBROUTINE mp_deallocate_d (DATA, stat)
18780 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
18781 INTEGER, INTENT(OUT), OPTIONAL :: stat
18782
18783 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_d'
18784
18785 INTEGER :: handle
18786#if defined(__parallel)
18787 INTEGER :: ierr
18788#endif
18789
18790 CALL mp_timeset(routinen, handle)
18791
18792#if defined(__parallel)
18793 CALL mp_free_mem(DATA, ierr)
18794 IF (PRESENT(stat)) THEN
18795 stat = ierr
18796 ELSE
18797 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
18798 END IF
18799 NULLIFY (data)
18800 CALL add_perf(perf_id=15, count=1)
18801#else
18802 DEALLOCATE (data)
18803 IF (PRESENT(stat)) stat = 0
18804#endif
18805 CALL mp_timestop(handle)
18806 END SUBROUTINE mp_deallocate_d
18807
18808! **************************************************************************************************
18809!> \brief (parallel) Blocking individual file write using explicit offsets
18810!> (serial) Unformatted stream write
18811!> \param[in] fh file handle (file storage unit)
18812!> \param[in] offset file offset (position)
18813!> \param[in] msg data to be written to the file
18814!> \param msglen ...
18815!> \par MPI-I/O mapping mpi_file_write_at
18816!> \par STREAM-I/O mapping WRITE
18817!> \param[in](optional) msglen number of the elements of data
18818! **************************************************************************************************
18819 SUBROUTINE mp_file_write_at_dv(fh, offset, msg, msglen)
18820 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
18821 CLASS(mp_file_type), INTENT(IN) :: fh
18822 INTEGER, INTENT(IN), OPTIONAL :: msglen
18823 INTEGER(kind=file_offset), INTENT(IN) :: offset
18824
18825 INTEGER :: msg_len
18826#if defined(__parallel)
18827 INTEGER :: ierr
18828#endif
18829
18830 msg_len = SIZE(msg)
18831 IF (PRESENT(msglen)) msg_len = msglen
18832#if defined(__parallel)
18833 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18834 IF (ierr .NE. 0) &
18835 cpabort("mpi_file_write_at_dv @ mp_file_write_at_dv")
18836#else
18837 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18838#endif
18839 END SUBROUTINE mp_file_write_at_dv
18840
18841! **************************************************************************************************
18842!> \brief ...
18843!> \param fh ...
18844!> \param offset ...
18845!> \param msg ...
18846! **************************************************************************************************
18847 SUBROUTINE mp_file_write_at_d (fh, offset, msg)
18848 REAL(kind=real_8), INTENT(IN) :: msg
18849 CLASS(mp_file_type), INTENT(IN) :: fh
18850 INTEGER(kind=file_offset), INTENT(IN) :: offset
18851
18852#if defined(__parallel)
18853 INTEGER :: ierr
18854
18855 ierr = 0
18856 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18857 IF (ierr .NE. 0) &
18858 cpabort("mpi_file_write_at_d @ mp_file_write_at_d")
18859#else
18860 WRITE (unit=fh%handle, pos=offset + 1) msg
18861#endif
18862 END SUBROUTINE mp_file_write_at_d
18863
18864! **************************************************************************************************
18865!> \brief (parallel) Blocking collective file write using explicit offsets
18866!> (serial) Unformatted stream write
18867!> \param fh ...
18868!> \param offset ...
18869!> \param msg ...
18870!> \param msglen ...
18871!> \par MPI-I/O mapping mpi_file_write_at_all
18872!> \par STREAM-I/O mapping WRITE
18873! **************************************************************************************************
18874 SUBROUTINE mp_file_write_at_all_dv(fh, offset, msg, msglen)
18875 REAL(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
18876 CLASS(mp_file_type), INTENT(IN) :: fh
18877 INTEGER, INTENT(IN), OPTIONAL :: msglen
18878 INTEGER(kind=file_offset), INTENT(IN) :: offset
18879
18880 INTEGER :: msg_len
18881#if defined(__parallel)
18882 INTEGER :: ierr
18883#endif
18884
18885 msg_len = SIZE(msg)
18886 IF (PRESENT(msglen)) msg_len = msglen
18887#if defined(__parallel)
18888 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18889 IF (ierr .NE. 0) &
18890 cpabort("mpi_file_write_at_all_dv @ mp_file_write_at_all_dv")
18891#else
18892 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18893#endif
18894 END SUBROUTINE mp_file_write_at_all_dv
18895
18896! **************************************************************************************************
18897!> \brief ...
18898!> \param fh ...
18899!> \param offset ...
18900!> \param msg ...
18901! **************************************************************************************************
18902 SUBROUTINE mp_file_write_at_all_d (fh, offset, msg)
18903 REAL(kind=real_8), INTENT(IN) :: msg
18904 CLASS(mp_file_type), INTENT(IN) :: fh
18905 INTEGER(kind=file_offset), INTENT(IN) :: offset
18906
18907#if defined(__parallel)
18908 INTEGER :: ierr
18909
18910 ierr = 0
18911 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18912 IF (ierr .NE. 0) &
18913 cpabort("mpi_file_write_at_all_d @ mp_file_write_at_all_d")
18914#else
18915 WRITE (unit=fh%handle, pos=offset + 1) msg
18916#endif
18917 END SUBROUTINE mp_file_write_at_all_d
18918
18919! **************************************************************************************************
18920!> \brief (parallel) Blocking individual file read using explicit offsets
18921!> (serial) Unformatted stream read
18922!> \param[in] fh file handle (file storage unit)
18923!> \param[in] offset file offset (position)
18924!> \param[out] msg data to be read from the file
18925!> \param msglen ...
18926!> \par MPI-I/O mapping mpi_file_read_at
18927!> \par STREAM-I/O mapping READ
18928!> \param[in](optional) msglen number of elements of data
18929! **************************************************************************************************
18930 SUBROUTINE mp_file_read_at_dv(fh, offset, msg, msglen)
18931 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
18932 CLASS(mp_file_type), INTENT(IN) :: fh
18933 INTEGER, INTENT(IN), OPTIONAL :: msglen
18934 INTEGER(kind=file_offset), INTENT(IN) :: offset
18935
18936 INTEGER :: msg_len
18937#if defined(__parallel)
18938 INTEGER :: ierr
18939#endif
18940
18941 msg_len = SIZE(msg)
18942 IF (PRESENT(msglen)) msg_len = msglen
18943#if defined(__parallel)
18944 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
18945 IF (ierr .NE. 0) &
18946 cpabort("mpi_file_read_at_dv @ mp_file_read_at_dv")
18947#else
18948 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
18949#endif
18950 END SUBROUTINE mp_file_read_at_dv
18951
18952! **************************************************************************************************
18953!> \brief ...
18954!> \param fh ...
18955!> \param offset ...
18956!> \param msg ...
18957! **************************************************************************************************
18958 SUBROUTINE mp_file_read_at_d (fh, offset, msg)
18959 REAL(kind=real_8), INTENT(OUT) :: msg
18960 CLASS(mp_file_type), INTENT(IN) :: fh
18961 INTEGER(kind=file_offset), INTENT(IN) :: offset
18962
18963#if defined(__parallel)
18964 INTEGER :: ierr
18965
18966 ierr = 0
18967 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
18968 IF (ierr .NE. 0) &
18969 cpabort("mpi_file_read_at_d @ mp_file_read_at_d")
18970#else
18971 READ (unit=fh%handle, pos=offset + 1) msg
18972#endif
18973 END SUBROUTINE mp_file_read_at_d
18974
18975! **************************************************************************************************
18976!> \brief (parallel) Blocking collective file read using explicit offsets
18977!> (serial) Unformatted stream read
18978!> \param fh ...
18979!> \param offset ...
18980!> \param msg ...
18981!> \param msglen ...
18982!> \par MPI-I/O mapping mpi_file_read_at_all
18983!> \par STREAM-I/O mapping READ
18984! **************************************************************************************************
18985 SUBROUTINE mp_file_read_at_all_dv(fh, offset, msg, msglen)
18986 REAL(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
18987 CLASS(mp_file_type), INTENT(IN) :: fh
18988 INTEGER, INTENT(IN), OPTIONAL :: msglen
18989 INTEGER(kind=file_offset), INTENT(IN) :: offset
18990
18991 INTEGER :: msg_len
18992#if defined(__parallel)
18993 INTEGER :: ierr
18994#endif
18995
18996 msg_len = SIZE(msg)
18997 IF (PRESENT(msglen)) msg_len = msglen
18998#if defined(__parallel)
18999 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_double_precision, mpi_status_ignore, ierr)
19000 IF (ierr .NE. 0) &
19001 cpabort("mpi_file_read_at_all_dv @ mp_file_read_at_all_dv")
19002#else
19003 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
19004#endif
19005 END SUBROUTINE mp_file_read_at_all_dv
19006
19007! **************************************************************************************************
19008!> \brief ...
19009!> \param fh ...
19010!> \param offset ...
19011!> \param msg ...
19012! **************************************************************************************************
19013 SUBROUTINE mp_file_read_at_all_d (fh, offset, msg)
19014 REAL(kind=real_8), INTENT(OUT) :: msg
19015 CLASS(mp_file_type), INTENT(IN) :: fh
19016 INTEGER(kind=file_offset), INTENT(IN) :: offset
19017
19018#if defined(__parallel)
19019 INTEGER :: ierr
19020
19021 ierr = 0
19022 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_double_precision, mpi_status_ignore, ierr)
19023 IF (ierr .NE. 0) &
19024 cpabort("mpi_file_read_at_all_d @ mp_file_read_at_all_d")
19025#else
19026 READ (unit=fh%handle, pos=offset + 1) msg
19027#endif
19028 END SUBROUTINE mp_file_read_at_all_d
19029
19030! **************************************************************************************************
19031!> \brief ...
19032!> \param ptr ...
19033!> \param vector_descriptor ...
19034!> \param index_descriptor ...
19035!> \return ...
19036! **************************************************************************************************
19037 FUNCTION mp_type_make_d (ptr, &
19038 vector_descriptor, index_descriptor) &
19039 result(type_descriptor)
19040 REAL(kind=real_8), DIMENSION(:), TARGET, asynchronous :: ptr
19041 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
19042 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
19043 TYPE(mp_type_descriptor_type) :: type_descriptor
19044
19045 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_d'
19046
19047#if defined(__parallel)
19048 INTEGER :: ierr
19049#endif
19050
19051 NULLIFY (type_descriptor%subtype)
19052 type_descriptor%length = SIZE(ptr)
19053#if defined(__parallel)
19054 type_descriptor%type_handle = mpi_double_precision
19055 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
19056 IF (ierr /= 0) &
19057 cpabort("MPI_Get_address @ "//routinen)
19058#else
19059 type_descriptor%type_handle = 3
19060#endif
19061 type_descriptor%vector_descriptor(1:2) = 1
19062 type_descriptor%has_indexing = .false.
19063 type_descriptor%data_d => ptr
19064 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
19065 cpabort(routinen//": Vectors and indices NYI")
19066 END IF
19067 END FUNCTION mp_type_make_d
19068
19069! **************************************************************************************************
19070!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
19071!> as the Fortran version returns an integer, which we take to be a C_PTR
19072!> \param DATA data array to allocate
19073!> \param[in] len length (in data elements) of data array allocation
19074!> \param[out] stat (optional) allocation status result
19075! **************************************************************************************************
19076 SUBROUTINE mp_alloc_mem_d (DATA, len, stat)
19077 REAL(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
19078 INTEGER, INTENT(IN) :: len
19079 INTEGER, INTENT(OUT), OPTIONAL :: stat
19080
19081#if defined(__parallel)
19082 INTEGER :: size, ierr, length, &
19083 mp_res
19084 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
19085 TYPE(c_ptr) :: mp_baseptr
19086 mpi_info_type :: mp_info
19087
19088 length = max(len, 1)
19089 CALL mpi_type_size(mpi_double_precision, size, ierr)
19090 mp_size = int(length, kind=mpi_address_kind)*size
19091 IF (mp_size .GT. mp_max_memory_size) THEN
19092 cpabort("MPI cannot allocate more than 2 GiByte")
19093 END IF
19094 mp_info = mpi_info_null
19095 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
19096 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
19097 IF (PRESENT(stat)) stat = mp_res
19098#else
19099 INTEGER :: length, mystat
19100 length = max(len, 1)
19101 IF (PRESENT(stat)) THEN
19102 ALLOCATE (DATA(length), stat=mystat)
19103 stat = mystat ! show to convention checker that stat is used
19104 ELSE
19105 ALLOCATE (DATA(length))
19106 END IF
19107#endif
19108 END SUBROUTINE mp_alloc_mem_d
19109
19110! **************************************************************************************************
19111!> \brief Deallocates am array, ... this is hackish
19112!> as the Fortran version takes an integer, which we hope to get by reference
19113!> \param DATA data array to allocate
19114!> \param[out] stat (optional) allocation status result
19115! **************************************************************************************************
19116 SUBROUTINE mp_free_mem_d (DATA, stat)
19117 REAL(kind=real_8), DIMENSION(:), &
19118 POINTER, asynchronous :: DATA
19119 INTEGER, INTENT(OUT), OPTIONAL :: stat
19120
19121#if defined(__parallel)
19122 INTEGER :: mp_res
19123 CALL mpi_free_mem(DATA, mp_res)
19124 IF (PRESENT(stat)) stat = mp_res
19125#else
19126 DEALLOCATE (data)
19127 IF (PRESENT(stat)) stat = 0
19128#endif
19129 END SUBROUTINE mp_free_mem_d
19130! **************************************************************************************************
19131!> \brief Shift around the data in msg
19132!> \param[in,out] msg Rank-2 data to shift
19133!> \param[in] comm message passing environment identifier
19134!> \param[in] displ_in displacements (?)
19135!> \par Example
19136!> msg will be moved from rank to rank+displ_in (in a circular way)
19137!> \par Limitations
19138!> * displ_in will be 1 by default (others not tested)
19139!> * the message array needs to be the same size on all processes
19140! **************************************************************************************************
19141 SUBROUTINE mp_shift_rm(msg, comm, displ_in)
19142
19143 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
19144 CLASS(mp_comm_type), INTENT(IN) :: comm
19145 INTEGER, INTENT(IN), OPTIONAL :: displ_in
19146
19147 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_rm'
19148
19149 INTEGER :: handle, ierror
19150#if defined(__parallel)
19151 INTEGER :: displ, left, &
19152 msglen, myrank, nprocs, &
19153 right, tag
19154#endif
19155
19156 ierror = 0
19157 CALL mp_timeset(routinen, handle)
19158
19159#if defined(__parallel)
19160 CALL mpi_comm_rank(comm%handle, myrank, ierror)
19161 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
19162 CALL mpi_comm_size(comm%handle, nprocs, ierror)
19163 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
19164 IF (PRESENT(displ_in)) THEN
19165 displ = displ_in
19166 ELSE
19167 displ = 1
19168 END IF
19169 right = modulo(myrank + displ, nprocs)
19170 left = modulo(myrank - displ, nprocs)
19171 tag = 17
19172 msglen = SIZE(msg)
19173 CALL mpi_sendrecv_replace(msg, msglen, mpi_real, right, tag, left, tag, &
19174 comm%handle, mpi_status_ignore, ierror)
19175 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
19176 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_4_size)
19177#else
19178 mark_used(msg)
19179 mark_used(comm)
19180 mark_used(displ_in)
19181#endif
19182 CALL mp_timestop(handle)
19183
19184 END SUBROUTINE mp_shift_rm
19185
19186! **************************************************************************************************
19187!> \brief Shift around the data in msg
19188!> \param[in,out] msg Data to shift
19189!> \param[in] comm message passing environment identifier
19190!> \param[in] displ_in displacements (?)
19191!> \par Example
19192!> msg will be moved from rank to rank+displ_in (in a circular way)
19193!> \par Limitations
19194!> * displ_in will be 1 by default (others not tested)
19195!> * the message array needs to be the same size on all processes
19196! **************************************************************************************************
19197 SUBROUTINE mp_shift_r (msg, comm, displ_in)
19198
19199 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19200 CLASS(mp_comm_type), INTENT(IN) :: comm
19201 INTEGER, INTENT(IN), OPTIONAL :: displ_in
19202
19203 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_r'
19204
19205 INTEGER :: handle, ierror
19206#if defined(__parallel)
19207 INTEGER :: displ, left, &
19208 msglen, myrank, nprocs, &
19209 right, tag
19210#endif
19211
19212 ierror = 0
19213 CALL mp_timeset(routinen, handle)
19214
19215#if defined(__parallel)
19216 CALL mpi_comm_rank(comm%handle, myrank, ierror)
19217 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
19218 CALL mpi_comm_size(comm%handle, nprocs, ierror)
19219 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
19220 IF (PRESENT(displ_in)) THEN
19221 displ = displ_in
19222 ELSE
19223 displ = 1
19224 END IF
19225 right = modulo(myrank + displ, nprocs)
19226 left = modulo(myrank - displ, nprocs)
19227 tag = 19
19228 msglen = SIZE(msg)
19229 CALL mpi_sendrecv_replace(msg, msglen, mpi_real, right, tag, left, &
19230 tag, comm%handle, mpi_status_ignore, ierror)
19231 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
19232 CALL add_perf(perf_id=7, count=1, msg_size=msglen*real_4_size)
19233#else
19234 mark_used(msg)
19235 mark_used(comm)
19236 mark_used(displ_in)
19237#endif
19238 CALL mp_timestop(handle)
19239
19240 END SUBROUTINE mp_shift_r
19241
19242! **************************************************************************************************
19243!> \brief All-to-all data exchange, rank-1 data of different sizes
19244!> \param[in] sb Data to send
19245!> \param[in] scount Data counts for data sent to other processes
19246!> \param[in] sdispl Respective data offsets for data sent to process
19247!> \param[in,out] rb Buffer into which to receive data
19248!> \param[in] rcount Data counts for data received from other
19249!> processes
19250!> \param[in] rdispl Respective data offsets for data received from
19251!> other processes
19252!> \param[in] comm Message passing environment identifier
19253!> \par MPI mapping
19254!> mpi_alltoallv
19255!> \par Array sizes
19256!> The scount, rcount, and the sdispl and rdispl arrays have a
19257!> size equal to the number of processes.
19258!> \par Offsets
19259!> Values in sdispl and rdispl start with 0.
19260! **************************************************************************************************
19261 SUBROUTINE mp_alltoall_r11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
19262
19263 REAL(kind=real_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
19264 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
19265 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
19266 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
19267 CLASS(mp_comm_type), INTENT(IN) :: comm
19268
19269 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r11v'
19270
19271 INTEGER :: handle
19272#if defined(__parallel)
19273 INTEGER :: ierr, msglen
19274#else
19275 INTEGER :: i
19276#endif
19277
19278 CALL mp_timeset(routinen, handle)
19279
19280#if defined(__parallel)
19281 CALL mpi_alltoallv(sb, scount, sdispl, mpi_real, &
19282 rb, rcount, rdispl, mpi_real, comm%handle, ierr)
19283 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
19284 msglen = sum(scount) + sum(rcount)
19285 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19286#else
19287 mark_used(comm)
19288 mark_used(scount)
19289 mark_used(sdispl)
19290 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
19291 DO i = 1, rcount(1)
19292 rb(rdispl(1) + i) = sb(sdispl(1) + i)
19293 END DO
19294#endif
19295 CALL mp_timestop(handle)
19296
19297 END SUBROUTINE mp_alltoall_r11v
19298
19299! **************************************************************************************************
19300!> \brief All-to-all data exchange, rank-2 data of different sizes
19301!> \param sb ...
19302!> \param scount ...
19303!> \param sdispl ...
19304!> \param rb ...
19305!> \param rcount ...
19306!> \param rdispl ...
19307!> \param comm ...
19308!> \par MPI mapping
19309!> mpi_alltoallv
19310!> \note see mp_alltoall_r11v
19311! **************************************************************************************************
19312 SUBROUTINE mp_alltoall_r22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
19313
19314 REAL(kind=real_4), DIMENSION(:, :), &
19315 INTENT(IN), CONTIGUOUS :: sb
19316 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
19317 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, &
19318 INTENT(INOUT) :: rb
19319 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
19320 CLASS(mp_comm_type), INTENT(IN) :: comm
19321
19322 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r22v'
19323
19324 INTEGER :: handle
19325#if defined(__parallel)
19326 INTEGER :: ierr, msglen
19327#endif
19328
19329 CALL mp_timeset(routinen, handle)
19330
19331#if defined(__parallel)
19332 CALL mpi_alltoallv(sb, scount, sdispl, mpi_real, &
19333 rb, rcount, rdispl, mpi_real, comm%handle, ierr)
19334 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
19335 msglen = sum(scount) + sum(rcount)
19336 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*real_4_size)
19337#else
19338 mark_used(comm)
19339 mark_used(scount)
19340 mark_used(sdispl)
19341 mark_used(rcount)
19342 mark_used(rdispl)
19343 rb = sb
19344#endif
19345 CALL mp_timestop(handle)
19346
19347 END SUBROUTINE mp_alltoall_r22v
19348
19349! **************************************************************************************************
19350!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
19351!> \param[in] sb array with data to send
19352!> \param[out] rb array into which data is received
19353!> \param[in] count number of elements to send/receive (product of the
19354!> extents of the first two dimensions)
19355!> \param[in] comm Message passing environment identifier
19356!> \par Index meaning
19357!> \par The first two indices specify the data while the last index counts
19358!> the processes
19359!> \par Sizes of ranks
19360!> All processes have the same data size.
19361!> \par MPI mapping
19362!> mpi_alltoall
19363! **************************************************************************************************
19364 SUBROUTINE mp_alltoall_r (sb, rb, count, comm)
19365
19366 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
19367 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
19368 INTEGER, INTENT(IN) :: count
19369 CLASS(mp_comm_type), INTENT(IN) :: comm
19370
19371 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r'
19372
19373 INTEGER :: handle
19374#if defined(__parallel)
19375 INTEGER :: ierr, msglen, np
19376#endif
19377
19378 CALL mp_timeset(routinen, handle)
19379
19380#if defined(__parallel)
19381 CALL mpi_alltoall(sb, count, mpi_real, &
19382 rb, count, mpi_real, comm%handle, ierr)
19383 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19384 CALL mpi_comm_size(comm%handle, np, ierr)
19385 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19386 msglen = 2*count*np
19387 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19388#else
19389 mark_used(count)
19390 mark_used(comm)
19391 rb = sb
19392#endif
19393 CALL mp_timestop(handle)
19394
19395 END SUBROUTINE mp_alltoall_r
19396
19397! **************************************************************************************************
19398!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
19399!> \param sb ...
19400!> \param rb ...
19401!> \param count ...
19402!> \param commp ...
19403!> \note see mp_alltoall_r
19404! **************************************************************************************************
19405 SUBROUTINE mp_alltoall_r22(sb, rb, count, comm)
19406
19407 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
19408 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
19409 INTEGER, INTENT(IN) :: count
19410 CLASS(mp_comm_type), INTENT(IN) :: comm
19411
19412 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r22'
19413
19414 INTEGER :: handle
19415#if defined(__parallel)
19416 INTEGER :: ierr, msglen, np
19417#endif
19418
19419 CALL mp_timeset(routinen, handle)
19420
19421#if defined(__parallel)
19422 CALL mpi_alltoall(sb, count, mpi_real, &
19423 rb, count, mpi_real, comm%handle, ierr)
19424 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19425 CALL mpi_comm_size(comm%handle, np, ierr)
19426 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19427 msglen = 2*SIZE(sb)*np
19428 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19429#else
19430 mark_used(count)
19431 mark_used(comm)
19432 rb = sb
19433#endif
19434 CALL mp_timestop(handle)
19435
19436 END SUBROUTINE mp_alltoall_r22
19437
19438! **************************************************************************************************
19439!> \brief All-to-all data exchange, rank-3 data with equal sizes
19440!> \param sb ...
19441!> \param rb ...
19442!> \param count ...
19443!> \param comm ...
19444!> \note see mp_alltoall_r
19445! **************************************************************************************************
19446 SUBROUTINE mp_alltoall_r33(sb, rb, count, comm)
19447
19448 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
19449 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
19450 INTEGER, INTENT(IN) :: count
19451 CLASS(mp_comm_type), INTENT(IN) :: comm
19452
19453 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r33'
19454
19455 INTEGER :: handle
19456#if defined(__parallel)
19457 INTEGER :: ierr, msglen, np
19458#endif
19459
19460 CALL mp_timeset(routinen, handle)
19461
19462#if defined(__parallel)
19463 CALL mpi_alltoall(sb, count, mpi_real, &
19464 rb, count, mpi_real, comm%handle, ierr)
19465 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19466 CALL mpi_comm_size(comm%handle, np, ierr)
19467 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19468 msglen = 2*count*np
19469 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19470#else
19471 mark_used(count)
19472 mark_used(comm)
19473 rb = sb
19474#endif
19475 CALL mp_timestop(handle)
19476
19477 END SUBROUTINE mp_alltoall_r33
19478
19479! **************************************************************************************************
19480!> \brief All-to-all data exchange, rank 4 data, equal sizes
19481!> \param sb ...
19482!> \param rb ...
19483!> \param count ...
19484!> \param comm ...
19485!> \note see mp_alltoall_r
19486! **************************************************************************************************
19487 SUBROUTINE mp_alltoall_r44(sb, rb, count, comm)
19488
19489 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19490 INTENT(IN) :: sb
19491 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19492 INTENT(OUT) :: rb
19493 INTEGER, INTENT(IN) :: count
19494 CLASS(mp_comm_type), INTENT(IN) :: comm
19495
19496 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r44'
19497
19498 INTEGER :: handle
19499#if defined(__parallel)
19500 INTEGER :: ierr, msglen, np
19501#endif
19502
19503 CALL mp_timeset(routinen, handle)
19504
19505#if defined(__parallel)
19506 CALL mpi_alltoall(sb, count, mpi_real, &
19507 rb, count, mpi_real, comm%handle, ierr)
19508 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19509 CALL mpi_comm_size(comm%handle, np, ierr)
19510 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19511 msglen = 2*count*np
19512 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19513#else
19514 mark_used(count)
19515 mark_used(comm)
19516 rb = sb
19517#endif
19518 CALL mp_timestop(handle)
19519
19520 END SUBROUTINE mp_alltoall_r44
19521
19522! **************************************************************************************************
19523!> \brief All-to-all data exchange, rank 5 data, equal sizes
19524!> \param sb ...
19525!> \param rb ...
19526!> \param count ...
19527!> \param comm ...
19528!> \note see mp_alltoall_r
19529! **************************************************************************************************
19530 SUBROUTINE mp_alltoall_r55(sb, rb, count, comm)
19531
19532 REAL(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
19533 INTENT(IN) :: sb
19534 REAL(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
19535 INTENT(OUT) :: rb
19536 INTEGER, INTENT(IN) :: count
19537 CLASS(mp_comm_type), INTENT(IN) :: comm
19538
19539 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r55'
19540
19541 INTEGER :: handle
19542#if defined(__parallel)
19543 INTEGER :: ierr, msglen, np
19544#endif
19545
19546 CALL mp_timeset(routinen, handle)
19547
19548#if defined(__parallel)
19549 CALL mpi_alltoall(sb, count, mpi_real, &
19550 rb, count, mpi_real, comm%handle, ierr)
19551 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19552 CALL mpi_comm_size(comm%handle, np, ierr)
19553 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19554 msglen = 2*count*np
19555 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19556#else
19557 mark_used(count)
19558 mark_used(comm)
19559 rb = sb
19560#endif
19561 CALL mp_timestop(handle)
19562
19563 END SUBROUTINE mp_alltoall_r55
19564
19565! **************************************************************************************************
19566!> \brief All-to-all data exchange, rank-4 data to rank-5 data
19567!> \param sb ...
19568!> \param rb ...
19569!> \param count ...
19570!> \param comm ...
19571!> \note see mp_alltoall_r
19572!> \note User must ensure size consistency.
19573! **************************************************************************************************
19574 SUBROUTINE mp_alltoall_r45(sb, rb, count, comm)
19575
19576 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19577 INTENT(IN) :: sb
19578 REAL(kind=real_4), &
19579 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
19580 INTEGER, INTENT(IN) :: count
19581 CLASS(mp_comm_type), INTENT(IN) :: comm
19582
19583 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r45'
19584
19585 INTEGER :: handle
19586#if defined(__parallel)
19587 INTEGER :: ierr, msglen, np
19588#endif
19589
19590 CALL mp_timeset(routinen, handle)
19591
19592#if defined(__parallel)
19593 CALL mpi_alltoall(sb, count, mpi_real, &
19594 rb, count, mpi_real, comm%handle, ierr)
19595 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19596 CALL mpi_comm_size(comm%handle, np, ierr)
19597 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19598 msglen = 2*count*np
19599 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19600#else
19601 mark_used(count)
19602 mark_used(comm)
19603 rb = reshape(sb, shape(rb))
19604#endif
19605 CALL mp_timestop(handle)
19606
19607 END SUBROUTINE mp_alltoall_r45
19608
19609! **************************************************************************************************
19610!> \brief All-to-all data exchange, rank-3 data to rank-4 data
19611!> \param sb ...
19612!> \param rb ...
19613!> \param count ...
19614!> \param comm ...
19615!> \note see mp_alltoall_r
19616!> \note User must ensure size consistency.
19617! **************************************************************************************************
19618 SUBROUTINE mp_alltoall_r34(sb, rb, count, comm)
19619
19620 REAL(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, &
19621 INTENT(IN) :: sb
19622 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19623 INTENT(OUT) :: rb
19624 INTEGER, INTENT(IN) :: count
19625 CLASS(mp_comm_type), INTENT(IN) :: comm
19626
19627 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r34'
19628
19629 INTEGER :: handle
19630#if defined(__parallel)
19631 INTEGER :: ierr, msglen, np
19632#endif
19633
19634 CALL mp_timeset(routinen, handle)
19635
19636#if defined(__parallel)
19637 CALL mpi_alltoall(sb, count, mpi_real, &
19638 rb, count, mpi_real, comm%handle, ierr)
19639 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19640 CALL mpi_comm_size(comm%handle, np, ierr)
19641 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19642 msglen = 2*count*np
19643 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19644#else
19645 mark_used(count)
19646 mark_used(comm)
19647 rb = reshape(sb, shape(rb))
19648#endif
19649 CALL mp_timestop(handle)
19650
19651 END SUBROUTINE mp_alltoall_r34
19652
19653! **************************************************************************************************
19654!> \brief All-to-all data exchange, rank-5 data to rank-4 data
19655!> \param sb ...
19656!> \param rb ...
19657!> \param count ...
19658!> \param comm ...
19659!> \note see mp_alltoall_r
19660!> \note User must ensure size consistency.
19661! **************************************************************************************************
19662 SUBROUTINE mp_alltoall_r54(sb, rb, count, comm)
19663
19664 REAL(kind=real_4), &
19665 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
19666 REAL(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
19667 INTENT(OUT) :: rb
19668 INTEGER, INTENT(IN) :: count
19669 CLASS(mp_comm_type), INTENT(IN) :: comm
19670
19671 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_r54'
19672
19673 INTEGER :: handle
19674#if defined(__parallel)
19675 INTEGER :: ierr, msglen, np
19676#endif
19677
19678 CALL mp_timeset(routinen, handle)
19679
19680#if defined(__parallel)
19681 CALL mpi_alltoall(sb, count, mpi_real, &
19682 rb, count, mpi_real, comm%handle, ierr)
19683 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
19684 CALL mpi_comm_size(comm%handle, np, ierr)
19685 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
19686 msglen = 2*count*np
19687 CALL add_perf(perf_id=6, count=1, msg_size=msglen*real_4_size)
19688#else
19689 mark_used(count)
19690 mark_used(comm)
19691 rb = reshape(sb, shape(rb))
19692#endif
19693 CALL mp_timestop(handle)
19694
19695 END SUBROUTINE mp_alltoall_r54
19696
19697! **************************************************************************************************
19698!> \brief Send one datum to another process
19699!> \param[in] msg Scalar to send
19700!> \param[in] dest Destination process
19701!> \param[in] tag Transfer identifier
19702!> \param[in] comm Message passing environment identifier
19703!> \par MPI mapping
19704!> mpi_send
19705! **************************************************************************************************
19706 SUBROUTINE mp_send_r (msg, dest, tag, comm)
19707 REAL(kind=real_4), INTENT(IN) :: msg
19708 INTEGER, INTENT(IN) :: dest, tag
19709 CLASS(mp_comm_type), INTENT(IN) :: comm
19710
19711 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_r'
19712
19713 INTEGER :: handle
19714#if defined(__parallel)
19715 INTEGER :: ierr, msglen
19716#endif
19717
19718 CALL mp_timeset(routinen, handle)
19719
19720#if defined(__parallel)
19721 msglen = 1
19722 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19723 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19724 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19725#else
19726 mark_used(msg)
19727 mark_used(dest)
19728 mark_used(tag)
19729 mark_used(comm)
19730 ! only defined in parallel
19731 cpabort("not in parallel mode")
19732#endif
19733 CALL mp_timestop(handle)
19734 END SUBROUTINE mp_send_r
19735
19736! **************************************************************************************************
19737!> \brief Send rank-1 data to another process
19738!> \param[in] msg Rank-1 data to send
19739!> \param dest ...
19740!> \param tag ...
19741!> \param comm ...
19742!> \note see mp_send_r
19743! **************************************************************************************************
19744 SUBROUTINE mp_send_rv(msg, dest, tag, comm)
19745 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
19746 INTEGER, INTENT(IN) :: dest, tag
19747 CLASS(mp_comm_type), INTENT(IN) :: comm
19748
19749 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_rv'
19750
19751 INTEGER :: handle
19752#if defined(__parallel)
19753 INTEGER :: ierr, msglen
19754#endif
19755
19756 CALL mp_timeset(routinen, handle)
19757
19758#if defined(__parallel)
19759 msglen = SIZE(msg)
19760 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19761 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19762 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19763#else
19764 mark_used(msg)
19765 mark_used(dest)
19766 mark_used(tag)
19767 mark_used(comm)
19768 ! only defined in parallel
19769 cpabort("not in parallel mode")
19770#endif
19771 CALL mp_timestop(handle)
19772 END SUBROUTINE mp_send_rv
19773
19774! **************************************************************************************************
19775!> \brief Send rank-2 data to another process
19776!> \param[in] msg Rank-2 data to send
19777!> \param dest ...
19778!> \param tag ...
19779!> \param comm ...
19780!> \note see mp_send_r
19781! **************************************************************************************************
19782 SUBROUTINE mp_send_rm2(msg, dest, tag, comm)
19783 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
19784 INTEGER, INTENT(IN) :: dest, tag
19785 CLASS(mp_comm_type), INTENT(IN) :: comm
19786
19787 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_rm2'
19788
19789 INTEGER :: handle
19790#if defined(__parallel)
19791 INTEGER :: ierr, msglen
19792#endif
19793
19794 CALL mp_timeset(routinen, handle)
19795
19796#if defined(__parallel)
19797 msglen = SIZE(msg)
19798 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19799 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19800 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19801#else
19802 mark_used(msg)
19803 mark_used(dest)
19804 mark_used(tag)
19805 mark_used(comm)
19806 ! only defined in parallel
19807 cpabort("not in parallel mode")
19808#endif
19809 CALL mp_timestop(handle)
19810 END SUBROUTINE mp_send_rm2
19811
19812! **************************************************************************************************
19813!> \brief Send rank-3 data to another process
19814!> \param[in] msg Rank-3 data to send
19815!> \param dest ...
19816!> \param tag ...
19817!> \param comm ...
19818!> \note see mp_send_r
19819! **************************************************************************************************
19820 SUBROUTINE mp_send_rm3(msg, dest, tag, comm)
19821 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
19822 INTEGER, INTENT(IN) :: dest, tag
19823 CLASS(mp_comm_type), INTENT(IN) :: comm
19824
19825 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
19826
19827 INTEGER :: handle
19828#if defined(__parallel)
19829 INTEGER :: ierr, msglen
19830#endif
19831
19832 CALL mp_timeset(routinen, handle)
19833
19834#if defined(__parallel)
19835 msglen = SIZE(msg)
19836 CALL mpi_send(msg, msglen, mpi_real, dest, tag, comm%handle, ierr)
19837 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
19838 CALL add_perf(perf_id=13, count=1, msg_size=msglen*real_4_size)
19839#else
19840 mark_used(msg)
19841 mark_used(dest)
19842 mark_used(tag)
19843 mark_used(comm)
19844 ! only defined in parallel
19845 cpabort("not in parallel mode")
19846#endif
19847 CALL mp_timestop(handle)
19848 END SUBROUTINE mp_send_rm3
19849
19850! **************************************************************************************************
19851!> \brief Receive one datum from another process
19852!> \param[in,out] msg Place received data into this variable
19853!> \param[in,out] source Process to receive from
19854!> \param[in,out] tag Transfer identifier
19855!> \param[in] comm Message passing environment identifier
19856!> \par MPI mapping
19857!> mpi_send
19858! **************************************************************************************************
19859 SUBROUTINE mp_recv_r (msg, source, tag, comm)
19860 REAL(kind=real_4), INTENT(INOUT) :: msg
19861 INTEGER, INTENT(INOUT) :: source, tag
19862 CLASS(mp_comm_type), INTENT(IN) :: comm
19863
19864 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_r'
19865
19866 INTEGER :: handle
19867#if defined(__parallel)
19868 INTEGER :: ierr, msglen
19869 mpi_status_type :: status
19870#endif
19871
19872 CALL mp_timeset(routinen, handle)
19873
19874#if defined(__parallel)
19875 msglen = 1
19876 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19877 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19878 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19879 ELSE
19880 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19881 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19882 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19883 source = status mpi_status_extract(mpi_source)
19884 tag = status mpi_status_extract(mpi_tag)
19885 END IF
19886#else
19887 mark_used(msg)
19888 mark_used(source)
19889 mark_used(tag)
19890 mark_used(comm)
19891 ! only defined in parallel
19892 cpabort("not in parallel mode")
19893#endif
19894 CALL mp_timestop(handle)
19895 END SUBROUTINE mp_recv_r
19896
19897! **************************************************************************************************
19898!> \brief Receive rank-1 data from another process
19899!> \param[in,out] msg Place received data into this rank-1 array
19900!> \param source ...
19901!> \param tag ...
19902!> \param comm ...
19903!> \note see mp_recv_r
19904! **************************************************************************************************
19905 SUBROUTINE mp_recv_rv(msg, source, tag, comm)
19906 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
19907 INTEGER, INTENT(INOUT) :: source, tag
19908 CLASS(mp_comm_type), INTENT(IN) :: comm
19909
19910 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rv'
19911
19912 INTEGER :: handle
19913#if defined(__parallel)
19914 INTEGER :: ierr, msglen
19915 mpi_status_type :: status
19916#endif
19917
19918 CALL mp_timeset(routinen, handle)
19919
19920#if defined(__parallel)
19921 msglen = SIZE(msg)
19922 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19923 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19924 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19925 ELSE
19926 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19927 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19928 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19929 source = status mpi_status_extract(mpi_source)
19930 tag = status mpi_status_extract(mpi_tag)
19931 END IF
19932#else
19933 mark_used(msg)
19934 mark_used(source)
19935 mark_used(tag)
19936 mark_used(comm)
19937 ! only defined in parallel
19938 cpabort("not in parallel mode")
19939#endif
19940 CALL mp_timestop(handle)
19941 END SUBROUTINE mp_recv_rv
19942
19943! **************************************************************************************************
19944!> \brief Receive rank-2 data from another process
19945!> \param[in,out] msg Place received data into this rank-2 array
19946!> \param source ...
19947!> \param tag ...
19948!> \param comm ...
19949!> \note see mp_recv_r
19950! **************************************************************************************************
19951 SUBROUTINE mp_recv_rm2(msg, source, tag, comm)
19952 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
19953 INTEGER, INTENT(INOUT) :: source, tag
19954 CLASS(mp_comm_type), INTENT(IN) :: comm
19955
19956 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rm2'
19957
19958 INTEGER :: handle
19959#if defined(__parallel)
19960 INTEGER :: ierr, msglen
19961 mpi_status_type :: status
19962#endif
19963
19964 CALL mp_timeset(routinen, handle)
19965
19966#if defined(__parallel)
19967 msglen = SIZE(msg)
19968 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
19969 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
19970 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19971 ELSE
19972 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
19973 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
19974 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
19975 source = status mpi_status_extract(mpi_source)
19976 tag = status mpi_status_extract(mpi_tag)
19977 END IF
19978#else
19979 mark_used(msg)
19980 mark_used(source)
19981 mark_used(tag)
19982 mark_used(comm)
19983 ! only defined in parallel
19984 cpabort("not in parallel mode")
19985#endif
19986 CALL mp_timestop(handle)
19987 END SUBROUTINE mp_recv_rm2
19988
19989! **************************************************************************************************
19990!> \brief Receive rank-3 data from another process
19991!> \param[in,out] msg Place received data into this rank-3 array
19992!> \param source ...
19993!> \param tag ...
19994!> \param comm ...
19995!> \note see mp_recv_r
19996! **************************************************************************************************
19997 SUBROUTINE mp_recv_rm3(msg, source, tag, comm)
19998 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
19999 INTEGER, INTENT(INOUT) :: source, tag
20000 CLASS(mp_comm_type), INTENT(IN) :: comm
20001
20002 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_rm3'
20003
20004 INTEGER :: handle
20005#if defined(__parallel)
20006 INTEGER :: ierr, msglen
20007 mpi_status_type :: status
20008#endif
20009
20010 CALL mp_timeset(routinen, handle)
20011
20012#if defined(__parallel)
20013 msglen = SIZE(msg)
20014 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
20015 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, mpi_status_ignore, ierr)
20016 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20017 ELSE
20018 CALL mpi_recv(msg, msglen, mpi_real, source, tag, comm%handle, status, ierr)
20019 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
20020 CALL add_perf(perf_id=14, count=1, msg_size=msglen*real_4_size)
20021 source = status mpi_status_extract(mpi_source)
20022 tag = status mpi_status_extract(mpi_tag)
20023 END IF
20024#else
20025 mark_used(msg)
20026 mark_used(source)
20027 mark_used(tag)
20028 mark_used(comm)
20029 ! only defined in parallel
20030 cpabort("not in parallel mode")
20031#endif
20032 CALL mp_timestop(handle)
20033 END SUBROUTINE mp_recv_rm3
20034
20035! **************************************************************************************************
20036!> \brief Broadcasts a datum to all processes.
20037!> \param[in] msg Datum to broadcast
20038!> \param[in] source Processes which broadcasts
20039!> \param[in] comm Message passing environment identifier
20040!> \par MPI mapping
20041!> mpi_bcast
20042! **************************************************************************************************
20043 SUBROUTINE mp_bcast_r (msg, source, comm)
20044 REAL(kind=real_4), INTENT(INOUT) :: msg
20045 INTEGER, INTENT(IN) :: source
20046 CLASS(mp_comm_type), INTENT(IN) :: comm
20047
20048 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r'
20049
20050 INTEGER :: handle
20051#if defined(__parallel)
20052 INTEGER :: ierr, msglen
20053#endif
20054
20055 CALL mp_timeset(routinen, handle)
20056
20057#if defined(__parallel)
20058 msglen = 1
20059 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20060 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20061 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20062#else
20063 mark_used(msg)
20064 mark_used(source)
20065 mark_used(comm)
20066#endif
20067 CALL mp_timestop(handle)
20068 END SUBROUTINE mp_bcast_r
20069
20070! **************************************************************************************************
20071!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
20072!> \param[in] msg Datum to broadcast
20073!> \param[in] comm Message passing environment identifier
20074!> \par MPI mapping
20075!> mpi_bcast
20076! **************************************************************************************************
20077 SUBROUTINE mp_bcast_r_src(msg, comm)
20078 REAL(kind=real_4), INTENT(INOUT) :: msg
20079 CLASS(mp_comm_type), INTENT(IN) :: comm
20080
20081 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r_src'
20082
20083 INTEGER :: handle
20084#if defined(__parallel)
20085 INTEGER :: ierr, msglen
20086#endif
20087
20088 CALL mp_timeset(routinen, handle)
20089
20090#if defined(__parallel)
20091 msglen = 1
20092 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20093 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20094 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20095#else
20096 mark_used(msg)
20097 mark_used(comm)
20098#endif
20099 CALL mp_timestop(handle)
20100 END SUBROUTINE mp_bcast_r_src
20101
20102! **************************************************************************************************
20103!> \brief Broadcasts a datum to all processes.
20104!> \param[in] msg Datum to broadcast
20105!> \param[in] source Processes which broadcasts
20106!> \param[in] comm Message passing environment identifier
20107!> \par MPI mapping
20108!> mpi_bcast
20109! **************************************************************************************************
20110 SUBROUTINE mp_ibcast_r (msg, source, comm, request)
20111 REAL(kind=real_4), INTENT(INOUT) :: msg
20112 INTEGER, INTENT(IN) :: source
20113 CLASS(mp_comm_type), INTENT(IN) :: comm
20114 TYPE(mp_request_type), INTENT(OUT) :: request
20115
20116 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_r'
20117
20118 INTEGER :: handle
20119#if defined(__parallel)
20120 INTEGER :: ierr, msglen
20121#endif
20122
20123 CALL mp_timeset(routinen, handle)
20124
20125#if defined(__parallel)
20126 msglen = 1
20127 CALL mpi_ibcast(msg, msglen, mpi_real, source, comm%handle, request%handle, ierr)
20128 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
20129 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_4_size)
20130#else
20131 mark_used(msg)
20132 mark_used(source)
20133 mark_used(comm)
20134 request = mp_request_null
20135#endif
20136 CALL mp_timestop(handle)
20137 END SUBROUTINE mp_ibcast_r
20138
20139! **************************************************************************************************
20140!> \brief Broadcasts rank-1 data to all processes
20141!> \param[in] msg Data to broadcast
20142!> \param source ...
20143!> \param comm ...
20144!> \note see mp_bcast_r1
20145! **************************************************************************************************
20146 SUBROUTINE mp_bcast_rv(msg, source, comm)
20147 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20148 INTEGER, INTENT(IN) :: source
20149 CLASS(mp_comm_type), INTENT(IN) :: comm
20150
20151 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rv'
20152
20153 INTEGER :: handle
20154#if defined(__parallel)
20155 INTEGER :: ierr, msglen
20156#endif
20157
20158 CALL mp_timeset(routinen, handle)
20159
20160#if defined(__parallel)
20161 msglen = SIZE(msg)
20162 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20163 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20164 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20165#else
20166 mark_used(msg)
20167 mark_used(source)
20168 mark_used(comm)
20169#endif
20170 CALL mp_timestop(handle)
20171 END SUBROUTINE mp_bcast_rv
20172
20173! **************************************************************************************************
20174!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
20175!> \param[in] msg Data to broadcast
20176!> \param comm ...
20177!> \note see mp_bcast_r1
20178! **************************************************************************************************
20179 SUBROUTINE mp_bcast_rv_src(msg, comm)
20180 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20181 CLASS(mp_comm_type), INTENT(IN) :: comm
20182
20183 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rv_src'
20184
20185 INTEGER :: handle
20186#if defined(__parallel)
20187 INTEGER :: ierr, msglen
20188#endif
20189
20190 CALL mp_timeset(routinen, handle)
20191
20192#if defined(__parallel)
20193 msglen = SIZE(msg)
20194 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20195 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20196 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20197#else
20198 mark_used(msg)
20199 mark_used(comm)
20200#endif
20201 CALL mp_timestop(handle)
20202 END SUBROUTINE mp_bcast_rv_src
20203
20204! **************************************************************************************************
20205!> \brief Broadcasts rank-1 data to all processes
20206!> \param[in] msg Data to broadcast
20207!> \param source ...
20208!> \param comm ...
20209!> \note see mp_bcast_r1
20210! **************************************************************************************************
20211 SUBROUTINE mp_ibcast_rv(msg, source, comm, request)
20212 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20213 INTEGER, INTENT(IN) :: source
20214 CLASS(mp_comm_type), INTENT(IN) :: comm
20215 TYPE(mp_request_type) :: request
20216
20217 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_rv'
20218
20219 INTEGER :: handle
20220#if defined(__parallel)
20221 INTEGER :: ierr, msglen
20222#endif
20223
20224 CALL mp_timeset(routinen, handle)
20225
20226#if defined(__parallel)
20227#if !defined(__GNUC__) || __GNUC__ >= 9
20228 cpassert(is_contiguous(msg))
20229#endif
20230 msglen = SIZE(msg)
20231 CALL mpi_ibcast(msg, msglen, mpi_real, source, comm%handle, request%handle, ierr)
20232 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
20233 CALL add_perf(perf_id=22, count=1, msg_size=msglen*real_4_size)
20234#else
20235 mark_used(msg)
20236 mark_used(source)
20237 mark_used(comm)
20238 request = mp_request_null
20239#endif
20240 CALL mp_timestop(handle)
20241 END SUBROUTINE mp_ibcast_rv
20242
20243! **************************************************************************************************
20244!> \brief Broadcasts rank-2 data to all processes
20245!> \param[in] msg Data to broadcast
20246!> \param source ...
20247!> \param comm ...
20248!> \note see mp_bcast_r1
20249! **************************************************************************************************
20250 SUBROUTINE mp_bcast_rm(msg, source, comm)
20251 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20252 INTEGER, INTENT(IN) :: source
20253 CLASS(mp_comm_type), INTENT(IN) :: comm
20254
20255 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rm'
20256
20257 INTEGER :: handle
20258#if defined(__parallel)
20259 INTEGER :: ierr, msglen
20260#endif
20261
20262 CALL mp_timeset(routinen, handle)
20263
20264#if defined(__parallel)
20265 msglen = SIZE(msg)
20266 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20267 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20268 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20269#else
20270 mark_used(msg)
20271 mark_used(source)
20272 mark_used(comm)
20273#endif
20274 CALL mp_timestop(handle)
20275 END SUBROUTINE mp_bcast_rm
20276
20277! **************************************************************************************************
20278!> \brief Broadcasts rank-2 data to all processes
20279!> \param[in] msg Data to broadcast
20280!> \param source ...
20281!> \param comm ...
20282!> \note see mp_bcast_r1
20283! **************************************************************************************************
20284 SUBROUTINE mp_bcast_rm_src(msg, comm)
20285 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20286 CLASS(mp_comm_type), INTENT(IN) :: comm
20287
20288 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_rm_src'
20289
20290 INTEGER :: handle
20291#if defined(__parallel)
20292 INTEGER :: ierr, msglen
20293#endif
20294
20295 CALL mp_timeset(routinen, handle)
20296
20297#if defined(__parallel)
20298 msglen = SIZE(msg)
20299 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20300 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20301 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20302#else
20303 mark_used(msg)
20304 mark_used(comm)
20305#endif
20306 CALL mp_timestop(handle)
20307 END SUBROUTINE mp_bcast_rm_src
20308
20309! **************************************************************************************************
20310!> \brief Broadcasts rank-3 data to all processes
20311!> \param[in] msg Data to broadcast
20312!> \param source ...
20313!> \param comm ...
20314!> \note see mp_bcast_r1
20315! **************************************************************************************************
20316 SUBROUTINE mp_bcast_r3(msg, source, comm)
20317 REAL(kind=real_4), CONTIGUOUS :: msg(:, :, :)
20318 INTEGER, INTENT(IN) :: source
20319 CLASS(mp_comm_type), INTENT(IN) :: comm
20320
20321 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r3'
20322
20323 INTEGER :: handle
20324#if defined(__parallel)
20325 INTEGER :: ierr, msglen
20326#endif
20327
20328 CALL mp_timeset(routinen, handle)
20329
20330#if defined(__parallel)
20331 msglen = SIZE(msg)
20332 CALL mpi_bcast(msg, msglen, mpi_real, source, comm%handle, ierr)
20333 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20334 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20335#else
20336 mark_used(msg)
20337 mark_used(source)
20338 mark_used(comm)
20339#endif
20340 CALL mp_timestop(handle)
20341 END SUBROUTINE mp_bcast_r3
20342
20343! **************************************************************************************************
20344!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
20345!> \param[in] msg Data to broadcast
20346!> \param source ...
20347!> \param comm ...
20348!> \note see mp_bcast_r1
20349! **************************************************************************************************
20350 SUBROUTINE mp_bcast_r3_src(msg, comm)
20351 REAL(kind=real_4), CONTIGUOUS :: msg(:, :, :)
20352 CLASS(mp_comm_type), INTENT(IN) :: comm
20353
20354 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_r3_src'
20355
20356 INTEGER :: handle
20357#if defined(__parallel)
20358 INTEGER :: ierr, msglen
20359#endif
20360
20361 CALL mp_timeset(routinen, handle)
20362
20363#if defined(__parallel)
20364 msglen = SIZE(msg)
20365 CALL mpi_bcast(msg, msglen, mpi_real, comm%source, comm%handle, ierr)
20366 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
20367 CALL add_perf(perf_id=2, count=1, msg_size=msglen*real_4_size)
20368#else
20369 mark_used(msg)
20370 mark_used(comm)
20371#endif
20372 CALL mp_timestop(handle)
20373 END SUBROUTINE mp_bcast_r3_src
20374
20375! **************************************************************************************************
20376!> \brief Sums a datum from all processes with result left on all processes.
20377!> \param[in,out] msg Datum to sum (input) and result (output)
20378!> \param[in] comm Message passing environment identifier
20379!> \par MPI mapping
20380!> mpi_allreduce
20381! **************************************************************************************************
20382 SUBROUTINE mp_sum_r (msg, comm)
20383 REAL(kind=real_4), INTENT(INOUT) :: msg
20384 CLASS(mp_comm_type), INTENT(IN) :: comm
20385
20386 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_r'
20387
20388 INTEGER :: handle
20389#if defined(__parallel)
20390 INTEGER :: ierr, msglen
20391#endif
20392
20393 CALL mp_timeset(routinen, handle)
20394
20395#if defined(__parallel)
20396 msglen = 1
20397 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20398 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20399 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20400#else
20401 mark_used(msg)
20402 mark_used(comm)
20403#endif
20404 CALL mp_timestop(handle)
20405 END SUBROUTINE mp_sum_r
20406
20407! **************************************************************************************************
20408!> \brief Element-wise sum of a rank-1 array on all processes.
20409!> \param[in,out] msg Vector to sum and result
20410!> \param comm ...
20411!> \note see mp_sum_r
20412! **************************************************************************************************
20413 SUBROUTINE mp_sum_rv(msg, comm)
20414 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20415 CLASS(mp_comm_type), INTENT(IN) :: comm
20416
20417 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rv'
20418
20419 INTEGER :: handle
20420#if defined(__parallel)
20421 INTEGER :: ierr, msglen
20422#endif
20423
20424 CALL mp_timeset(routinen, handle)
20425
20426#if defined(__parallel)
20427 msglen = SIZE(msg)
20428 IF (msglen > 0) THEN
20429 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20430 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20431 END IF
20432 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20433#else
20434 mark_used(msg)
20435 mark_used(comm)
20436#endif
20437 CALL mp_timestop(handle)
20438 END SUBROUTINE mp_sum_rv
20439
20440! **************************************************************************************************
20441!> \brief Element-wise sum of a rank-1 array on all processes.
20442!> \param[in,out] msg Vector to sum and result
20443!> \param comm ...
20444!> \note see mp_sum_r
20445! **************************************************************************************************
20446 SUBROUTINE mp_isum_rv(msg, comm, request)
20447 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
20448 CLASS(mp_comm_type), INTENT(IN) :: comm
20449 TYPE(mp_request_type), INTENT(OUT) :: request
20450
20451 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_rv'
20452
20453 INTEGER :: handle
20454#if defined(__parallel)
20455 INTEGER :: ierr, msglen
20456#endif
20457
20458 CALL mp_timeset(routinen, handle)
20459
20460#if defined(__parallel)
20461#if !defined(__GNUC__) || __GNUC__ >= 9
20462 cpassert(is_contiguous(msg))
20463#endif
20464 msglen = SIZE(msg)
20465 IF (msglen > 0) THEN
20466 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, request%handle, ierr)
20467 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
20468 ELSE
20469 request = mp_request_null
20470 END IF
20471 CALL add_perf(perf_id=23, count=1, msg_size=msglen*real_4_size)
20472#else
20473 mark_used(msg)
20474 mark_used(comm)
20475 request = mp_request_null
20476#endif
20477 CALL mp_timestop(handle)
20478 END SUBROUTINE mp_isum_rv
20479
20480! **************************************************************************************************
20481!> \brief Element-wise sum of a rank-2 array on all processes.
20482!> \param[in] msg Matrix to sum and result
20483!> \param comm ...
20484!> \note see mp_sum_r
20485! **************************************************************************************************
20486 SUBROUTINE mp_sum_rm(msg, comm)
20487 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20488 CLASS(mp_comm_type), INTENT(IN) :: comm
20489
20490 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm'
20491
20492 INTEGER :: handle
20493#if defined(__parallel)
20494 INTEGER, PARAMETER :: max_msg = 2**25
20495 INTEGER :: ierr, m1, msglen, step, msglensum
20496#endif
20497
20498 CALL mp_timeset(routinen, handle)
20499
20500#if defined(__parallel)
20501 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
20502 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
20503 msglensum = 0
20504 DO m1 = lbound(msg, 2), ubound(msg, 2), step
20505 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
20506 msglensum = msglensum + msglen
20507 IF (msglen > 0) THEN
20508 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_real, mpi_sum, comm%handle, ierr)
20509 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20510 END IF
20511 END DO
20512 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*real_4_size)
20513#else
20514 mark_used(msg)
20515 mark_used(comm)
20516#endif
20517 CALL mp_timestop(handle)
20518 END SUBROUTINE mp_sum_rm
20519
20520! **************************************************************************************************
20521!> \brief Element-wise sum of a rank-3 array on all processes.
20522!> \param[in] msg Array to sum and result
20523!> \param comm ...
20524!> \note see mp_sum_r
20525! **************************************************************************************************
20526 SUBROUTINE mp_sum_rm3(msg, comm)
20527 REAL(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
20528 CLASS(mp_comm_type), INTENT(IN) :: comm
20529
20530 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm3'
20531
20532 INTEGER :: handle
20533#if defined(__parallel)
20534 INTEGER :: ierr, msglen
20535#endif
20536
20537 CALL mp_timeset(routinen, handle)
20538
20539#if defined(__parallel)
20540 msglen = SIZE(msg)
20541 IF (msglen > 0) THEN
20542 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20543 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20544 END IF
20545 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20546#else
20547 mark_used(msg)
20548 mark_used(comm)
20549#endif
20550 CALL mp_timestop(handle)
20551 END SUBROUTINE mp_sum_rm3
20552
20553! **************************************************************************************************
20554!> \brief Element-wise sum of a rank-4 array on all processes.
20555!> \param[in] msg Array to sum and result
20556!> \param comm ...
20557!> \note see mp_sum_r
20558! **************************************************************************************************
20559 SUBROUTINE mp_sum_rm4(msg, comm)
20560 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
20561 CLASS(mp_comm_type), INTENT(IN) :: comm
20562
20563 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_rm4'
20564
20565 INTEGER :: handle
20566#if defined(__parallel)
20567 INTEGER :: ierr, msglen
20568#endif
20569
20570 CALL mp_timeset(routinen, handle)
20571
20572#if defined(__parallel)
20573 msglen = SIZE(msg)
20574 IF (msglen > 0) THEN
20575 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20576 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20577 END IF
20578 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20579#else
20580 mark_used(msg)
20581 mark_used(comm)
20582#endif
20583 CALL mp_timestop(handle)
20584 END SUBROUTINE mp_sum_rm4
20585
20586! **************************************************************************************************
20587!> \brief Element-wise sum of data from all processes with result left only on
20588!> one.
20589!> \param[in,out] msg Vector to sum (input) and (only on process root)
20590!> result (output)
20591!> \param root ...
20592!> \param[in] comm Message passing environment identifier
20593!> \par MPI mapping
20594!> mpi_reduce
20595! **************************************************************************************************
20596 SUBROUTINE mp_sum_root_rv(msg, root, comm)
20597 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20598 INTEGER, INTENT(IN) :: root
20599 CLASS(mp_comm_type), INTENT(IN) :: comm
20600
20601 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rv'
20602
20603 INTEGER :: handle
20604#if defined(__parallel)
20605 INTEGER :: ierr, m1, msglen, taskid
20606 REAL(kind=real_4), ALLOCATABLE :: res(:)
20607#endif
20608
20609 CALL mp_timeset(routinen, handle)
20610
20611#if defined(__parallel)
20612 msglen = SIZE(msg)
20613 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20614 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20615 IF (msglen > 0) THEN
20616 m1 = SIZE(msg, 1)
20617 ALLOCATE (res(m1))
20618 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_sum, &
20619 root, comm%handle, ierr)
20620 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20621 IF (taskid == root) THEN
20622 msg = res
20623 END IF
20624 DEALLOCATE (res)
20625 END IF
20626 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20627#else
20628 mark_used(msg)
20629 mark_used(root)
20630 mark_used(comm)
20631#endif
20632 CALL mp_timestop(handle)
20633 END SUBROUTINE mp_sum_root_rv
20634
20635! **************************************************************************************************
20636!> \brief Element-wise sum of data from all processes with result left only on
20637!> one.
20638!> \param[in,out] msg Matrix to sum (input) and (only on process root)
20639!> result (output)
20640!> \param root ...
20641!> \param comm ...
20642!> \note see mp_sum_root_rv
20643! **************************************************************************************************
20644 SUBROUTINE mp_sum_root_rm(msg, root, comm)
20645 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20646 INTEGER, INTENT(IN) :: root
20647 CLASS(mp_comm_type), INTENT(IN) :: comm
20648
20649 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
20650
20651 INTEGER :: handle
20652#if defined(__parallel)
20653 INTEGER :: ierr, m1, m2, msglen, taskid
20654 REAL(kind=real_4), ALLOCATABLE :: res(:, :)
20655#endif
20656
20657 CALL mp_timeset(routinen, handle)
20658
20659#if defined(__parallel)
20660 msglen = SIZE(msg)
20661 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20662 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20663 IF (msglen > 0) THEN
20664 m1 = SIZE(msg, 1)
20665 m2 = SIZE(msg, 2)
20666 ALLOCATE (res(m1, m2))
20667 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_sum, root, comm%handle, ierr)
20668 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20669 IF (taskid == root) THEN
20670 msg = res
20671 END IF
20672 DEALLOCATE (res)
20673 END IF
20674 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20675#else
20676 mark_used(root)
20677 mark_used(msg)
20678 mark_used(comm)
20679#endif
20680 CALL mp_timestop(handle)
20681 END SUBROUTINE mp_sum_root_rm
20682
20683! **************************************************************************************************
20684!> \brief Partial sum of data from all processes with result on each process.
20685!> \param[in] msg Matrix to sum (input)
20686!> \param[out] res Matrix containing result (output)
20687!> \param[in] comm Message passing environment identifier
20688! **************************************************************************************************
20689 SUBROUTINE mp_sum_partial_rm(msg, res, comm)
20690 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
20691 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
20692 CLASS(mp_comm_type), INTENT(IN) :: comm
20693
20694 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_rm'
20695
20696 INTEGER :: handle
20697#if defined(__parallel)
20698 INTEGER :: ierr, msglen, taskid
20699#endif
20700
20701 CALL mp_timeset(routinen, handle)
20702
20703#if defined(__parallel)
20704 msglen = SIZE(msg)
20705 CALL mpi_comm_rank(comm%handle, taskid, ierr)
20706 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
20707 IF (msglen > 0) THEN
20708 CALL mpi_scan(msg, res, msglen, mpi_real, mpi_sum, comm%handle, ierr)
20709 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
20710 END IF
20711 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20712 ! perf_id is same as for other summation routines
20713#else
20714 res = msg
20715 mark_used(comm)
20716#endif
20717 CALL mp_timestop(handle)
20718 END SUBROUTINE mp_sum_partial_rm
20719
20720! **************************************************************************************************
20721!> \brief Finds the maximum of a datum with the result left on all processes.
20722!> \param[in,out] msg Find maximum among these data (input) and
20723!> maximum (output)
20724!> \param[in] comm Message passing environment identifier
20725!> \par MPI mapping
20726!> mpi_allreduce
20727! **************************************************************************************************
20728 SUBROUTINE mp_max_r (msg, comm)
20729 REAL(kind=real_4), INTENT(INOUT) :: msg
20730 CLASS(mp_comm_type), INTENT(IN) :: comm
20731
20732 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_r'
20733
20734 INTEGER :: handle
20735#if defined(__parallel)
20736 INTEGER :: ierr, msglen
20737#endif
20738
20739 CALL mp_timeset(routinen, handle)
20740
20741#if defined(__parallel)
20742 msglen = 1
20743 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_max, comm%handle, ierr)
20744 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
20750 CALL mp_timestop(handle)
20751 END SUBROUTINE mp_max_r
20752
20753! **************************************************************************************************
20754!> \brief Finds the maximum of a datum with the result left on all processes.
20755!> \param[in,out] msg Find maximum among these data (input) and
20756!> maximum (output)
20757!> \param[in] comm Message passing environment identifier
20758!> \par MPI mapping
20759!> mpi_allreduce
20760! **************************************************************************************************
20761 SUBROUTINE mp_max_root_r (msg, root, comm)
20762 REAL(kind=real_4), INTENT(INOUT) :: msg
20763 INTEGER, INTENT(IN) :: root
20764 CLASS(mp_comm_type), INTENT(IN) :: comm
20765
20766 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_r'
20767
20768 INTEGER :: handle
20769#if defined(__parallel)
20770 INTEGER :: ierr, msglen
20771 REAL(kind=real_4) :: res
20772#endif
20773
20774 CALL mp_timeset(routinen, handle)
20775
20776#if defined(__parallel)
20777 msglen = 1
20778 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_max, root, comm%handle, ierr)
20779 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
20780 IF (root == comm%mepos) msg = res
20781 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20782#else
20783 mark_used(msg)
20784 mark_used(comm)
20785 mark_used(root)
20786#endif
20787 CALL mp_timestop(handle)
20788 END SUBROUTINE mp_max_root_r
20789
20790! **************************************************************************************************
20791!> \brief Finds the element-wise maximum of a vector with the result left on
20792!> all processes.
20793!> \param[in,out] msg Find maximum among these data (input) and
20794!> maximum (output)
20795!> \param comm ...
20796!> \note see mp_max_r
20797! **************************************************************************************************
20798 SUBROUTINE mp_max_rv(msg, comm)
20799 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
20800 CLASS(mp_comm_type), INTENT(IN) :: comm
20801
20802 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_rv'
20803
20804 INTEGER :: handle
20805#if defined(__parallel)
20806 INTEGER :: ierr, msglen
20807#endif
20808
20809 CALL mp_timeset(routinen, handle)
20810
20811#if defined(__parallel)
20812 msglen = SIZE(msg)
20813 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_max, comm%handle, ierr)
20814 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
20820 CALL mp_timestop(handle)
20821 END SUBROUTINE mp_max_rv
20822
20823! **************************************************************************************************
20824!> \brief Finds the element-wise maximum of a vector with the result left on
20825!> all processes.
20826!> \param[in,out] msg Find maximum among these data (input) and
20827!> maximum (output)
20828!> \param comm ...
20829!> \note see mp_max_r
20830! **************************************************************************************************
20831 SUBROUTINE mp_max_root_rm(msg, root, comm)
20832 REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
20833 INTEGER :: root
20834 CLASS(mp_comm_type), INTENT(IN) :: comm
20835
20836 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_rm'
20837
20838 INTEGER :: handle
20839#if defined(__parallel)
20840 INTEGER :: ierr, msglen
20841 REAL(kind=real_4) :: res(SIZE(msg, 1), SIZE(msg, 2))
20842#endif
20843
20844 CALL mp_timeset(routinen, handle)
20845
20846#if defined(__parallel)
20847 msglen = SIZE(msg)
20848 CALL mpi_reduce(msg, res, msglen, mpi_real, mpi_max, root, comm%handle, ierr)
20849 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20850 IF (root == comm%mepos) msg = res
20851 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20852#else
20853 mark_used(msg)
20854 mark_used(comm)
20855 mark_used(root)
20856#endif
20857 CALL mp_timestop(handle)
20858 END SUBROUTINE mp_max_root_rm
20859
20860! **************************************************************************************************
20861!> \brief Finds the minimum of a datum with the result left on all processes.
20862!> \param[in,out] msg Find minimum among these data (input) and
20863!> maximum (output)
20864!> \param[in] comm Message passing environment identifier
20865!> \par MPI mapping
20866!> mpi_allreduce
20867! **************************************************************************************************
20868 SUBROUTINE mp_min_r (msg, comm)
20869 REAL(kind=real_4), INTENT(INOUT) :: msg
20870 CLASS(mp_comm_type), INTENT(IN) :: comm
20871
20872 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_r'
20873
20874 INTEGER :: handle
20875#if defined(__parallel)
20876 INTEGER :: ierr, msglen
20877#endif
20878
20879 CALL mp_timeset(routinen, handle)
20880
20881#if defined(__parallel)
20882 msglen = 1
20883 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_min, comm%handle, ierr)
20884 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20885 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20886#else
20887 mark_used(msg)
20888 mark_used(comm)
20889#endif
20890 CALL mp_timestop(handle)
20891 END SUBROUTINE mp_min_r
20892
20893! **************************************************************************************************
20894!> \brief Finds the element-wise minimum of vector with the result left on
20895!> all processes.
20896!> \param[in,out] msg Find minimum among these data (input) and
20897!> maximum (output)
20898!> \param comm ...
20899!> \par MPI mapping
20900!> mpi_allreduce
20901!> \note see mp_min_r
20902! **************************************************************************************************
20903 SUBROUTINE mp_min_rv(msg, comm)
20904 REAL(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
20905 CLASS(mp_comm_type), INTENT(IN) :: comm
20906
20907 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_rv'
20908
20909 INTEGER :: handle
20910#if defined(__parallel)
20911 INTEGER :: ierr, msglen
20912#endif
20913
20914 CALL mp_timeset(routinen, handle)
20915
20916#if defined(__parallel)
20917 msglen = SIZE(msg)
20918 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_min, comm%handle, ierr)
20919 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20920 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20921#else
20922 mark_used(msg)
20923 mark_used(comm)
20924#endif
20925 CALL mp_timestop(handle)
20926 END SUBROUTINE mp_min_rv
20927
20928! **************************************************************************************************
20929!> \brief Multiplies a set of numbers scattered across a number of processes,
20930!> then replicates the result.
20931!> \param[in,out] msg a number to multiply (input) and result (output)
20932!> \param[in] comm message passing environment identifier
20933!> \par MPI mapping
20934!> mpi_allreduce
20935! **************************************************************************************************
20936 SUBROUTINE mp_prod_r (msg, comm)
20937 REAL(kind=real_4), INTENT(INOUT) :: msg
20938 CLASS(mp_comm_type), INTENT(IN) :: comm
20939
20940 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_r'
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 = 1
20951 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_real, mpi_prod, comm%handle, ierr)
20952 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
20953 CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
20954#else
20955 mark_used(msg)
20956 mark_used(comm)
20957#endif
20958 CALL mp_timestop(handle)
20959 END SUBROUTINE mp_prod_r
20960
20961! **************************************************************************************************
20962!> \brief Scatters data from one processes to all others
20963!> \param[in] msg_scatter Data to scatter (for root process)
20964!> \param[out] msg Received data
20965!> \param[in] root Process which scatters data
20966!> \param[in] comm Message passing environment identifier
20967!> \par MPI mapping
20968!> mpi_scatter
20969! **************************************************************************************************
20970 SUBROUTINE mp_scatter_rv(msg_scatter, msg, root, comm)
20971 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
20972 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
20973 INTEGER, INTENT(IN) :: root
20974 CLASS(mp_comm_type), INTENT(IN) :: comm
20975
20976 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_rv'
20977
20978 INTEGER :: handle
20979#if defined(__parallel)
20980 INTEGER :: ierr, msglen
20981#endif
20982
20983 CALL mp_timeset(routinen, handle)
20984
20985#if defined(__parallel)
20986 msglen = SIZE(msg)
20987 CALL mpi_scatter(msg_scatter, msglen, mpi_real, msg, &
20988 msglen, mpi_real, root, comm%handle, ierr)
20989 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
20990 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
20991#else
20992 mark_used(root)
20993 mark_used(comm)
20994 msg = msg_scatter
20995#endif
20996 CALL mp_timestop(handle)
20997 END SUBROUTINE mp_scatter_rv
20998
20999! **************************************************************************************************
21000!> \brief Scatters data from one processes to all others
21001!> \param[in] msg_scatter Data to scatter (for root process)
21002!> \param[in] root Process which scatters data
21003!> \param[in] comm Message passing environment identifier
21004!> \par MPI mapping
21005!> mpi_scatter
21006! **************************************************************************************************
21007 SUBROUTINE mp_iscatter_r (msg_scatter, msg, root, comm, request)
21008 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:)
21009 REAL(kind=real_4), INTENT(INOUT) :: msg
21010 INTEGER, INTENT(IN) :: root
21011 CLASS(mp_comm_type), INTENT(IN) :: comm
21012 TYPE(mp_request_type), INTENT(OUT) :: request
21013
21014 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_r'
21015
21016 INTEGER :: handle
21017#if defined(__parallel)
21018 INTEGER :: ierr, msglen
21019#endif
21020
21021 CALL mp_timeset(routinen, handle)
21022
21023#if defined(__parallel)
21024#if !defined(__GNUC__) || __GNUC__ >= 9
21025 cpassert(is_contiguous(msg_scatter))
21026#endif
21027 msglen = 1
21028 CALL mpi_iscatter(msg_scatter, msglen, mpi_real, msg, &
21029 msglen, mpi_real, root, comm%handle, request%handle, ierr)
21030 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
21031 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
21032#else
21033 mark_used(root)
21034 mark_used(comm)
21035 msg = msg_scatter(1)
21036 request = mp_request_null
21037#endif
21038 CALL mp_timestop(handle)
21039 END SUBROUTINE mp_iscatter_r
21040
21041! **************************************************************************************************
21042!> \brief Scatters data from one processes to all others
21043!> \param[in] msg_scatter Data to scatter (for root process)
21044!> \param[in] root Process which scatters data
21045!> \param[in] comm Message passing environment identifier
21046!> \par MPI mapping
21047!> mpi_scatter
21048! **************************************************************************************************
21049 SUBROUTINE mp_iscatter_rv2(msg_scatter, msg, root, comm, request)
21050 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:, :)
21051 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
21052 INTEGER, INTENT(IN) :: root
21053 CLASS(mp_comm_type), INTENT(IN) :: comm
21054 TYPE(mp_request_type), INTENT(OUT) :: request
21055
21056 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_rv2'
21057
21058 INTEGER :: handle
21059#if defined(__parallel)
21060 INTEGER :: ierr, msglen
21061#endif
21062
21063 CALL mp_timeset(routinen, handle)
21064
21065#if defined(__parallel)
21066#if !defined(__GNUC__) || __GNUC__ >= 9
21067 cpassert(is_contiguous(msg_scatter))
21068#endif
21069 msglen = SIZE(msg)
21070 CALL mpi_iscatter(msg_scatter, msglen, mpi_real, msg, &
21071 msglen, mpi_real, root, comm%handle, request%handle, ierr)
21072 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
21073 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
21074#else
21075 mark_used(root)
21076 mark_used(comm)
21077 msg(:) = msg_scatter(:, 1)
21078 request = mp_request_null
21079#endif
21080 CALL mp_timestop(handle)
21081 END SUBROUTINE mp_iscatter_rv2
21082
21083! **************************************************************************************************
21084!> \brief Scatters data from one processes to all others
21085!> \param[in] msg_scatter Data to scatter (for root process)
21086!> \param[in] root Process which scatters data
21087!> \param[in] comm Message passing environment identifier
21088!> \par MPI mapping
21089!> mpi_scatter
21090! **************************************************************************************************
21091 SUBROUTINE mp_iscatterv_rv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
21092 REAL(kind=real_4), INTENT(IN) :: msg_scatter(:)
21093 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
21094 REAL(kind=real_4), INTENT(INOUT) :: msg(:)
21095 INTEGER, INTENT(IN) :: recvcount, root
21096 CLASS(mp_comm_type), INTENT(IN) :: comm
21097 TYPE(mp_request_type), INTENT(OUT) :: request
21098
21099 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_rv'
21100
21101 INTEGER :: handle
21102#if defined(__parallel)
21103 INTEGER :: ierr
21104#endif
21105
21106 CALL mp_timeset(routinen, handle)
21107
21108#if defined(__parallel)
21109#if !defined(__GNUC__) || __GNUC__ >= 9
21110 cpassert(is_contiguous(msg_scatter))
21111 cpassert(is_contiguous(msg))
21112 cpassert(is_contiguous(sendcounts))
21113 cpassert(is_contiguous(displs))
21114#endif
21115 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_real, msg, &
21116 recvcount, mpi_real, root, comm%handle, request%handle, ierr)
21117 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
21118 CALL add_perf(perf_id=24, count=1, msg_size=1*real_4_size)
21119#else
21120 mark_used(sendcounts)
21121 mark_used(displs)
21122 mark_used(recvcount)
21123 mark_used(root)
21124 mark_used(comm)
21125 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
21126 request = mp_request_null
21127#endif
21128 CALL mp_timestop(handle)
21129 END SUBROUTINE mp_iscatterv_rv
21130
21131! **************************************************************************************************
21132!> \brief Gathers a datum from all processes to one
21133!> \param[in] msg Datum to send to root
21134!> \param[out] msg_gather Received data (on root)
21135!> \param[in] root Process which gathers the data
21136!> \param[in] comm Message passing environment identifier
21137!> \par MPI mapping
21138!> mpi_gather
21139! **************************************************************************************************
21140 SUBROUTINE mp_gather_r (msg, msg_gather, root, comm)
21141 REAL(kind=real_4), INTENT(IN) :: msg
21142 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21143 INTEGER, INTENT(IN) :: root
21144 CLASS(mp_comm_type), INTENT(IN) :: comm
21145
21146 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_r'
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, root, 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(root)
21163 mark_used(comm)
21164 msg_gather(1) = msg
21165#endif
21166 CALL mp_timestop(handle)
21167 END SUBROUTINE mp_gather_r
21168
21169! **************************************************************************************************
21170!> \brief Gathers a datum from all processes to one, uses the source process of comm
21171!> \param[in] msg Datum to send to root
21172!> \param[out] msg_gather Received data (on root)
21173!> \param[in] comm Message passing environment identifier
21174!> \par MPI mapping
21175!> mpi_gather
21176! **************************************************************************************************
21177 SUBROUTINE mp_gather_r_src(msg, msg_gather, comm)
21178 REAL(kind=real_4), INTENT(IN) :: msg
21179 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21180 CLASS(mp_comm_type), INTENT(IN) :: comm
21181
21182 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_r_src'
21183
21184 INTEGER :: handle
21185#if defined(__parallel)
21186 INTEGER :: ierr, msglen
21187#endif
21188
21189 CALL mp_timeset(routinen, handle)
21190
21191#if defined(__parallel)
21192 msglen = 1
21193 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21194 msglen, mpi_real, comm%source, comm%handle, ierr)
21195 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21196 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21197#else
21198 mark_used(comm)
21199 msg_gather(1) = msg
21200#endif
21201 CALL mp_timestop(handle)
21202 END SUBROUTINE mp_gather_r_src
21203
21204! **************************************************************************************************
21205!> \brief Gathers data from all processes to one
21206!> \param[in] msg Datum to send to root
21207!> \param msg_gather ...
21208!> \param root ...
21209!> \param comm ...
21210!> \par Data length
21211!> All data (msg) is equal-sized
21212!> \par MPI mapping
21213!> mpi_gather
21214!> \note see mp_gather_r
21215! **************************************************************************************************
21216 SUBROUTINE mp_gather_rv(msg, msg_gather, root, comm)
21217 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
21218 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21219 INTEGER, INTENT(IN) :: root
21220 CLASS(mp_comm_type), INTENT(IN) :: comm
21221
21222 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rv'
21223
21224 INTEGER :: handle
21225#if defined(__parallel)
21226 INTEGER :: ierr, msglen
21227#endif
21228
21229 CALL mp_timeset(routinen, handle)
21230
21231#if defined(__parallel)
21232 msglen = SIZE(msg)
21233 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21234 msglen, mpi_real, root, comm%handle, ierr)
21235 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21236 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21237#else
21238 mark_used(root)
21239 mark_used(comm)
21240 msg_gather = msg
21241#endif
21242 CALL mp_timestop(handle)
21243 END SUBROUTINE mp_gather_rv
21244
21245! **************************************************************************************************
21246!> \brief Gathers data from all processes to one. Gathers from comm%source
21247!> \param[in] msg Datum to send to root
21248!> \param msg_gather ...
21249!> \param comm ...
21250!> \par Data length
21251!> All data (msg) is equal-sized
21252!> \par MPI mapping
21253!> mpi_gather
21254!> \note see mp_gather_r
21255! **************************************************************************************************
21256 SUBROUTINE mp_gather_rv_src(msg, msg_gather, comm)
21257 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
21258 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
21259 CLASS(mp_comm_type), INTENT(IN) :: comm
21260
21261 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rv_src'
21262
21263 INTEGER :: handle
21264#if defined(__parallel)
21265 INTEGER :: ierr, msglen
21266#endif
21267
21268 CALL mp_timeset(routinen, handle)
21269
21270#if defined(__parallel)
21271 msglen = SIZE(msg)
21272 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21273 msglen, mpi_real, comm%source, comm%handle, ierr)
21274 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21275 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21276#else
21277 mark_used(comm)
21278 msg_gather = msg
21279#endif
21280 CALL mp_timestop(handle)
21281 END SUBROUTINE mp_gather_rv_src
21282
21283! **************************************************************************************************
21284!> \brief Gathers data from all processes to one
21285!> \param[in] msg Datum to send to root
21286!> \param msg_gather ...
21287!> \param root ...
21288!> \param comm ...
21289!> \par Data length
21290!> All data (msg) is equal-sized
21291!> \par MPI mapping
21292!> mpi_gather
21293!> \note see mp_gather_r
21294! **************************************************************************************************
21295 SUBROUTINE mp_gather_rm(msg, msg_gather, root, comm)
21296 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
21297 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
21298 INTEGER, INTENT(IN) :: root
21299 CLASS(mp_comm_type), INTENT(IN) :: comm
21300
21301 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rm'
21302
21303 INTEGER :: handle
21304#if defined(__parallel)
21305 INTEGER :: ierr, msglen
21306#endif
21307
21308 CALL mp_timeset(routinen, handle)
21309
21310#if defined(__parallel)
21311 msglen = SIZE(msg)
21312 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21313 msglen, mpi_real, root, comm%handle, ierr)
21314 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21315 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21316#else
21317 mark_used(root)
21318 mark_used(comm)
21319 msg_gather = msg
21320#endif
21321 CALL mp_timestop(handle)
21322 END SUBROUTINE mp_gather_rm
21323
21324! **************************************************************************************************
21325!> \brief Gathers data from all processes to one. Gathers from comm%source
21326!> \param[in] msg Datum to send to root
21327!> \param msg_gather ...
21328!> \param comm ...
21329!> \par Data length
21330!> All data (msg) is equal-sized
21331!> \par MPI mapping
21332!> mpi_gather
21333!> \note see mp_gather_r
21334! **************************************************************************************************
21335 SUBROUTINE mp_gather_rm_src(msg, msg_gather, comm)
21336 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
21337 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
21338 CLASS(mp_comm_type), INTENT(IN) :: comm
21339
21340 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_rm_src'
21341
21342 INTEGER :: handle
21343#if defined(__parallel)
21344 INTEGER :: ierr, msglen
21345#endif
21346
21347 CALL mp_timeset(routinen, handle)
21348
21349#if defined(__parallel)
21350 msglen = SIZE(msg)
21351 CALL mpi_gather(msg, msglen, mpi_real, msg_gather, &
21352 msglen, mpi_real, comm%source, comm%handle, ierr)
21353 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
21354 CALL add_perf(perf_id=4, count=1, msg_size=msglen*real_4_size)
21355#else
21356 mark_used(comm)
21357 msg_gather = msg
21358#endif
21359 CALL mp_timestop(handle)
21360 END SUBROUTINE mp_gather_rm_src
21361
21362! **************************************************************************************************
21363!> \brief Gathers data from all processes to one.
21364!> \param[in] sendbuf Data to send to root
21365!> \param[out] recvbuf Received data (on root)
21366!> \param[in] recvcounts Sizes of data received from processes
21367!> \param[in] displs Offsets of data received from processes
21368!> \param[in] root Process which gathers the data
21369!> \param[in] comm Message passing environment identifier
21370!> \par Data length
21371!> Data can have different lengths
21372!> \par Offsets
21373!> Offsets start at 0
21374!> \par MPI mapping
21375!> mpi_gather
21376! **************************************************************************************************
21377 SUBROUTINE mp_gatherv_rv(sendbuf, recvbuf, recvcounts, displs, root, comm)
21378
21379 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
21380 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
21381 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21382 INTEGER, INTENT(IN) :: root
21383 CLASS(mp_comm_type), INTENT(IN) :: comm
21384
21385 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rv'
21386
21387 INTEGER :: handle
21388#if defined(__parallel)
21389 INTEGER :: ierr, sendcount
21390#endif
21391
21392 CALL mp_timeset(routinen, handle)
21393
21394#if defined(__parallel)
21395 sendcount = SIZE(sendbuf)
21396 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21397 recvbuf, recvcounts, displs, mpi_real, &
21398 root, comm%handle, ierr)
21399 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21400 CALL add_perf(perf_id=4, &
21401 count=1, &
21402 msg_size=sendcount*real_4_size)
21403#else
21404 mark_used(recvcounts)
21405 mark_used(root)
21406 mark_used(comm)
21407 recvbuf(1 + displs(1):) = sendbuf
21408#endif
21409 CALL mp_timestop(handle)
21410 END SUBROUTINE mp_gatherv_rv
21411
21412! **************************************************************************************************
21413!> \brief Gathers data from all processes to one. Gathers from comm%source
21414!> \param[in] sendbuf Data to send to root
21415!> \param[out] recvbuf Received data (on root)
21416!> \param[in] recvcounts Sizes of data received from processes
21417!> \param[in] displs Offsets of data received from processes
21418!> \param[in] comm Message passing environment identifier
21419!> \par Data length
21420!> Data can have different lengths
21421!> \par Offsets
21422!> Offsets start at 0
21423!> \par MPI mapping
21424!> mpi_gather
21425! **************************************************************************************************
21426 SUBROUTINE mp_gatherv_rv_src(sendbuf, recvbuf, recvcounts, displs, comm)
21427
21428 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
21429 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
21430 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21431 CLASS(mp_comm_type), INTENT(IN) :: comm
21432
21433 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rv_src'
21434
21435 INTEGER :: handle
21436#if defined(__parallel)
21437 INTEGER :: ierr, sendcount
21438#endif
21439
21440 CALL mp_timeset(routinen, handle)
21441
21442#if defined(__parallel)
21443 sendcount = SIZE(sendbuf)
21444 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21445 recvbuf, recvcounts, displs, mpi_real, &
21446 comm%source, comm%handle, ierr)
21447 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21448 CALL add_perf(perf_id=4, &
21449 count=1, &
21450 msg_size=sendcount*real_4_size)
21451#else
21452 mark_used(recvcounts)
21453 mark_used(comm)
21454 recvbuf(1 + displs(1):) = sendbuf
21455#endif
21456 CALL mp_timestop(handle)
21457 END SUBROUTINE mp_gatherv_rv_src
21458
21459! **************************************************************************************************
21460!> \brief Gathers data from all processes to one.
21461!> \param[in] sendbuf Data to send to root
21462!> \param[out] recvbuf Received data (on root)
21463!> \param[in] recvcounts Sizes of data received from processes
21464!> \param[in] displs Offsets of data received from processes
21465!> \param[in] root Process which gathers the data
21466!> \param[in] comm Message passing environment identifier
21467!> \par Data length
21468!> Data can have different lengths
21469!> \par Offsets
21470!> Offsets start at 0
21471!> \par MPI mapping
21472!> mpi_gather
21473! **************************************************************************************************
21474 SUBROUTINE mp_gatherv_rm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
21475
21476 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
21477 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
21478 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21479 INTEGER, INTENT(IN) :: root
21480 CLASS(mp_comm_type), INTENT(IN) :: comm
21481
21482 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rm2'
21483
21484 INTEGER :: handle
21485#if defined(__parallel)
21486 INTEGER :: ierr, sendcount
21487#endif
21488
21489 CALL mp_timeset(routinen, handle)
21490
21491#if defined(__parallel)
21492 sendcount = SIZE(sendbuf)
21493 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21494 recvbuf, recvcounts, displs, mpi_real, &
21495 root, comm%handle, ierr)
21496 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21497 CALL add_perf(perf_id=4, &
21498 count=1, &
21499 msg_size=sendcount*real_4_size)
21500#else
21501 mark_used(recvcounts)
21502 mark_used(root)
21503 mark_used(comm)
21504 recvbuf(:, 1 + displs(1):) = sendbuf
21505#endif
21506 CALL mp_timestop(handle)
21507 END SUBROUTINE mp_gatherv_rm2
21508
21509! **************************************************************************************************
21510!> \brief Gathers data from all processes to one.
21511!> \param[in] sendbuf Data to send to root
21512!> \param[out] recvbuf Received data (on root)
21513!> \param[in] recvcounts Sizes of data received from processes
21514!> \param[in] displs Offsets of data received from processes
21515!> \param[in] comm Message passing environment identifier
21516!> \par Data length
21517!> Data can have different lengths
21518!> \par Offsets
21519!> Offsets start at 0
21520!> \par MPI mapping
21521!> mpi_gather
21522! **************************************************************************************************
21523 SUBROUTINE mp_gatherv_rm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
21524
21525 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
21526 REAL(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
21527 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21528 CLASS(mp_comm_type), INTENT(IN) :: comm
21529
21530 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_rm2_src'
21531
21532 INTEGER :: handle
21533#if defined(__parallel)
21534 INTEGER :: ierr, sendcount
21535#endif
21536
21537 CALL mp_timeset(routinen, handle)
21538
21539#if defined(__parallel)
21540 sendcount = SIZE(sendbuf)
21541 CALL mpi_gatherv(sendbuf, sendcount, mpi_real, &
21542 recvbuf, recvcounts, displs, mpi_real, &
21543 comm%source, comm%handle, ierr)
21544 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21545 CALL add_perf(perf_id=4, &
21546 count=1, &
21547 msg_size=sendcount*real_4_size)
21548#else
21549 mark_used(recvcounts)
21550 mark_used(comm)
21551 recvbuf(:, 1 + displs(1):) = sendbuf
21552#endif
21553 CALL mp_timestop(handle)
21554 END SUBROUTINE mp_gatherv_rm2_src
21555
21556! **************************************************************************************************
21557!> \brief Gathers data from all processes to one.
21558!> \param[in] sendbuf Data to send to root
21559!> \param[out] recvbuf Received data (on root)
21560!> \param[in] recvcounts Sizes of data received from processes
21561!> \param[in] displs Offsets of data received from processes
21562!> \param[in] root Process which gathers the data
21563!> \param[in] comm Message passing environment identifier
21564!> \par Data length
21565!> Data can have different lengths
21566!> \par Offsets
21567!> Offsets start at 0
21568!> \par MPI mapping
21569!> mpi_gather
21570! **************************************************************************************************
21571 SUBROUTINE mp_igatherv_rv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
21572 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: sendbuf
21573 REAL(kind=real_4), DIMENSION(:), INTENT(OUT) :: recvbuf
21574 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
21575 INTEGER, INTENT(IN) :: sendcount, root
21576 CLASS(mp_comm_type), INTENT(IN) :: comm
21577 TYPE(mp_request_type), INTENT(OUT) :: request
21578
21579 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_rv'
21580
21581 INTEGER :: handle
21582#if defined(__parallel)
21583 INTEGER :: ierr
21584#endif
21585
21586 CALL mp_timeset(routinen, handle)
21587
21588#if defined(__parallel)
21589#if !defined(__GNUC__) || __GNUC__ >= 9
21590 cpassert(is_contiguous(sendbuf))
21591 cpassert(is_contiguous(recvbuf))
21592 cpassert(is_contiguous(recvcounts))
21593 cpassert(is_contiguous(displs))
21594#endif
21595 CALL mpi_igatherv(sendbuf, sendcount, mpi_real, &
21596 recvbuf, recvcounts, displs, mpi_real, &
21597 root, comm%handle, request%handle, ierr)
21598 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
21599 CALL add_perf(perf_id=24, &
21600 count=1, &
21601 msg_size=sendcount*real_4_size)
21602#else
21603 mark_used(sendcount)
21604 mark_used(recvcounts)
21605 mark_used(root)
21606 mark_used(comm)
21607 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
21608 request = mp_request_null
21609#endif
21610 CALL mp_timestop(handle)
21611 END SUBROUTINE mp_igatherv_rv
21612
21613! **************************************************************************************************
21614!> \brief Gathers a datum from all processes and all processes receive the
21615!> same data
21616!> \param[in] msgout Datum to send
21617!> \param[out] msgin Received data
21618!> \param[in] comm Message passing environment identifier
21619!> \par Data size
21620!> All processes send equal-sized data
21621!> \par MPI mapping
21622!> mpi_allgather
21623! **************************************************************************************************
21624 SUBROUTINE mp_allgather_r (msgout, msgin, comm)
21625 REAL(kind=real_4), INTENT(IN) :: msgout
21626 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
21627 CLASS(mp_comm_type), INTENT(IN) :: comm
21628
21629 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r'
21630
21631 INTEGER :: handle
21632#if defined(__parallel)
21633 INTEGER :: ierr, rcount, scount
21634#endif
21635
21636 CALL mp_timeset(routinen, handle)
21637
21638#if defined(__parallel)
21639 scount = 1
21640 rcount = 1
21641 CALL mpi_allgather(msgout, scount, mpi_real, &
21642 msgin, rcount, mpi_real, &
21643 comm%handle, ierr)
21644 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21645#else
21646 mark_used(comm)
21647 msgin = msgout
21648#endif
21649 CALL mp_timestop(handle)
21650 END SUBROUTINE mp_allgather_r
21651
21652! **************************************************************************************************
21653!> \brief Gathers a datum from all processes and all processes receive the
21654!> same data
21655!> \param[in] msgout Datum to send
21656!> \param[out] msgin Received data
21657!> \param[in] comm Message passing environment identifier
21658!> \par Data size
21659!> All processes send equal-sized data
21660!> \par MPI mapping
21661!> mpi_allgather
21662! **************************************************************************************************
21663 SUBROUTINE mp_allgather_r2(msgout, msgin, comm)
21664 REAL(kind=real_4), INTENT(IN) :: msgout
21665 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
21666 CLASS(mp_comm_type), INTENT(IN) :: comm
21667
21668 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r2'
21669
21670 INTEGER :: handle
21671#if defined(__parallel)
21672 INTEGER :: ierr, rcount, scount
21673#endif
21674
21675 CALL mp_timeset(routinen, handle)
21676
21677#if defined(__parallel)
21678 scount = 1
21679 rcount = 1
21680 CALL mpi_allgather(msgout, scount, mpi_real, &
21681 msgin, rcount, mpi_real, &
21682 comm%handle, ierr)
21683 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21684#else
21685 mark_used(comm)
21686 msgin = msgout
21687#endif
21688 CALL mp_timestop(handle)
21689 END SUBROUTINE mp_allgather_r2
21690
21691! **************************************************************************************************
21692!> \brief Gathers a datum from all processes and all processes receive the
21693!> same data
21694!> \param[in] msgout Datum to send
21695!> \param[out] msgin Received data
21696!> \param[in] comm Message passing environment identifier
21697!> \par Data size
21698!> All processes send equal-sized data
21699!> \par MPI mapping
21700!> mpi_allgather
21701! **************************************************************************************************
21702 SUBROUTINE mp_iallgather_r (msgout, msgin, comm, request)
21703 REAL(kind=real_4), INTENT(IN) :: msgout
21704 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
21705 CLASS(mp_comm_type), INTENT(IN) :: comm
21706 TYPE(mp_request_type), INTENT(OUT) :: request
21707
21708 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r'
21709
21710 INTEGER :: handle
21711#if defined(__parallel)
21712 INTEGER :: ierr, rcount, scount
21713#endif
21714
21715 CALL mp_timeset(routinen, handle)
21716
21717#if defined(__parallel)
21718#if !defined(__GNUC__) || __GNUC__ >= 9
21719 cpassert(is_contiguous(msgin))
21720#endif
21721 scount = 1
21722 rcount = 1
21723 CALL mpi_iallgather(msgout, scount, mpi_real, &
21724 msgin, rcount, mpi_real, &
21725 comm%handle, request%handle, ierr)
21726 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21727#else
21728 mark_used(comm)
21729 msgin = msgout
21730 request = mp_request_null
21731#endif
21732 CALL mp_timestop(handle)
21733 END SUBROUTINE mp_iallgather_r
21734
21735! **************************************************************************************************
21736!> \brief Gathers vector data from all processes and all processes receive the
21737!> same data
21738!> \param[in] msgout Rank-1 data to send
21739!> \param[out] msgin Received data
21740!> \param[in] comm Message passing environment identifier
21741!> \par Data size
21742!> All processes send equal-sized data
21743!> \par Ranks
21744!> The last rank counts the processes
21745!> \par MPI mapping
21746!> mpi_allgather
21747! **************************************************************************************************
21748 SUBROUTINE mp_allgather_r12(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_r12'
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_r12
21775
21776! **************************************************************************************************
21777!> \brief Gathers matrix data from all processes and all processes receive the
21778!> same data
21779!> \param[in] msgout Rank-2 data to send
21780!> \param msgin ...
21781!> \param comm ...
21782!> \note see mp_allgather_r12
21783! **************************************************************************************************
21784 SUBROUTINE mp_allgather_r23(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_r23'
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_r23
21811
21812! **************************************************************************************************
21813!> \brief Gathers rank-3 data from all processes and all processes receive the
21814!> same data
21815!> \param[in] msgout Rank-3 data to send
21816!> \param msgin ...
21817!> \param comm ...
21818!> \note see mp_allgather_r12
21819! **************************************************************************************************
21820 SUBROUTINE mp_allgather_r34(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_r34'
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(:, :, :, 1) = msgout(:, :, :)
21844#endif
21845 CALL mp_timestop(handle)
21846 END SUBROUTINE mp_allgather_r34
21847
21848! **************************************************************************************************
21849!> \brief Gathers rank-2 data from all processes and all processes receive the
21850!> same data
21851!> \param[in] msgout Rank-2 data to send
21852!> \param msgin ...
21853!> \param comm ...
21854!> \note see mp_allgather_r12
21855! **************************************************************************************************
21856 SUBROUTINE mp_allgather_r22(msgout, msgin, comm)
21857 REAL(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
21858 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
21859 CLASS(mp_comm_type), INTENT(IN) :: comm
21860
21861 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_r22'
21862
21863 INTEGER :: handle
21864#if defined(__parallel)
21865 INTEGER :: ierr, rcount, scount
21866#endif
21867
21868 CALL mp_timeset(routinen, handle)
21869
21870#if defined(__parallel)
21871 scount = SIZE(msgout(:, :))
21872 rcount = scount
21873 CALL mpi_allgather(msgout, scount, mpi_real, &
21874 msgin, rcount, mpi_real, &
21875 comm%handle, ierr)
21876 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
21877#else
21878 mark_used(comm)
21879 msgin(:, :) = msgout(:, :)
21880#endif
21881 CALL mp_timestop(handle)
21882 END SUBROUTINE mp_allgather_r22
21883
21884! **************************************************************************************************
21885!> \brief Gathers rank-1 data from all processes and all processes receive the
21886!> same data
21887!> \param[in] msgout Rank-1 data to send
21888!> \param msgin ...
21889!> \param comm ...
21890!> \param request ...
21891!> \note see mp_allgather_r11
21892! **************************************************************************************************
21893 SUBROUTINE mp_iallgather_r11(msgout, msgin, comm, request)
21894 REAL(kind=real_4), INTENT(IN) :: msgout(:)
21895 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
21896 CLASS(mp_comm_type), INTENT(IN) :: comm
21897 TYPE(mp_request_type), INTENT(OUT) :: request
21898
21899 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r11'
21900
21901 INTEGER :: handle
21902#if defined(__parallel)
21903 INTEGER :: ierr, rcount, scount
21904#endif
21905
21906 CALL mp_timeset(routinen, handle)
21907
21908#if defined(__parallel)
21909#if !defined(__GNUC__) || __GNUC__ >= 9
21910 cpassert(is_contiguous(msgout))
21911 cpassert(is_contiguous(msgin))
21912#endif
21913 scount = SIZE(msgout(:))
21914 rcount = scount
21915 CALL mpi_iallgather(msgout, scount, mpi_real, &
21916 msgin, rcount, mpi_real, &
21917 comm%handle, request%handle, ierr)
21918 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21919#else
21920 mark_used(comm)
21921 msgin = msgout
21922 request = mp_request_null
21923#endif
21924 CALL mp_timestop(handle)
21925 END SUBROUTINE mp_iallgather_r11
21926
21927! **************************************************************************************************
21928!> \brief Gathers rank-2 data from all processes and all processes receive the
21929!> same data
21930!> \param[in] msgout Rank-2 data to send
21931!> \param msgin ...
21932!> \param comm ...
21933!> \param request ...
21934!> \note see mp_allgather_r12
21935! **************************************************************************************************
21936 SUBROUTINE mp_iallgather_r13(msgout, msgin, comm, request)
21937 REAL(kind=real_4), INTENT(IN) :: msgout(:)
21938 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
21939 CLASS(mp_comm_type), INTENT(IN) :: comm
21940 TYPE(mp_request_type), INTENT(OUT) :: request
21941
21942 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r13'
21943
21944 INTEGER :: handle
21945#if defined(__parallel)
21946 INTEGER :: ierr, rcount, scount
21947#endif
21948
21949 CALL mp_timeset(routinen, handle)
21950
21951#if defined(__parallel)
21952#if !defined(__GNUC__) || __GNUC__ >= 9
21953 cpassert(is_contiguous(msgout))
21954 cpassert(is_contiguous(msgin))
21955#endif
21956
21957 scount = SIZE(msgout(:))
21958 rcount = scount
21959 CALL mpi_iallgather(msgout, scount, mpi_real, &
21960 msgin, rcount, mpi_real, &
21961 comm%handle, request%handle, ierr)
21962 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
21963#else
21964 mark_used(comm)
21965 msgin(:, 1, 1) = msgout(:)
21966 request = mp_request_null
21967#endif
21968 CALL mp_timestop(handle)
21969 END SUBROUTINE mp_iallgather_r13
21970
21971! **************************************************************************************************
21972!> \brief Gathers rank-2 data from all processes and all processes receive the
21973!> same data
21974!> \param[in] msgout Rank-2 data to send
21975!> \param msgin ...
21976!> \param comm ...
21977!> \param request ...
21978!> \note see mp_allgather_r12
21979! **************************************************************************************************
21980 SUBROUTINE mp_iallgather_r22(msgout, msgin, comm, request)
21981 REAL(kind=real_4), INTENT(IN) :: msgout(:, :)
21982 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :)
21983 CLASS(mp_comm_type), INTENT(IN) :: comm
21984 TYPE(mp_request_type), INTENT(OUT) :: request
21985
21986 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r22'
21987
21988 INTEGER :: handle
21989#if defined(__parallel)
21990 INTEGER :: ierr, rcount, scount
21991#endif
21992
21993 CALL mp_timeset(routinen, handle)
21994
21995#if defined(__parallel)
21996#if !defined(__GNUC__) || __GNUC__ >= 9
21997 cpassert(is_contiguous(msgout))
21998 cpassert(is_contiguous(msgin))
21999#endif
22000
22001 scount = SIZE(msgout(:, :))
22002 rcount = scount
22003 CALL mpi_iallgather(msgout, scount, mpi_real, &
22004 msgin, rcount, mpi_real, &
22005 comm%handle, request%handle, ierr)
22006 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22007#else
22008 mark_used(comm)
22009 msgin(:, :) = msgout(:, :)
22010 request = mp_request_null
22011#endif
22012 CALL mp_timestop(handle)
22013 END SUBROUTINE mp_iallgather_r22
22014
22015! **************************************************************************************************
22016!> \brief Gathers rank-2 data from all processes and all processes receive the
22017!> same data
22018!> \param[in] msgout Rank-2 data to send
22019!> \param msgin ...
22020!> \param comm ...
22021!> \param request ...
22022!> \note see mp_allgather_r12
22023! **************************************************************************************************
22024 SUBROUTINE mp_iallgather_r24(msgout, msgin, comm, request)
22025 REAL(kind=real_4), INTENT(IN) :: msgout(:, :)
22026 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :, :)
22027 CLASS(mp_comm_type), INTENT(IN) :: comm
22028 TYPE(mp_request_type), INTENT(OUT) :: request
22029
22030 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r24'
22031
22032 INTEGER :: handle
22033#if defined(__parallel)
22034 INTEGER :: ierr, rcount, scount
22035#endif
22036
22037 CALL mp_timeset(routinen, handle)
22038
22039#if defined(__parallel)
22040#if !defined(__GNUC__) || __GNUC__ >= 9
22041 cpassert(is_contiguous(msgout))
22042 cpassert(is_contiguous(msgin))
22043#endif
22044
22045 scount = SIZE(msgout(:, :))
22046 rcount = scount
22047 CALL mpi_iallgather(msgout, scount, mpi_real, &
22048 msgin, rcount, mpi_real, &
22049 comm%handle, request%handle, ierr)
22050 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22051#else
22052 mark_used(comm)
22053 msgin(:, :, 1, 1) = msgout(:, :)
22054 request = mp_request_null
22055#endif
22056 CALL mp_timestop(handle)
22057 END SUBROUTINE mp_iallgather_r24
22058
22059! **************************************************************************************************
22060!> \brief Gathers rank-3 data from all processes and all processes receive the
22061!> same data
22062!> \param[in] msgout Rank-3 data to send
22063!> \param msgin ...
22064!> \param comm ...
22065!> \param request ...
22066!> \note see mp_allgather_r12
22067! **************************************************************************************************
22068 SUBROUTINE mp_iallgather_r33(msgout, msgin, comm, request)
22069 REAL(kind=real_4), INTENT(IN) :: msgout(:, :, :)
22070 REAL(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
22071 CLASS(mp_comm_type), INTENT(IN) :: comm
22072 TYPE(mp_request_type), INTENT(OUT) :: request
22073
22074 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_r33'
22075
22076 INTEGER :: handle
22077#if defined(__parallel)
22078 INTEGER :: ierr, rcount, scount
22079#endif
22080
22081 CALL mp_timeset(routinen, handle)
22082
22083#if defined(__parallel)
22084#if !defined(__GNUC__) || __GNUC__ >= 9
22085 cpassert(is_contiguous(msgout))
22086 cpassert(is_contiguous(msgin))
22087#endif
22088
22089 scount = SIZE(msgout(:, :, :))
22090 rcount = scount
22091 CALL mpi_iallgather(msgout, scount, mpi_real, &
22092 msgin, rcount, mpi_real, &
22093 comm%handle, request%handle, ierr)
22094 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
22095#else
22096 mark_used(comm)
22097 msgin(:, :, :) = msgout(:, :, :)
22098 request = mp_request_null
22099#endif
22100 CALL mp_timestop(handle)
22101 END SUBROUTINE mp_iallgather_r33
22102
22103! **************************************************************************************************
22104!> \brief Gathers vector data from all processes and all processes receive the
22105!> same data
22106!> \param[in] msgout Rank-1 data to send
22107!> \param[out] msgin Received data
22108!> \param[in] rcount Size of sent data for every process
22109!> \param[in] rdispl Offset of sent data for every process
22110!> \param[in] comm Message passing environment identifier
22111!> \par Data size
22112!> Processes can send different-sized data
22113!> \par Ranks
22114!> The last rank counts the processes
22115!> \par Offsets
22116!> Offsets are from 0
22117!> \par MPI mapping
22118!> mpi_allgather
22119! **************************************************************************************************
22120 SUBROUTINE mp_allgatherv_rv(msgout, msgin, rcount, rdispl, comm)
22121 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
22122 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22123 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22124 CLASS(mp_comm_type), INTENT(IN) :: comm
22125
22126 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_rv'
22127
22128 INTEGER :: handle
22129#if defined(__parallel)
22130 INTEGER :: ierr, scount
22131#endif
22132
22133 CALL mp_timeset(routinen, handle)
22134
22135#if defined(__parallel)
22136 scount = SIZE(msgout)
22137 CALL mpi_allgatherv(msgout, scount, mpi_real, msgin, rcount, &
22138 rdispl, mpi_real, comm%handle, ierr)
22139 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
22140#else
22141 mark_used(rcount)
22142 mark_used(rdispl)
22143 mark_used(comm)
22144 msgin = msgout
22145#endif
22146 CALL mp_timestop(handle)
22147 END SUBROUTINE mp_allgatherv_rv
22148
22149! **************************************************************************************************
22150!> \brief Gathers vector data from all processes and all processes receive the
22151!> same data
22152!> \param[in] msgout Rank-1 data to send
22153!> \param[out] msgin Received data
22154!> \param[in] rcount Size of sent data for every process
22155!> \param[in] rdispl Offset of sent data for every process
22156!> \param[in] comm Message passing environment identifier
22157!> \par Data size
22158!> Processes can send different-sized data
22159!> \par Ranks
22160!> The last rank counts the processes
22161!> \par Offsets
22162!> Offsets are from 0
22163!> \par MPI mapping
22164!> mpi_allgather
22165! **************************************************************************************************
22166 SUBROUTINE mp_allgatherv_rm2(msgout, msgin, rcount, rdispl, comm)
22167 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
22168 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
22169 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22170 CLASS(mp_comm_type), INTENT(IN) :: comm
22171
22172 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_rv'
22173
22174 INTEGER :: handle
22175#if defined(__parallel)
22176 INTEGER :: ierr, scount
22177#endif
22178
22179 CALL mp_timeset(routinen, handle)
22180
22181#if defined(__parallel)
22182 scount = SIZE(msgout)
22183 CALL mpi_allgatherv(msgout, scount, mpi_real, msgin, rcount, &
22184 rdispl, mpi_real, comm%handle, ierr)
22185 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
22186#else
22187 mark_used(rcount)
22188 mark_used(rdispl)
22189 mark_used(comm)
22190 msgin = msgout
22191#endif
22192 CALL mp_timestop(handle)
22193 END SUBROUTINE mp_allgatherv_rm2
22194
22195! **************************************************************************************************
22196!> \brief Gathers vector data from all processes and all processes receive the
22197!> same data
22198!> \param[in] msgout Rank-1 data to send
22199!> \param[out] msgin Received data
22200!> \param[in] rcount Size of sent data for every process
22201!> \param[in] rdispl Offset of sent data for every process
22202!> \param[in] comm Message passing environment identifier
22203!> \par Data size
22204!> Processes can send different-sized data
22205!> \par Ranks
22206!> The last rank counts the processes
22207!> \par Offsets
22208!> Offsets are from 0
22209!> \par MPI mapping
22210!> mpi_allgather
22211! **************************************************************************************************
22212 SUBROUTINE mp_iallgatherv_rv(msgout, msgin, rcount, rdispl, comm, request)
22213 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22214 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22215 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
22216 CLASS(mp_comm_type), INTENT(IN) :: comm
22217 TYPE(mp_request_type), INTENT(OUT) :: request
22218
22219 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_rv'
22220
22221 INTEGER :: handle
22222#if defined(__parallel)
22223 INTEGER :: ierr, scount, rsize
22224#endif
22225
22226 CALL mp_timeset(routinen, handle)
22227
22228#if defined(__parallel)
22229#if !defined(__GNUC__) || __GNUC__ >= 9
22230 cpassert(is_contiguous(msgout))
22231 cpassert(is_contiguous(msgin))
22232 cpassert(is_contiguous(rcount))
22233 cpassert(is_contiguous(rdispl))
22234#endif
22235
22236 scount = SIZE(msgout)
22237 rsize = SIZE(rcount)
22238 CALL mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, &
22239 rdispl, comm, request, ierr)
22240 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
22241#else
22242 mark_used(rcount)
22243 mark_used(rdispl)
22244 mark_used(comm)
22245 msgin = msgout
22246 request = mp_request_null
22247#endif
22248 CALL mp_timestop(handle)
22249 END SUBROUTINE mp_iallgatherv_rv
22250
22251! **************************************************************************************************
22252!> \brief Gathers vector data from all processes and all processes receive the
22253!> same data
22254!> \param[in] msgout Rank-1 data to send
22255!> \param[out] msgin Received data
22256!> \param[in] rcount Size of sent data for every process
22257!> \param[in] rdispl Offset of sent data for every process
22258!> \param[in] comm Message passing environment identifier
22259!> \par Data size
22260!> Processes can send different-sized data
22261!> \par Ranks
22262!> The last rank counts the processes
22263!> \par Offsets
22264!> Offsets are from 0
22265!> \par MPI mapping
22266!> mpi_allgather
22267! **************************************************************************************************
22268 SUBROUTINE mp_iallgatherv_rv2(msgout, msgin, rcount, rdispl, comm, request)
22269 REAL(kind=real_4), INTENT(IN) :: msgout(:)
22270 REAL(kind=real_4), INTENT(OUT) :: msgin(:)
22271 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
22272 CLASS(mp_comm_type), INTENT(IN) :: comm
22273 TYPE(mp_request_type), INTENT(OUT) :: request
22274
22275 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_rv2'
22276
22277 INTEGER :: handle
22278#if defined(__parallel)
22279 INTEGER :: ierr, scount, rsize
22280#endif
22281
22282 CALL mp_timeset(routinen, handle)
22283
22284#if defined(__parallel)
22285#if !defined(__GNUC__) || __GNUC__ >= 9
22286 cpassert(is_contiguous(msgout))
22287 cpassert(is_contiguous(msgin))
22288 cpassert(is_contiguous(rcount))
22289 cpassert(is_contiguous(rdispl))
22290#endif
22291
22292 scount = SIZE(msgout)
22293 rsize = SIZE(rcount)
22294 CALL mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, &
22295 rdispl, comm, request, ierr)
22296 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
22297#else
22298 mark_used(rcount)
22299 mark_used(rdispl)
22300 mark_used(comm)
22301 msgin = msgout
22302 request = mp_request_null
22303#endif
22304 CALL mp_timestop(handle)
22305 END SUBROUTINE mp_iallgatherv_rv2
22306
22307! **************************************************************************************************
22308!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
22309!> the issue is with the rank of rcount and rdispl
22310!> \param count ...
22311!> \param array_of_requests ...
22312!> \param array_of_statuses ...
22313!> \param ierr ...
22314!> \author Alfio Lazzaro
22315! **************************************************************************************************
22316#if defined(__parallel)
22317 SUBROUTINE mp_iallgatherv_rv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
22318 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
22319 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22320 INTEGER, INTENT(IN) :: rsize
22321 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
22322 CLASS(mp_comm_type), INTENT(IN) :: comm
22323 TYPE(mp_request_type), INTENT(OUT) :: request
22324 INTEGER, INTENT(INOUT) :: ierr
22325
22326 CALL mpi_iallgatherv(msgout, scount, mpi_real, msgin, rcount, &
22327 rdispl, mpi_real, comm%handle, request%handle, ierr)
22328
22329 END SUBROUTINE mp_iallgatherv_rv_internal
22330#endif
22331
22332! **************************************************************************************************
22333!> \brief Sums a vector and partitions the result among processes
22334!> \param[in] msgout Data to sum
22335!> \param[out] msgin Received portion of summed data
22336!> \param[in] rcount Partition sizes of the summed data for
22337!> every process
22338!> \param[in] comm Message passing environment identifier
22339! **************************************************************************************************
22340 SUBROUTINE mp_sum_scatter_rv(msgout, msgin, rcount, comm)
22341 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
22342 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
22343 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
22344 CLASS(mp_comm_type), INTENT(IN) :: comm
22345
22346 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_rv'
22347
22348 INTEGER :: handle
22349#if defined(__parallel)
22350 INTEGER :: ierr
22351#endif
22352
22353 CALL mp_timeset(routinen, handle)
22354
22355#if defined(__parallel)
22356 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_real, mpi_sum, &
22357 comm%handle, ierr)
22358 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
22359
22360 CALL add_perf(perf_id=3, count=1, &
22361 msg_size=rcount(1)*2*real_4_size)
22362#else
22363 mark_used(rcount)
22364 mark_used(comm)
22365 msgin = msgout(:, 1)
22366#endif
22367 CALL mp_timestop(handle)
22368 END SUBROUTINE mp_sum_scatter_rv
22369
22370! **************************************************************************************************
22371!> \brief Sends and receives vector data
22372!> \param[in] msgin Data to send
22373!> \param[in] dest Process to send data to
22374!> \param[out] msgout Received data
22375!> \param[in] source Process from which to receive
22376!> \param[in] comm Message passing environment identifier
22377!> \param[in] tag Send and recv tag (default: 0)
22378! **************************************************************************************************
22379 SUBROUTINE mp_sendrecv_r (msgin, dest, msgout, source, comm, tag)
22380 REAL(kind=real_4), INTENT(IN) :: msgin
22381 INTEGER, INTENT(IN) :: dest
22382 REAL(kind=real_4), INTENT(OUT) :: msgout
22383 INTEGER, INTENT(IN) :: source
22384 CLASS(mp_comm_type), INTENT(IN) :: comm
22385 INTEGER, INTENT(IN), OPTIONAL :: tag
22386
22387 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_r'
22388
22389 INTEGER :: handle
22390#if defined(__parallel)
22391 INTEGER :: ierr, msglen_in, msglen_out, &
22392 recv_tag, send_tag
22393#endif
22394
22395 CALL mp_timeset(routinen, handle)
22396
22397#if defined(__parallel)
22398 msglen_in = 1
22399 msglen_out = 1
22400 send_tag = 0 ! cannot think of something better here, this might be dangerous
22401 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22402 IF (PRESENT(tag)) THEN
22403 send_tag = tag
22404 recv_tag = tag
22405 END IF
22406 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22407 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22408 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22409 CALL add_perf(perf_id=7, count=1, &
22410 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22411#else
22412 mark_used(dest)
22413 mark_used(source)
22414 mark_used(comm)
22415 mark_used(tag)
22416 msgout = msgin
22417#endif
22418 CALL mp_timestop(handle)
22419 END SUBROUTINE mp_sendrecv_r
22420
22421! **************************************************************************************************
22422!> \brief Sends and receives vector data
22423!> \param[in] msgin Data to send
22424!> \param[in] dest Process to send data to
22425!> \param[out] msgout Received data
22426!> \param[in] source Process from which to receive
22427!> \param[in] comm Message passing environment identifier
22428!> \param[in] tag Send and recv tag (default: 0)
22429! **************************************************************************************************
22430 SUBROUTINE mp_sendrecv_rv(msgin, dest, msgout, source, comm, tag)
22431 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
22432 INTEGER, INTENT(IN) :: dest
22433 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
22434 INTEGER, INTENT(IN) :: source
22435 CLASS(mp_comm_type), INTENT(IN) :: comm
22436 INTEGER, INTENT(IN), OPTIONAL :: tag
22437
22438 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rv'
22439
22440 INTEGER :: handle
22441#if defined(__parallel)
22442 INTEGER :: ierr, msglen_in, msglen_out, &
22443 recv_tag, send_tag
22444#endif
22445
22446 CALL mp_timeset(routinen, handle)
22447
22448#if defined(__parallel)
22449 msglen_in = SIZE(msgin)
22450 msglen_out = SIZE(msgout)
22451 send_tag = 0 ! cannot think of something better here, this might be dangerous
22452 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22453 IF (PRESENT(tag)) THEN
22454 send_tag = tag
22455 recv_tag = tag
22456 END IF
22457 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22458 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22459 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22460 CALL add_perf(perf_id=7, count=1, &
22461 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22462#else
22463 mark_used(dest)
22464 mark_used(source)
22465 mark_used(comm)
22466 mark_used(tag)
22467 msgout = msgin
22468#endif
22469 CALL mp_timestop(handle)
22470 END SUBROUTINE mp_sendrecv_rv
22471
22472! **************************************************************************************************
22473!> \brief Sends and receives matrix data
22474!> \param msgin ...
22475!> \param dest ...
22476!> \param msgout ...
22477!> \param source ...
22478!> \param comm ...
22479!> \param tag ...
22480!> \note see mp_sendrecv_rv
22481! **************************************************************************************************
22482 SUBROUTINE mp_sendrecv_rm2(msgin, dest, msgout, source, comm, tag)
22483 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
22484 INTEGER, INTENT(IN) :: dest
22485 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
22486 INTEGER, INTENT(IN) :: source
22487 CLASS(mp_comm_type), INTENT(IN) :: comm
22488 INTEGER, INTENT(IN), OPTIONAL :: tag
22489
22490 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm2'
22491
22492 INTEGER :: handle
22493#if defined(__parallel)
22494 INTEGER :: ierr, msglen_in, msglen_out, &
22495 recv_tag, send_tag
22496#endif
22497
22498 CALL mp_timeset(routinen, handle)
22499
22500#if defined(__parallel)
22501 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
22502 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
22503 send_tag = 0 ! cannot think of something better here, this might be dangerous
22504 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22505 IF (PRESENT(tag)) THEN
22506 send_tag = tag
22507 recv_tag = tag
22508 END IF
22509 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22510 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22511 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22512 CALL add_perf(perf_id=7, count=1, &
22513 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22514#else
22515 mark_used(dest)
22516 mark_used(source)
22517 mark_used(comm)
22518 mark_used(tag)
22519 msgout = msgin
22520#endif
22521 CALL mp_timestop(handle)
22522 END SUBROUTINE mp_sendrecv_rm2
22523
22524! **************************************************************************************************
22525!> \brief Sends and receives rank-3 data
22526!> \param msgin ...
22527!> \param dest ...
22528!> \param msgout ...
22529!> \param source ...
22530!> \param comm ...
22531!> \note see mp_sendrecv_rv
22532! **************************************************************************************************
22533 SUBROUTINE mp_sendrecv_rm3(msgin, dest, msgout, source, comm, tag)
22534 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
22535 INTEGER, INTENT(IN) :: dest
22536 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
22537 INTEGER, INTENT(IN) :: source
22538 CLASS(mp_comm_type), INTENT(IN) :: comm
22539 INTEGER, INTENT(IN), OPTIONAL :: tag
22540
22541 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm3'
22542
22543 INTEGER :: handle
22544#if defined(__parallel)
22545 INTEGER :: ierr, msglen_in, msglen_out, &
22546 recv_tag, send_tag
22547#endif
22548
22549 CALL mp_timeset(routinen, handle)
22550
22551#if defined(__parallel)
22552 msglen_in = SIZE(msgin)
22553 msglen_out = SIZE(msgout)
22554 send_tag = 0 ! cannot think of something better here, this might be dangerous
22555 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22556 IF (PRESENT(tag)) THEN
22557 send_tag = tag
22558 recv_tag = tag
22559 END IF
22560 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22561 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22562 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22563 CALL add_perf(perf_id=7, count=1, &
22564 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22565#else
22566 mark_used(dest)
22567 mark_used(source)
22568 mark_used(comm)
22569 mark_used(tag)
22570 msgout = msgin
22571#endif
22572 CALL mp_timestop(handle)
22573 END SUBROUTINE mp_sendrecv_rm3
22574
22575! **************************************************************************************************
22576!> \brief Sends and receives rank-4 data
22577!> \param msgin ...
22578!> \param dest ...
22579!> \param msgout ...
22580!> \param source ...
22581!> \param comm ...
22582!> \note see mp_sendrecv_rv
22583! **************************************************************************************************
22584 SUBROUTINE mp_sendrecv_rm4(msgin, dest, msgout, source, comm, tag)
22585 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
22586 INTEGER, INTENT(IN) :: dest
22587 REAL(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
22588 INTEGER, INTENT(IN) :: source
22589 CLASS(mp_comm_type), INTENT(IN) :: comm
22590 INTEGER, INTENT(IN), OPTIONAL :: tag
22591
22592 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_rm4'
22593
22594 INTEGER :: handle
22595#if defined(__parallel)
22596 INTEGER :: ierr, msglen_in, msglen_out, &
22597 recv_tag, send_tag
22598#endif
22599
22600 CALL mp_timeset(routinen, handle)
22601
22602#if defined(__parallel)
22603 msglen_in = SIZE(msgin)
22604 msglen_out = SIZE(msgout)
22605 send_tag = 0 ! cannot think of something better here, this might be dangerous
22606 recv_tag = 0 ! cannot think of something better here, this might be dangerous
22607 IF (PRESENT(tag)) THEN
22608 send_tag = tag
22609 recv_tag = tag
22610 END IF
22611 CALL mpi_sendrecv(msgin, msglen_in, mpi_real, dest, send_tag, msgout, &
22612 msglen_out, mpi_real, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
22613 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
22614 CALL add_perf(perf_id=7, count=1, &
22615 msg_size=(msglen_in + msglen_out)*real_4_size/2)
22616#else
22617 mark_used(dest)
22618 mark_used(source)
22619 mark_used(comm)
22620 mark_used(tag)
22621 msgout = msgin
22622#endif
22623 CALL mp_timestop(handle)
22624 END SUBROUTINE mp_sendrecv_rm4
22625
22626! **************************************************************************************************
22627!> \brief Non-blocking send and receive of a scalar
22628!> \param[in] msgin Scalar data to send
22629!> \param[in] dest Which process to send to
22630!> \param[out] msgout Receive data into this pointer
22631!> \param[in] source Process to receive from
22632!> \param[in] comm Message passing environment identifier
22633!> \param[out] send_request Request handle for the send
22634!> \param[out] recv_request Request handle for the receive
22635!> \param[in] tag (optional) tag to differentiate requests
22636!> \par Implementation
22637!> Calls mpi_isend and mpi_irecv.
22638!> \par History
22639!> 02.2005 created [Alfio Lazzaro]
22640! **************************************************************************************************
22641 SUBROUTINE mp_isendrecv_r (msgin, dest, msgout, source, comm, send_request, &
22642 recv_request, tag)
22643 REAL(kind=real_4), INTENT(IN) :: msgin
22644 INTEGER, INTENT(IN) :: dest
22645 REAL(kind=real_4), INTENT(INOUT) :: msgout
22646 INTEGER, INTENT(IN) :: source
22647 CLASS(mp_comm_type), INTENT(IN) :: comm
22648 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
22649 INTEGER, INTENT(in), OPTIONAL :: tag
22650
22651 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_r'
22652
22653 INTEGER :: handle
22654#if defined(__parallel)
22655 INTEGER :: ierr, my_tag
22656#endif
22657
22658 CALL mp_timeset(routinen, handle)
22659
22660#if defined(__parallel)
22661 my_tag = 0
22662 IF (PRESENT(tag)) my_tag = tag
22663
22664 CALL mpi_irecv(msgout, 1, mpi_real, source, my_tag, &
22665 comm%handle, recv_request%handle, ierr)
22666 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
22667
22668 CALL mpi_isend(msgin, 1, mpi_real, dest, my_tag, &
22669 comm%handle, send_request%handle, ierr)
22670 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22671
22672 CALL add_perf(perf_id=8, count=1, msg_size=2*real_4_size)
22673#else
22674 mark_used(dest)
22675 mark_used(source)
22676 mark_used(comm)
22677 mark_used(tag)
22678 send_request = mp_request_null
22679 recv_request = mp_request_null
22680 msgout = msgin
22681#endif
22682 CALL mp_timestop(handle)
22683 END SUBROUTINE mp_isendrecv_r
22684
22685! **************************************************************************************************
22686!> \brief Non-blocking send and receive of a vector
22687!> \param[in] msgin Vector data to send
22688!> \param[in] dest Which process to send to
22689!> \param[out] msgout Receive data into this pointer
22690!> \param[in] source Process to receive from
22691!> \param[in] comm Message passing environment identifier
22692!> \param[out] send_request Request handle for the send
22693!> \param[out] recv_request Request handle for the receive
22694!> \param[in] tag (optional) tag to differentiate requests
22695!> \par Implementation
22696!> Calls mpi_isend and mpi_irecv.
22697!> \par History
22698!> 11.2004 created [Joost VandeVondele]
22699!> \note
22700!> arrays can be pointers or assumed shape, but they must be contiguous!
22701! **************************************************************************************************
22702 SUBROUTINE mp_isendrecv_rv(msgin, dest, msgout, source, comm, send_request, &
22703 recv_request, tag)
22704 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
22705 INTEGER, INTENT(IN) :: dest
22706 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
22707 INTEGER, INTENT(IN) :: source
22708 CLASS(mp_comm_type), INTENT(IN) :: comm
22709 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
22710 INTEGER, INTENT(in), OPTIONAL :: tag
22711
22712 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_rv'
22713
22714 INTEGER :: handle
22715#if defined(__parallel)
22716 INTEGER :: ierr, msglen, my_tag
22717 REAL(kind=real_4) :: foo
22718#endif
22719
22720 CALL mp_timeset(routinen, handle)
22721
22722#if defined(__parallel)
22723#if !defined(__GNUC__) || __GNUC__ >= 9
22724 cpassert(is_contiguous(msgout))
22725 cpassert(is_contiguous(msgin))
22726#endif
22727
22728 my_tag = 0
22729 IF (PRESENT(tag)) my_tag = tag
22730
22731 msglen = SIZE(msgout, 1)
22732 IF (msglen > 0) THEN
22733 CALL mpi_irecv(msgout(1), msglen, mpi_real, source, my_tag, &
22734 comm%handle, recv_request%handle, ierr)
22735 ELSE
22736 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
22737 comm%handle, recv_request%handle, ierr)
22738 END IF
22739 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
22740
22741 msglen = SIZE(msgin, 1)
22742 IF (msglen > 0) THEN
22743 CALL mpi_isend(msgin(1), msglen, mpi_real, dest, my_tag, &
22744 comm%handle, send_request%handle, ierr)
22745 ELSE
22746 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22747 comm%handle, send_request%handle, ierr)
22748 END IF
22749 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22750
22751 msglen = (msglen + SIZE(msgout, 1) + 1)/2
22752 CALL add_perf(perf_id=8, count=1, msg_size=msglen*real_4_size)
22753#else
22754 mark_used(dest)
22755 mark_used(source)
22756 mark_used(comm)
22757 mark_used(tag)
22758 send_request = mp_request_null
22759 recv_request = mp_request_null
22760 msgout = msgin
22761#endif
22762 CALL mp_timestop(handle)
22763 END SUBROUTINE mp_isendrecv_rv
22764
22765! **************************************************************************************************
22766!> \brief Non-blocking send of vector data
22767!> \param msgin ...
22768!> \param dest ...
22769!> \param comm ...
22770!> \param request ...
22771!> \param tag ...
22772!> \par History
22773!> 08.2003 created [f&j]
22774!> \note see mp_isendrecv_rv
22775!> \note
22776!> arrays can be pointers or assumed shape, but they must be contiguous!
22777! **************************************************************************************************
22778 SUBROUTINE mp_isend_rv(msgin, dest, comm, request, tag)
22779 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
22780 INTEGER, INTENT(IN) :: dest
22781 CLASS(mp_comm_type), INTENT(IN) :: comm
22782 TYPE(mp_request_type), INTENT(out) :: request
22783 INTEGER, INTENT(in), OPTIONAL :: tag
22784
22785 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rv'
22786
22787 INTEGER :: handle, ierr
22788#if defined(__parallel)
22789 INTEGER :: msglen, my_tag
22790 REAL(kind=real_4) :: foo(1)
22791#endif
22792
22793 CALL mp_timeset(routinen, handle)
22794
22795#if defined(__parallel)
22796#if !defined(__GNUC__) || __GNUC__ >= 9
22797 cpassert(is_contiguous(msgin))
22798#endif
22799 my_tag = 0
22800 IF (PRESENT(tag)) my_tag = tag
22801
22802 msglen = SIZE(msgin)
22803 IF (msglen > 0) THEN
22804 CALL mpi_isend(msgin(1), msglen, mpi_real, dest, my_tag, &
22805 comm%handle, request%handle, ierr)
22806 ELSE
22807 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22808 comm%handle, request%handle, ierr)
22809 END IF
22810 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22811
22812 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22813#else
22814 mark_used(msgin)
22815 mark_used(dest)
22816 mark_used(comm)
22817 mark_used(request)
22818 mark_used(tag)
22819 ierr = 1
22820 request = mp_request_null
22821 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22822#endif
22823 CALL mp_timestop(handle)
22824 END SUBROUTINE mp_isend_rv
22825
22826! **************************************************************************************************
22827!> \brief Non-blocking send of matrix data
22828!> \param msgin ...
22829!> \param dest ...
22830!> \param comm ...
22831!> \param request ...
22832!> \param tag ...
22833!> \par History
22834!> 2009-11-25 [UB] Made type-generic for templates
22835!> \author fawzi
22836!> \note see mp_isendrecv_rv
22837!> \note see mp_isend_rv
22838!> \note
22839!> arrays can be pointers or assumed shape, but they must be contiguous!
22840! **************************************************************************************************
22841 SUBROUTINE mp_isend_rm2(msgin, dest, comm, request, tag)
22842 REAL(kind=real_4), DIMENSION(:, :), INTENT(IN) :: msgin
22843 INTEGER, INTENT(IN) :: dest
22844 CLASS(mp_comm_type), INTENT(IN) :: comm
22845 TYPE(mp_request_type), INTENT(out) :: request
22846 INTEGER, INTENT(in), OPTIONAL :: tag
22847
22848 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm2'
22849
22850 INTEGER :: handle, ierr
22851#if defined(__parallel)
22852 INTEGER :: msglen, my_tag
22853 REAL(kind=real_4) :: foo(1)
22854#endif
22855
22856 CALL mp_timeset(routinen, handle)
22857
22858#if defined(__parallel)
22859#if !defined(__GNUC__) || __GNUC__ >= 9
22860 cpassert(is_contiguous(msgin))
22861#endif
22862
22863 my_tag = 0
22864 IF (PRESENT(tag)) my_tag = tag
22865
22866 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
22867 IF (msglen > 0) THEN
22868 CALL mpi_isend(msgin(1, 1), msglen, mpi_real, dest, my_tag, &
22869 comm%handle, request%handle, ierr)
22870 ELSE
22871 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22872 comm%handle, request%handle, ierr)
22873 END IF
22874 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22875
22876 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22877#else
22878 mark_used(msgin)
22879 mark_used(dest)
22880 mark_used(comm)
22881 mark_used(request)
22882 mark_used(tag)
22883 ierr = 1
22884 request = mp_request_null
22885 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22886#endif
22887 CALL mp_timestop(handle)
22888 END SUBROUTINE mp_isend_rm2
22889
22890! **************************************************************************************************
22891!> \brief Non-blocking send of rank-3 data
22892!> \param msgin ...
22893!> \param dest ...
22894!> \param comm ...
22895!> \param request ...
22896!> \param tag ...
22897!> \par History
22898!> 9.2008 added _rm3 subroutine [Iain Bethune]
22899!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
22900!> 2009-11-25 [UB] Made type-generic for templates
22901!> \author fawzi
22902!> \note see mp_isendrecv_rv
22903!> \note see mp_isend_rv
22904!> \note
22905!> arrays can be pointers or assumed shape, but they must be contiguous!
22906! **************************************************************************************************
22907 SUBROUTINE mp_isend_rm3(msgin, dest, comm, request, tag)
22908 REAL(kind=real_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
22909 INTEGER, INTENT(IN) :: dest
22910 CLASS(mp_comm_type), INTENT(IN) :: comm
22911 TYPE(mp_request_type), INTENT(out) :: request
22912 INTEGER, INTENT(in), OPTIONAL :: tag
22913
22914 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm3'
22915
22916 INTEGER :: handle, ierr
22917#if defined(__parallel)
22918 INTEGER :: msglen, my_tag
22919 REAL(kind=real_4) :: foo(1)
22920#endif
22921
22922 CALL mp_timeset(routinen, handle)
22923
22924#if defined(__parallel)
22925#if !defined(__GNUC__) || __GNUC__ >= 9
22926 cpassert(is_contiguous(msgin))
22927#endif
22928
22929 my_tag = 0
22930 IF (PRESENT(tag)) my_tag = tag
22931
22932 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
22933 IF (msglen > 0) THEN
22934 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_real, dest, my_tag, &
22935 comm%handle, request%handle, ierr)
22936 ELSE
22937 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
22938 comm%handle, request%handle, ierr)
22939 END IF
22940 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
22941
22942 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
22943#else
22944 mark_used(msgin)
22945 mark_used(dest)
22946 mark_used(comm)
22947 mark_used(request)
22948 mark_used(tag)
22949 ierr = 1
22950 request = mp_request_null
22951 CALL mp_stop(ierr, "mp_isend called in non parallel case")
22952#endif
22953 CALL mp_timestop(handle)
22954 END SUBROUTINE mp_isend_rm3
22955
22956! **************************************************************************************************
22957!> \brief Non-blocking send of rank-4 data
22958!> \param msgin the input message
22959!> \param dest the destination processor
22960!> \param comm the communicator object
22961!> \param request the communication request id
22962!> \param tag the message tag
22963!> \par History
22964!> 2.2016 added _rm4 subroutine [Nico Holmberg]
22965!> \author fawzi
22966!> \note see mp_isend_rv
22967!> \note
22968!> arrays can be pointers or assumed shape, but they must be contiguous!
22969! **************************************************************************************************
22970 SUBROUTINE mp_isend_rm4(msgin, dest, comm, request, tag)
22971 REAL(kind=real_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
22972 INTEGER, INTENT(IN) :: dest
22973 CLASS(mp_comm_type), INTENT(IN) :: comm
22974 TYPE(mp_request_type), INTENT(out) :: request
22975 INTEGER, INTENT(in), OPTIONAL :: tag
22976
22977 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_rm4'
22978
22979 INTEGER :: handle, ierr
22980#if defined(__parallel)
22981 INTEGER :: msglen, my_tag
22982 REAL(kind=real_4) :: foo(1)
22983#endif
22984
22985 CALL mp_timeset(routinen, handle)
22986
22987#if defined(__parallel)
22988#if !defined(__GNUC__) || __GNUC__ >= 9
22989 cpassert(is_contiguous(msgin))
22990#endif
22991
22992 my_tag = 0
22993 IF (PRESENT(tag)) my_tag = tag
22994
22995 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
22996 IF (msglen > 0) THEN
22997 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_real, dest, my_tag, &
22998 comm%handle, request%handle, ierr)
22999 ELSE
23000 CALL mpi_isend(foo, msglen, mpi_real, dest, my_tag, &
23001 comm%handle, request%handle, ierr)
23002 END IF
23003 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
23004
23005 CALL add_perf(perf_id=11, count=1, msg_size=msglen*real_4_size)
23006#else
23007 mark_used(msgin)
23008 mark_used(dest)
23009 mark_used(comm)
23010 mark_used(request)
23011 mark_used(tag)
23012 ierr = 1
23013 request = mp_request_null
23014 CALL mp_stop(ierr, "mp_isend called in non parallel case")
23015#endif
23016 CALL mp_timestop(handle)
23017 END SUBROUTINE mp_isend_rm4
23018
23019! **************************************************************************************************
23020!> \brief Non-blocking receive of vector data
23021!> \param msgout ...
23022!> \param source ...
23023!> \param comm ...
23024!> \param request ...
23025!> \param tag ...
23026!> \par History
23027!> 08.2003 created [f&j]
23028!> 2009-11-25 [UB] Made type-generic for templates
23029!> \note see mp_isendrecv_rv
23030!> \note
23031!> arrays can be pointers or assumed shape, but they must be contiguous!
23032! **************************************************************************************************
23033 SUBROUTINE mp_irecv_rv(msgout, source, comm, request, tag)
23034 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
23035 INTEGER, INTENT(IN) :: source
23036 CLASS(mp_comm_type), INTENT(IN) :: comm
23037 TYPE(mp_request_type), INTENT(out) :: request
23038 INTEGER, INTENT(in), OPTIONAL :: tag
23039
23040 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rv'
23041
23042 INTEGER :: handle
23043#if defined(__parallel)
23044 INTEGER :: ierr, msglen, my_tag
23045 REAL(kind=real_4) :: foo(1)
23046#endif
23047
23048 CALL mp_timeset(routinen, handle)
23049
23050#if defined(__parallel)
23051#if !defined(__GNUC__) || __GNUC__ >= 9
23052 cpassert(is_contiguous(msgout))
23053#endif
23054
23055 my_tag = 0
23056 IF (PRESENT(tag)) my_tag = tag
23057
23058 msglen = SIZE(msgout)
23059 IF (msglen > 0) THEN
23060 CALL mpi_irecv(msgout(1), msglen, mpi_real, source, my_tag, &
23061 comm%handle, request%handle, ierr)
23062 ELSE
23063 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23064 comm%handle, request%handle, ierr)
23065 END IF
23066 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
23067
23068 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23069#else
23070 cpabort("mp_irecv called in non parallel case")
23071 mark_used(msgout)
23072 mark_used(source)
23073 mark_used(comm)
23074 mark_used(tag)
23075 request = mp_request_null
23076#endif
23077 CALL mp_timestop(handle)
23078 END SUBROUTINE mp_irecv_rv
23079
23080! **************************************************************************************************
23081!> \brief Non-blocking receive of matrix data
23082!> \param msgout ...
23083!> \param source ...
23084!> \param comm ...
23085!> \param request ...
23086!> \param tag ...
23087!> \par History
23088!> 2009-11-25 [UB] Made type-generic for templates
23089!> \author fawzi
23090!> \note see mp_isendrecv_rv
23091!> \note see mp_irecv_rv
23092!> \note
23093!> arrays can be pointers or assumed shape, but they must be contiguous!
23094! **************************************************************************************************
23095 SUBROUTINE mp_irecv_rm2(msgout, source, comm, request, tag)
23096 REAL(kind=real_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
23097 INTEGER, INTENT(IN) :: source
23098 CLASS(mp_comm_type), INTENT(IN) :: comm
23099 TYPE(mp_request_type), INTENT(out) :: request
23100 INTEGER, INTENT(in), OPTIONAL :: tag
23101
23102 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm2'
23103
23104 INTEGER :: handle
23105#if defined(__parallel)
23106 INTEGER :: ierr, msglen, my_tag
23107 REAL(kind=real_4) :: foo(1)
23108#endif
23109
23110 CALL mp_timeset(routinen, handle)
23111
23112#if defined(__parallel)
23113#if !defined(__GNUC__) || __GNUC__ >= 9
23114 cpassert(is_contiguous(msgout))
23115#endif
23116
23117 my_tag = 0
23118 IF (PRESENT(tag)) my_tag = tag
23119
23120 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
23121 IF (msglen > 0) THEN
23122 CALL mpi_irecv(msgout(1, 1), msglen, mpi_real, source, my_tag, &
23123 comm%handle, request%handle, ierr)
23124 ELSE
23125 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23126 comm%handle, request%handle, ierr)
23127 END IF
23128 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
23129
23130 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23131#else
23132 mark_used(msgout)
23133 mark_used(source)
23134 mark_used(comm)
23135 mark_used(tag)
23136 request = mp_request_null
23137 cpabort("mp_irecv called in non parallel case")
23138#endif
23139 CALL mp_timestop(handle)
23140 END SUBROUTINE mp_irecv_rm2
23141
23142! **************************************************************************************************
23143!> \brief Non-blocking send of rank-3 data
23144!> \param msgout ...
23145!> \param source ...
23146!> \param comm ...
23147!> \param request ...
23148!> \param tag ...
23149!> \par History
23150!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
23151!> 2009-11-25 [UB] Made type-generic for templates
23152!> \author fawzi
23153!> \note see mp_isendrecv_rv
23154!> \note see mp_irecv_rv
23155!> \note
23156!> arrays can be pointers or assumed shape, but they must be contiguous!
23157! **************************************************************************************************
23158 SUBROUTINE mp_irecv_rm3(msgout, source, comm, request, tag)
23159 REAL(kind=real_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
23160 INTEGER, INTENT(IN) :: source
23161 CLASS(mp_comm_type), INTENT(IN) :: comm
23162 TYPE(mp_request_type), INTENT(out) :: request
23163 INTEGER, INTENT(in), OPTIONAL :: tag
23164
23165 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm3'
23166
23167 INTEGER :: handle
23168#if defined(__parallel)
23169 INTEGER :: ierr, msglen, my_tag
23170 REAL(kind=real_4) :: foo(1)
23171#endif
23172
23173 CALL mp_timeset(routinen, handle)
23174
23175#if defined(__parallel)
23176#if !defined(__GNUC__) || __GNUC__ >= 9
23177 cpassert(is_contiguous(msgout))
23178#endif
23179
23180 my_tag = 0
23181 IF (PRESENT(tag)) my_tag = tag
23182
23183 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
23184 IF (msglen > 0) THEN
23185 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_real, source, my_tag, &
23186 comm%handle, request%handle, ierr)
23187 ELSE
23188 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23189 comm%handle, request%handle, ierr)
23190 END IF
23191 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
23192
23193 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23194#else
23195 mark_used(msgout)
23196 mark_used(source)
23197 mark_used(comm)
23198 mark_used(tag)
23199 request = mp_request_null
23200 cpabort("mp_irecv called in non parallel case")
23201#endif
23202 CALL mp_timestop(handle)
23203 END SUBROUTINE mp_irecv_rm3
23204
23205! **************************************************************************************************
23206!> \brief Non-blocking receive of rank-4 data
23207!> \param msgout the output message
23208!> \param source the source processor
23209!> \param comm the communicator object
23210!> \param request the communication request id
23211!> \param tag the message tag
23212!> \par History
23213!> 2.2016 added _rm4 subroutine [Nico Holmberg]
23214!> \author fawzi
23215!> \note see mp_irecv_rv
23216!> \note
23217!> arrays can be pointers or assumed shape, but they must be contiguous!
23218! **************************************************************************************************
23219 SUBROUTINE mp_irecv_rm4(msgout, source, comm, request, tag)
23220 REAL(kind=real_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
23221 INTEGER, INTENT(IN) :: source
23222 CLASS(mp_comm_type), INTENT(IN) :: comm
23223 TYPE(mp_request_type), INTENT(out) :: request
23224 INTEGER, INTENT(in), OPTIONAL :: tag
23225
23226 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_rm4'
23227
23228 INTEGER :: handle
23229#if defined(__parallel)
23230 INTEGER :: ierr, msglen, my_tag
23231 REAL(kind=real_4) :: foo(1)
23232#endif
23233
23234 CALL mp_timeset(routinen, handle)
23235
23236#if defined(__parallel)
23237#if !defined(__GNUC__) || __GNUC__ >= 9
23238 cpassert(is_contiguous(msgout))
23239#endif
23240
23241 my_tag = 0
23242 IF (PRESENT(tag)) my_tag = tag
23243
23244 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
23245 IF (msglen > 0) THEN
23246 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_real, source, my_tag, &
23247 comm%handle, request%handle, ierr)
23248 ELSE
23249 CALL mpi_irecv(foo, msglen, mpi_real, source, my_tag, &
23250 comm%handle, request%handle, ierr)
23251 END IF
23252 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
23253
23254 CALL add_perf(perf_id=12, count=1, msg_size=msglen*real_4_size)
23255#else
23256 mark_used(msgout)
23257 mark_used(source)
23258 mark_used(comm)
23259 mark_used(tag)
23260 request = mp_request_null
23261 cpabort("mp_irecv called in non parallel case")
23262#endif
23263 CALL mp_timestop(handle)
23264 END SUBROUTINE mp_irecv_rm4
23265
23266! **************************************************************************************************
23267!> \brief Window initialization function for vector data
23268!> \param base ...
23269!> \param comm ...
23270!> \param win ...
23271!> \par History
23272!> 02.2015 created [Alfio Lazzaro]
23273!> \note
23274!> arrays can be pointers or assumed shape, but they must be contiguous!
23275! **************************************************************************************************
23276 SUBROUTINE mp_win_create_rv(base, comm, win)
23277 REAL(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
23278 TYPE(mp_comm_type), INTENT(IN) :: comm
23279 CLASS(mp_win_type), INTENT(INOUT) :: win
23280
23281 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_rv'
23282
23283 INTEGER :: handle
23284#if defined(__parallel)
23285 INTEGER :: ierr
23286 INTEGER(kind=mpi_address_kind) :: len
23287 REAL(kind=real_4) :: foo(1)
23288#endif
23289
23290 CALL mp_timeset(routinen, handle)
23291
23292#if defined(__parallel)
23293
23294 len = SIZE(base)*real_4_size
23295 IF (len > 0) THEN
23296 CALL mpi_win_create(base(1), len, real_4_size, mpi_info_null, comm%handle, win%handle, ierr)
23297 ELSE
23298 CALL mpi_win_create(foo, len, real_4_size, mpi_info_null, comm%handle, win%handle, ierr)
23299 END IF
23300 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
23301
23302 CALL add_perf(perf_id=20, count=1)
23303#else
23304 mark_used(base)
23305 mark_used(comm)
23306 win%handle = mp_win_null_handle
23307#endif
23308 CALL mp_timestop(handle)
23309 END SUBROUTINE mp_win_create_rv
23310
23311! **************************************************************************************************
23312!> \brief Single-sided get function for vector data
23313!> \param base ...
23314!> \param comm ...
23315!> \param win ...
23316!> \par History
23317!> 02.2015 created [Alfio Lazzaro]
23318!> \note
23319!> arrays can be pointers or assumed shape, but they must be contiguous!
23320! **************************************************************************************************
23321 SUBROUTINE mp_rget_rv(base, source, win, win_data, myproc, disp, request, &
23322 origin_datatype, target_datatype)
23323 REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
23324 INTEGER, INTENT(IN) :: source
23325 CLASS(mp_win_type), INTENT(IN) :: win
23326 REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: win_data
23327 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
23328 TYPE(mp_request_type), INTENT(OUT) :: request
23329 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
23330
23331 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_rv'
23332
23333 INTEGER :: handle
23334#if defined(__parallel)
23335 INTEGER :: ierr, len, &
23336 origin_len, target_len
23337 LOGICAL :: do_local_copy
23338 INTEGER(kind=mpi_address_kind) :: disp_aint
23339 mpi_data_type :: handle_origin_datatype, handle_target_datatype
23340#endif
23341
23342 CALL mp_timeset(routinen, handle)
23343
23344#if defined(__parallel)
23345 len = SIZE(base)
23346 disp_aint = 0
23347 IF (PRESENT(disp)) THEN
23348 disp_aint = int(disp, kind=mpi_address_kind)
23349 END IF
23350 handle_origin_datatype = mpi_real
23351 origin_len = len
23352 IF (PRESENT(origin_datatype)) THEN
23353 handle_origin_datatype = origin_datatype%type_handle
23354 origin_len = 1
23355 END IF
23356 handle_target_datatype = mpi_real
23357 target_len = len
23358 IF (PRESENT(target_datatype)) THEN
23359 handle_target_datatype = target_datatype%type_handle
23360 target_len = 1
23361 END IF
23362 IF (len > 0) THEN
23363 do_local_copy = .false.
23364 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
23365 IF (myproc .EQ. source) do_local_copy = .true.
23366 END IF
23367 IF (do_local_copy) THEN
23368 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
23369 base(:) = win_data(disp_aint + 1:disp_aint + len)
23370 !$OMP END PARALLEL WORKSHARE
23371 request = mp_request_null
23372 ierr = 0
23373 ELSE
23374 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
23375 target_len, handle_target_datatype, win%handle, request%handle, ierr)
23376 END IF
23377 ELSE
23378 request = mp_request_null
23379 ierr = 0
23380 END IF
23381 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
23382
23383 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*real_4_size)
23384#else
23385 mark_used(source)
23386 mark_used(win)
23387 mark_used(myproc)
23388 mark_used(origin_datatype)
23389 mark_used(target_datatype)
23390
23391 request = mp_request_null
23392 !
23393 IF (PRESENT(disp)) THEN
23394 base(:) = win_data(disp + 1:disp + SIZE(base))
23395 ELSE
23396 base(:) = win_data(:SIZE(base))
23397 END IF
23398
23399#endif
23400 CALL mp_timestop(handle)
23401 END SUBROUTINE mp_rget_rv
23402
23403! **************************************************************************************************
23404!> \brief ...
23405!> \param count ...
23406!> \param lengths ...
23407!> \param displs ...
23408!> \return ...
23409! ***************************************************************************
23410 FUNCTION mp_type_indexed_make_r (count, lengths, displs) &
23411 result(type_descriptor)
23412 INTEGER, INTENT(IN) :: count
23413 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
23414 TYPE(mp_type_descriptor_type) :: type_descriptor
23415
23416 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_r'
23417
23418 INTEGER :: handle
23419#if defined(__parallel)
23420 INTEGER :: ierr
23421#endif
23422
23423 CALL mp_timeset(routinen, handle)
23424
23425#if defined(__parallel)
23426 CALL mpi_type_indexed(count, lengths, displs, mpi_real, &
23427 type_descriptor%type_handle, ierr)
23428 IF (ierr /= 0) &
23429 cpabort("MPI_Type_Indexed @ "//routinen)
23430 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
23431 IF (ierr /= 0) &
23432 cpabort("MPI_Type_commit @ "//routinen)
23433#else
23434 type_descriptor%type_handle = 1
23435#endif
23436 type_descriptor%length = count
23437 NULLIFY (type_descriptor%subtype)
23438 type_descriptor%vector_descriptor(1:2) = 1
23439 type_descriptor%has_indexing = .true.
23440 type_descriptor%index_descriptor%index => lengths
23441 type_descriptor%index_descriptor%chunks => displs
23442
23443 CALL mp_timestop(handle)
23444
23445 END FUNCTION mp_type_indexed_make_r
23446
23447! **************************************************************************************************
23448!> \brief Allocates special parallel memory
23449!> \param[in] DATA pointer to integer array to allocate
23450!> \param[in] len number of integers to allocate
23451!> \param[out] stat (optional) allocation status result
23452!> \author UB
23453! **************************************************************************************************
23454 SUBROUTINE mp_allocate_r (DATA, len, stat)
23455 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23456 INTEGER, INTENT(IN) :: len
23457 INTEGER, INTENT(OUT), OPTIONAL :: stat
23458
23459 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_r'
23460
23461 INTEGER :: handle, ierr
23462
23463 CALL mp_timeset(routinen, handle)
23464
23465#if defined(__parallel)
23466 NULLIFY (data)
23467 CALL mp_alloc_mem(DATA, len, stat=ierr)
23468 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
23469 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
23470 CALL add_perf(perf_id=15, count=1)
23471#else
23472 ALLOCATE (DATA(len), stat=ierr)
23473 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
23474 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
23475#endif
23476 IF (PRESENT(stat)) stat = ierr
23477 CALL mp_timestop(handle)
23478 END SUBROUTINE mp_allocate_r
23479
23480! **************************************************************************************************
23481!> \brief Deallocates special parallel memory
23482!> \param[in] DATA pointer to special memory to deallocate
23483!> \param stat ...
23484!> \author UB
23485! **************************************************************************************************
23486 SUBROUTINE mp_deallocate_r (DATA, stat)
23487 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23488 INTEGER, INTENT(OUT), OPTIONAL :: stat
23489
23490 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_r'
23491
23492 INTEGER :: handle
23493#if defined(__parallel)
23494 INTEGER :: ierr
23495#endif
23496
23497 CALL mp_timeset(routinen, handle)
23498
23499#if defined(__parallel)
23500 CALL mp_free_mem(DATA, ierr)
23501 IF (PRESENT(stat)) THEN
23502 stat = ierr
23503 ELSE
23504 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
23505 END IF
23506 NULLIFY (data)
23507 CALL add_perf(perf_id=15, count=1)
23508#else
23509 DEALLOCATE (data)
23510 IF (PRESENT(stat)) stat = 0
23511#endif
23512 CALL mp_timestop(handle)
23513 END SUBROUTINE mp_deallocate_r
23514
23515! **************************************************************************************************
23516!> \brief (parallel) Blocking individual file write using explicit offsets
23517!> (serial) Unformatted stream write
23518!> \param[in] fh file handle (file storage unit)
23519!> \param[in] offset file offset (position)
23520!> \param[in] msg data to be written to the file
23521!> \param msglen ...
23522!> \par MPI-I/O mapping mpi_file_write_at
23523!> \par STREAM-I/O mapping WRITE
23524!> \param[in](optional) msglen number of the elements of data
23525! **************************************************************************************************
23526 SUBROUTINE mp_file_write_at_rv(fh, offset, msg, msglen)
23527 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
23528 CLASS(mp_file_type), INTENT(IN) :: fh
23529 INTEGER, INTENT(IN), OPTIONAL :: msglen
23530 INTEGER(kind=file_offset), INTENT(IN) :: offset
23531
23532 INTEGER :: msg_len
23533#if defined(__parallel)
23534 INTEGER :: ierr
23535#endif
23536
23537 msg_len = SIZE(msg)
23538 IF (PRESENT(msglen)) msg_len = msglen
23539#if defined(__parallel)
23540 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23541 IF (ierr .NE. 0) &
23542 cpabort("mpi_file_write_at_rv @ mp_file_write_at_rv")
23543#else
23544 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23545#endif
23546 END SUBROUTINE mp_file_write_at_rv
23547
23548! **************************************************************************************************
23549!> \brief ...
23550!> \param fh ...
23551!> \param offset ...
23552!> \param msg ...
23553! **************************************************************************************************
23554 SUBROUTINE mp_file_write_at_r (fh, offset, msg)
23555 REAL(kind=real_4), INTENT(IN) :: msg
23556 CLASS(mp_file_type), INTENT(IN) :: fh
23557 INTEGER(kind=file_offset), INTENT(IN) :: offset
23558
23559#if defined(__parallel)
23560 INTEGER :: ierr
23561
23562 ierr = 0
23563 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23564 IF (ierr .NE. 0) &
23565 cpabort("mpi_file_write_at_r @ mp_file_write_at_r")
23566#else
23567 WRITE (unit=fh%handle, pos=offset + 1) msg
23568#endif
23569 END SUBROUTINE mp_file_write_at_r
23570
23571! **************************************************************************************************
23572!> \brief (parallel) Blocking collective file write using explicit offsets
23573!> (serial) Unformatted stream write
23574!> \param fh ...
23575!> \param offset ...
23576!> \param msg ...
23577!> \param msglen ...
23578!> \par MPI-I/O mapping mpi_file_write_at_all
23579!> \par STREAM-I/O mapping WRITE
23580! **************************************************************************************************
23581 SUBROUTINE mp_file_write_at_all_rv(fh, offset, msg, msglen)
23582 REAL(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
23583 CLASS(mp_file_type), INTENT(IN) :: fh
23584 INTEGER, INTENT(IN), OPTIONAL :: msglen
23585 INTEGER(kind=file_offset), INTENT(IN) :: offset
23586
23587 INTEGER :: msg_len
23588#if defined(__parallel)
23589 INTEGER :: ierr
23590#endif
23591
23592 msg_len = SIZE(msg)
23593 IF (PRESENT(msglen)) msg_len = msglen
23594#if defined(__parallel)
23595 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23596 IF (ierr .NE. 0) &
23597 cpabort("mpi_file_write_at_all_rv @ mp_file_write_at_all_rv")
23598#else
23599 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23600#endif
23601 END SUBROUTINE mp_file_write_at_all_rv
23602
23603! **************************************************************************************************
23604!> \brief ...
23605!> \param fh ...
23606!> \param offset ...
23607!> \param msg ...
23608! **************************************************************************************************
23609 SUBROUTINE mp_file_write_at_all_r (fh, offset, msg)
23610 REAL(kind=real_4), INTENT(IN) :: msg
23611 CLASS(mp_file_type), INTENT(IN) :: fh
23612 INTEGER(kind=file_offset), INTENT(IN) :: offset
23613
23614#if defined(__parallel)
23615 INTEGER :: ierr
23616
23617 ierr = 0
23618 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23619 IF (ierr .NE. 0) &
23620 cpabort("mpi_file_write_at_all_r @ mp_file_write_at_all_r")
23621#else
23622 WRITE (unit=fh%handle, pos=offset + 1) msg
23623#endif
23624 END SUBROUTINE mp_file_write_at_all_r
23625
23626! **************************************************************************************************
23627!> \brief (parallel) Blocking individual file read using explicit offsets
23628!> (serial) Unformatted stream read
23629!> \param[in] fh file handle (file storage unit)
23630!> \param[in] offset file offset (position)
23631!> \param[out] msg data to be read from the file
23632!> \param msglen ...
23633!> \par MPI-I/O mapping mpi_file_read_at
23634!> \par STREAM-I/O mapping READ
23635!> \param[in](optional) msglen number of elements of data
23636! **************************************************************************************************
23637 SUBROUTINE mp_file_read_at_rv(fh, offset, msg, msglen)
23638 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
23639 CLASS(mp_file_type), INTENT(IN) :: fh
23640 INTEGER, INTENT(IN), OPTIONAL :: msglen
23641 INTEGER(kind=file_offset), INTENT(IN) :: offset
23642
23643 INTEGER :: msg_len
23644#if defined(__parallel)
23645 INTEGER :: ierr
23646#endif
23647
23648 msg_len = SIZE(msg)
23649 IF (PRESENT(msglen)) msg_len = msglen
23650#if defined(__parallel)
23651 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23652 IF (ierr .NE. 0) &
23653 cpabort("mpi_file_read_at_rv @ mp_file_read_at_rv")
23654#else
23655 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23656#endif
23657 END SUBROUTINE mp_file_read_at_rv
23658
23659! **************************************************************************************************
23660!> \brief ...
23661!> \param fh ...
23662!> \param offset ...
23663!> \param msg ...
23664! **************************************************************************************************
23665 SUBROUTINE mp_file_read_at_r (fh, offset, msg)
23666 REAL(kind=real_4), INTENT(OUT) :: msg
23667 CLASS(mp_file_type), INTENT(IN) :: fh
23668 INTEGER(kind=file_offset), INTENT(IN) :: offset
23669
23670#if defined(__parallel)
23671 INTEGER :: ierr
23672
23673 ierr = 0
23674 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23675 IF (ierr .NE. 0) &
23676 cpabort("mpi_file_read_at_r @ mp_file_read_at_r")
23677#else
23678 READ (unit=fh%handle, pos=offset + 1) msg
23679#endif
23680 END SUBROUTINE mp_file_read_at_r
23681
23682! **************************************************************************************************
23683!> \brief (parallel) Blocking collective file read using explicit offsets
23684!> (serial) Unformatted stream read
23685!> \param fh ...
23686!> \param offset ...
23687!> \param msg ...
23688!> \param msglen ...
23689!> \par MPI-I/O mapping mpi_file_read_at_all
23690!> \par STREAM-I/O mapping READ
23691! **************************************************************************************************
23692 SUBROUTINE mp_file_read_at_all_rv(fh, offset, msg, msglen)
23693 REAL(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
23694 CLASS(mp_file_type), INTENT(IN) :: fh
23695 INTEGER, INTENT(IN), OPTIONAL :: msglen
23696 INTEGER(kind=file_offset), INTENT(IN) :: offset
23697
23698 INTEGER :: msg_len
23699#if defined(__parallel)
23700 INTEGER :: ierr
23701#endif
23702
23703 msg_len = SIZE(msg)
23704 IF (PRESENT(msglen)) msg_len = msglen
23705#if defined(__parallel)
23706 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_real, mpi_status_ignore, ierr)
23707 IF (ierr .NE. 0) &
23708 cpabort("mpi_file_read_at_all_rv @ mp_file_read_at_all_rv")
23709#else
23710 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
23711#endif
23712 END SUBROUTINE mp_file_read_at_all_rv
23713
23714! **************************************************************************************************
23715!> \brief ...
23716!> \param fh ...
23717!> \param offset ...
23718!> \param msg ...
23719! **************************************************************************************************
23720 SUBROUTINE mp_file_read_at_all_r (fh, offset, msg)
23721 REAL(kind=real_4), INTENT(OUT) :: msg
23722 CLASS(mp_file_type), INTENT(IN) :: fh
23723 INTEGER(kind=file_offset), INTENT(IN) :: offset
23724
23725#if defined(__parallel)
23726 INTEGER :: ierr
23727
23728 ierr = 0
23729 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_real, mpi_status_ignore, ierr)
23730 IF (ierr .NE. 0) &
23731 cpabort("mpi_file_read_at_all_r @ mp_file_read_at_all_r")
23732#else
23733 READ (unit=fh%handle, pos=offset + 1) msg
23734#endif
23735 END SUBROUTINE mp_file_read_at_all_r
23736
23737! **************************************************************************************************
23738!> \brief ...
23739!> \param ptr ...
23740!> \param vector_descriptor ...
23741!> \param index_descriptor ...
23742!> \return ...
23743! **************************************************************************************************
23744 FUNCTION mp_type_make_r (ptr, &
23745 vector_descriptor, index_descriptor) &
23746 result(type_descriptor)
23747 REAL(kind=real_4), DIMENSION(:), TARGET, asynchronous :: ptr
23748 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
23749 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
23750 TYPE(mp_type_descriptor_type) :: type_descriptor
23751
23752 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_r'
23753
23754#if defined(__parallel)
23755 INTEGER :: ierr
23756#endif
23757
23758 NULLIFY (type_descriptor%subtype)
23759 type_descriptor%length = SIZE(ptr)
23760#if defined(__parallel)
23761 type_descriptor%type_handle = mpi_real
23762 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
23763 IF (ierr /= 0) &
23764 cpabort("MPI_Get_address @ "//routinen)
23765#else
23766 type_descriptor%type_handle = 1
23767#endif
23768 type_descriptor%vector_descriptor(1:2) = 1
23769 type_descriptor%has_indexing = .false.
23770 type_descriptor%data_r => ptr
23771 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
23772 cpabort(routinen//": Vectors and indices NYI")
23773 END IF
23774 END FUNCTION mp_type_make_r
23775
23776! **************************************************************************************************
23777!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
23778!> as the Fortran version returns an integer, which we take to be a C_PTR
23779!> \param DATA data array to allocate
23780!> \param[in] len length (in data elements) of data array allocation
23781!> \param[out] stat (optional) allocation status result
23782! **************************************************************************************************
23783 SUBROUTINE mp_alloc_mem_r (DATA, len, stat)
23784 REAL(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
23785 INTEGER, INTENT(IN) :: len
23786 INTEGER, INTENT(OUT), OPTIONAL :: stat
23787
23788#if defined(__parallel)
23789 INTEGER :: size, ierr, length, &
23790 mp_res
23791 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
23792 TYPE(c_ptr) :: mp_baseptr
23793 mpi_info_type :: mp_info
23794
23795 length = max(len, 1)
23796 CALL mpi_type_size(mpi_real, size, ierr)
23797 mp_size = int(length, kind=mpi_address_kind)*size
23798 IF (mp_size .GT. mp_max_memory_size) THEN
23799 cpabort("MPI cannot allocate more than 2 GiByte")
23800 END IF
23801 mp_info = mpi_info_null
23802 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
23803 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
23804 IF (PRESENT(stat)) stat = mp_res
23805#else
23806 INTEGER :: length, mystat
23807 length = max(len, 1)
23808 IF (PRESENT(stat)) THEN
23809 ALLOCATE (DATA(length), stat=mystat)
23810 stat = mystat ! show to convention checker that stat is used
23811 ELSE
23812 ALLOCATE (DATA(length))
23813 END IF
23814#endif
23815 END SUBROUTINE mp_alloc_mem_r
23816
23817! **************************************************************************************************
23818!> \brief Deallocates am array, ... this is hackish
23819!> as the Fortran version takes an integer, which we hope to get by reference
23820!> \param DATA data array to allocate
23821!> \param[out] stat (optional) allocation status result
23822! **************************************************************************************************
23823 SUBROUTINE mp_free_mem_r (DATA, stat)
23824 REAL(kind=real_4), DIMENSION(:), &
23825 POINTER, asynchronous :: DATA
23826 INTEGER, INTENT(OUT), OPTIONAL :: stat
23827
23828#if defined(__parallel)
23829 INTEGER :: mp_res
23830 CALL mpi_free_mem(DATA, mp_res)
23831 IF (PRESENT(stat)) stat = mp_res
23832#else
23833 DEALLOCATE (data)
23834 IF (PRESENT(stat)) stat = 0
23835#endif
23836 END SUBROUTINE mp_free_mem_r
23837! **************************************************************************************************
23838!> \brief Shift around the data in msg
23839!> \param[in,out] msg Rank-2 data to shift
23840!> \param[in] comm message passing environment identifier
23841!> \param[in] displ_in displacements (?)
23842!> \par Example
23843!> msg will be moved from rank to rank+displ_in (in a circular way)
23844!> \par Limitations
23845!> * displ_in will be 1 by default (others not tested)
23846!> * the message array needs to be the same size on all processes
23847! **************************************************************************************************
23848 SUBROUTINE mp_shift_zm(msg, comm, displ_in)
23849
23850 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
23851 CLASS(mp_comm_type), INTENT(IN) :: comm
23852 INTEGER, INTENT(IN), OPTIONAL :: displ_in
23853
23854 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_zm'
23855
23856 INTEGER :: handle, ierror
23857#if defined(__parallel)
23858 INTEGER :: displ, left, &
23859 msglen, myrank, nprocs, &
23860 right, tag
23861#endif
23862
23863 ierror = 0
23864 CALL mp_timeset(routinen, handle)
23865
23866#if defined(__parallel)
23867 CALL mpi_comm_rank(comm%handle, myrank, ierror)
23868 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
23869 CALL mpi_comm_size(comm%handle, nprocs, ierror)
23870 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
23871 IF (PRESENT(displ_in)) THEN
23872 displ = displ_in
23873 ELSE
23874 displ = 1
23875 END IF
23876 right = modulo(myrank + displ, nprocs)
23877 left = modulo(myrank - displ, nprocs)
23878 tag = 17
23879 msglen = SIZE(msg)
23880 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_complex, right, tag, left, tag, &
23881 comm%handle, mpi_status_ignore, ierror)
23882 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
23883 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_8_size))
23884#else
23885 mark_used(msg)
23886 mark_used(comm)
23887 mark_used(displ_in)
23888#endif
23889 CALL mp_timestop(handle)
23890
23891 END SUBROUTINE mp_shift_zm
23892
23893! **************************************************************************************************
23894!> \brief Shift around the data in msg
23895!> \param[in,out] msg Data to shift
23896!> \param[in] comm message passing environment identifier
23897!> \param[in] displ_in displacements (?)
23898!> \par Example
23899!> msg will be moved from rank to rank+displ_in (in a circular way)
23900!> \par Limitations
23901!> * displ_in will be 1 by default (others not tested)
23902!> * the message array needs to be the same size on all processes
23903! **************************************************************************************************
23904 SUBROUTINE mp_shift_z (msg, comm, displ_in)
23905
23906 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
23907 CLASS(mp_comm_type), INTENT(IN) :: comm
23908 INTEGER, INTENT(IN), OPTIONAL :: displ_in
23909
23910 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_z'
23911
23912 INTEGER :: handle, ierror
23913#if defined(__parallel)
23914 INTEGER :: displ, left, &
23915 msglen, myrank, nprocs, &
23916 right, tag
23917#endif
23918
23919 ierror = 0
23920 CALL mp_timeset(routinen, handle)
23921
23922#if defined(__parallel)
23923 CALL mpi_comm_rank(comm%handle, myrank, ierror)
23924 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
23925 CALL mpi_comm_size(comm%handle, nprocs, ierror)
23926 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
23927 IF (PRESENT(displ_in)) THEN
23928 displ = displ_in
23929 ELSE
23930 displ = 1
23931 END IF
23932 right = modulo(myrank + displ, nprocs)
23933 left = modulo(myrank - displ, nprocs)
23934 tag = 19
23935 msglen = SIZE(msg)
23936 CALL mpi_sendrecv_replace(msg, msglen, mpi_double_complex, right, tag, left, &
23937 tag, comm%handle, mpi_status_ignore, ierror)
23938 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
23939 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_8_size))
23940#else
23941 mark_used(msg)
23942 mark_used(comm)
23943 mark_used(displ_in)
23944#endif
23945 CALL mp_timestop(handle)
23946
23947 END SUBROUTINE mp_shift_z
23948
23949! **************************************************************************************************
23950!> \brief All-to-all data exchange, rank-1 data of different sizes
23951!> \param[in] sb Data to send
23952!> \param[in] scount Data counts for data sent to other processes
23953!> \param[in] sdispl Respective data offsets for data sent to process
23954!> \param[in,out] rb Buffer into which to receive data
23955!> \param[in] rcount Data counts for data received from other
23956!> processes
23957!> \param[in] rdispl Respective data offsets for data received from
23958!> other processes
23959!> \param[in] comm Message passing environment identifier
23960!> \par MPI mapping
23961!> mpi_alltoallv
23962!> \par Array sizes
23963!> The scount, rcount, and the sdispl and rdispl arrays have a
23964!> size equal to the number of processes.
23965!> \par Offsets
23966!> Values in sdispl and rdispl start with 0.
23967! **************************************************************************************************
23968 SUBROUTINE mp_alltoall_z11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
23969
23970 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
23971 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
23972 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
23973 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
23974 CLASS(mp_comm_type), INTENT(IN) :: comm
23975
23976 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z11v'
23977
23978 INTEGER :: handle
23979#if defined(__parallel)
23980 INTEGER :: ierr, msglen
23981#else
23982 INTEGER :: i
23983#endif
23984
23985 CALL mp_timeset(routinen, handle)
23986
23987#if defined(__parallel)
23988 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_complex, &
23989 rb, rcount, rdispl, mpi_double_complex, comm%handle, ierr)
23990 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
23991 msglen = sum(scount) + sum(rcount)
23992 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
23993#else
23994 mark_used(comm)
23995 mark_used(scount)
23996 mark_used(sdispl)
23997 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
23998 DO i = 1, rcount(1)
23999 rb(rdispl(1) + i) = sb(sdispl(1) + i)
24000 END DO
24001#endif
24002 CALL mp_timestop(handle)
24003
24004 END SUBROUTINE mp_alltoall_z11v
24005
24006! **************************************************************************************************
24007!> \brief All-to-all data exchange, rank-2 data of different sizes
24008!> \param sb ...
24009!> \param scount ...
24010!> \param sdispl ...
24011!> \param rb ...
24012!> \param rcount ...
24013!> \param rdispl ...
24014!> \param comm ...
24015!> \par MPI mapping
24016!> mpi_alltoallv
24017!> \note see mp_alltoall_z11v
24018! **************************************************************************************************
24019 SUBROUTINE mp_alltoall_z22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
24020
24021 COMPLEX(kind=real_8), DIMENSION(:, :), &
24022 INTENT(IN), CONTIGUOUS :: sb
24023 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
24024 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, &
24025 INTENT(INOUT) :: rb
24026 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
24027 CLASS(mp_comm_type), INTENT(IN) :: comm
24028
24029 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z22v'
24030
24031 INTEGER :: handle
24032#if defined(__parallel)
24033 INTEGER :: ierr, msglen
24034#endif
24035
24036 CALL mp_timeset(routinen, handle)
24037
24038#if defined(__parallel)
24039 CALL mpi_alltoallv(sb, scount, sdispl, mpi_double_complex, &
24040 rb, rcount, rdispl, mpi_double_complex, comm%handle, ierr)
24041 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
24042 msglen = sum(scount) + sum(rcount)
24043 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*(2*real_8_size))
24044#else
24045 mark_used(comm)
24046 mark_used(scount)
24047 mark_used(sdispl)
24048 mark_used(rcount)
24049 mark_used(rdispl)
24050 rb = sb
24051#endif
24052 CALL mp_timestop(handle)
24053
24054 END SUBROUTINE mp_alltoall_z22v
24055
24056! **************************************************************************************************
24057!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
24058!> \param[in] sb array with data to send
24059!> \param[out] rb array into which data is received
24060!> \param[in] count number of elements to send/receive (product of the
24061!> extents of the first two dimensions)
24062!> \param[in] comm Message passing environment identifier
24063!> \par Index meaning
24064!> \par The first two indices specify the data while the last index counts
24065!> the processes
24066!> \par Sizes of ranks
24067!> All processes have the same data size.
24068!> \par MPI mapping
24069!> mpi_alltoall
24070! **************************************************************************************************
24071 SUBROUTINE mp_alltoall_z (sb, rb, count, comm)
24072
24073 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
24074 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
24075 INTEGER, INTENT(IN) :: count
24076 CLASS(mp_comm_type), INTENT(IN) :: comm
24077
24078 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z'
24079
24080 INTEGER :: handle
24081#if defined(__parallel)
24082 INTEGER :: ierr, msglen, np
24083#endif
24084
24085 CALL mp_timeset(routinen, handle)
24086
24087#if defined(__parallel)
24088 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24089 rb, count, mpi_double_complex, comm%handle, ierr)
24090 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24091 CALL mpi_comm_size(comm%handle, np, ierr)
24092 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24093 msglen = 2*count*np
24094 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24095#else
24096 mark_used(count)
24097 mark_used(comm)
24098 rb = sb
24099#endif
24100 CALL mp_timestop(handle)
24101
24102 END SUBROUTINE mp_alltoall_z
24103
24104! **************************************************************************************************
24105!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
24106!> \param sb ...
24107!> \param rb ...
24108!> \param count ...
24109!> \param commp ...
24110!> \note see mp_alltoall_z
24111! **************************************************************************************************
24112 SUBROUTINE mp_alltoall_z22(sb, rb, count, comm)
24113
24114 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
24115 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
24116 INTEGER, INTENT(IN) :: count
24117 CLASS(mp_comm_type), INTENT(IN) :: comm
24118
24119 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z22'
24120
24121 INTEGER :: handle
24122#if defined(__parallel)
24123 INTEGER :: ierr, msglen, np
24124#endif
24125
24126 CALL mp_timeset(routinen, handle)
24127
24128#if defined(__parallel)
24129 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24130 rb, count, mpi_double_complex, comm%handle, ierr)
24131 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24132 CALL mpi_comm_size(comm%handle, np, ierr)
24133 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24134 msglen = 2*SIZE(sb)*np
24135 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24136#else
24137 mark_used(count)
24138 mark_used(comm)
24139 rb = sb
24140#endif
24141 CALL mp_timestop(handle)
24142
24143 END SUBROUTINE mp_alltoall_z22
24144
24145! **************************************************************************************************
24146!> \brief All-to-all data exchange, rank-3 data with equal sizes
24147!> \param sb ...
24148!> \param rb ...
24149!> \param count ...
24150!> \param comm ...
24151!> \note see mp_alltoall_z
24152! **************************************************************************************************
24153 SUBROUTINE mp_alltoall_z33(sb, rb, count, comm)
24154
24155 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
24156 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
24157 INTEGER, INTENT(IN) :: count
24158 CLASS(mp_comm_type), INTENT(IN) :: comm
24159
24160 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z33'
24161
24162 INTEGER :: handle
24163#if defined(__parallel)
24164 INTEGER :: ierr, msglen, np
24165#endif
24166
24167 CALL mp_timeset(routinen, handle)
24168
24169#if defined(__parallel)
24170 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24171 rb, count, mpi_double_complex, comm%handle, ierr)
24172 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24173 CALL mpi_comm_size(comm%handle, np, ierr)
24174 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24175 msglen = 2*count*np
24176 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24177#else
24178 mark_used(count)
24179 mark_used(comm)
24180 rb = sb
24181#endif
24182 CALL mp_timestop(handle)
24183
24184 END SUBROUTINE mp_alltoall_z33
24185
24186! **************************************************************************************************
24187!> \brief All-to-all data exchange, rank 4 data, equal sizes
24188!> \param sb ...
24189!> \param rb ...
24190!> \param count ...
24191!> \param comm ...
24192!> \note see mp_alltoall_z
24193! **************************************************************************************************
24194 SUBROUTINE mp_alltoall_z44(sb, rb, count, comm)
24195
24196 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24197 INTENT(IN) :: sb
24198 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24199 INTENT(OUT) :: rb
24200 INTEGER, INTENT(IN) :: count
24201 CLASS(mp_comm_type), INTENT(IN) :: comm
24202
24203 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z44'
24204
24205 INTEGER :: handle
24206#if defined(__parallel)
24207 INTEGER :: ierr, msglen, np
24208#endif
24209
24210 CALL mp_timeset(routinen, handle)
24211
24212#if defined(__parallel)
24213 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24214 rb, count, mpi_double_complex, comm%handle, ierr)
24215 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24216 CALL mpi_comm_size(comm%handle, np, ierr)
24217 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24218 msglen = 2*count*np
24219 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24220#else
24221 mark_used(count)
24222 mark_used(comm)
24223 rb = sb
24224#endif
24225 CALL mp_timestop(handle)
24226
24227 END SUBROUTINE mp_alltoall_z44
24228
24229! **************************************************************************************************
24230!> \brief All-to-all data exchange, rank 5 data, equal sizes
24231!> \param sb ...
24232!> \param rb ...
24233!> \param count ...
24234!> \param comm ...
24235!> \note see mp_alltoall_z
24236! **************************************************************************************************
24237 SUBROUTINE mp_alltoall_z55(sb, rb, count, comm)
24238
24239 COMPLEX(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
24240 INTENT(IN) :: sb
24241 COMPLEX(kind=real_8), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
24242 INTENT(OUT) :: rb
24243 INTEGER, INTENT(IN) :: count
24244 CLASS(mp_comm_type), INTENT(IN) :: comm
24245
24246 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z55'
24247
24248 INTEGER :: handle
24249#if defined(__parallel)
24250 INTEGER :: ierr, msglen, np
24251#endif
24252
24253 CALL mp_timeset(routinen, handle)
24254
24255#if defined(__parallel)
24256 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24257 rb, count, mpi_double_complex, comm%handle, ierr)
24258 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24259 CALL mpi_comm_size(comm%handle, np, ierr)
24260 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24261 msglen = 2*count*np
24262 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24263#else
24264 mark_used(count)
24265 mark_used(comm)
24266 rb = sb
24267#endif
24268 CALL mp_timestop(handle)
24269
24270 END SUBROUTINE mp_alltoall_z55
24271
24272! **************************************************************************************************
24273!> \brief All-to-all data exchange, rank-4 data to rank-5 data
24274!> \param sb ...
24275!> \param rb ...
24276!> \param count ...
24277!> \param comm ...
24278!> \note see mp_alltoall_z
24279!> \note User must ensure size consistency.
24280! **************************************************************************************************
24281 SUBROUTINE mp_alltoall_z45(sb, rb, count, comm)
24282
24283 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24284 INTENT(IN) :: sb
24285 COMPLEX(kind=real_8), &
24286 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
24287 INTEGER, INTENT(IN) :: count
24288 CLASS(mp_comm_type), INTENT(IN) :: comm
24289
24290 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z45'
24291
24292 INTEGER :: handle
24293#if defined(__parallel)
24294 INTEGER :: ierr, msglen, np
24295#endif
24296
24297 CALL mp_timeset(routinen, handle)
24298
24299#if defined(__parallel)
24300 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24301 rb, count, mpi_double_complex, comm%handle, ierr)
24302 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24303 CALL mpi_comm_size(comm%handle, np, ierr)
24304 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24305 msglen = 2*count*np
24306 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24307#else
24308 mark_used(count)
24309 mark_used(comm)
24310 rb = reshape(sb, shape(rb))
24311#endif
24312 CALL mp_timestop(handle)
24313
24314 END SUBROUTINE mp_alltoall_z45
24315
24316! **************************************************************************************************
24317!> \brief All-to-all data exchange, rank-3 data to rank-4 data
24318!> \param sb ...
24319!> \param rb ...
24320!> \param count ...
24321!> \param comm ...
24322!> \note see mp_alltoall_z
24323!> \note User must ensure size consistency.
24324! **************************************************************************************************
24325 SUBROUTINE mp_alltoall_z34(sb, rb, count, comm)
24326
24327 COMPLEX(kind=real_8), DIMENSION(:, :, :), CONTIGUOUS, &
24328 INTENT(IN) :: sb
24329 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24330 INTENT(OUT) :: rb
24331 INTEGER, INTENT(IN) :: count
24332 CLASS(mp_comm_type), INTENT(IN) :: comm
24333
24334 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z34'
24335
24336 INTEGER :: handle
24337#if defined(__parallel)
24338 INTEGER :: ierr, msglen, np
24339#endif
24340
24341 CALL mp_timeset(routinen, handle)
24342
24343#if defined(__parallel)
24344 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24345 rb, count, mpi_double_complex, comm%handle, ierr)
24346 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24347 CALL mpi_comm_size(comm%handle, np, ierr)
24348 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24349 msglen = 2*count*np
24350 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24351#else
24352 mark_used(count)
24353 mark_used(comm)
24354 rb = reshape(sb, shape(rb))
24355#endif
24356 CALL mp_timestop(handle)
24357
24358 END SUBROUTINE mp_alltoall_z34
24359
24360! **************************************************************************************************
24361!> \brief All-to-all data exchange, rank-5 data to rank-4 data
24362!> \param sb ...
24363!> \param rb ...
24364!> \param count ...
24365!> \param comm ...
24366!> \note see mp_alltoall_z
24367!> \note User must ensure size consistency.
24368! **************************************************************************************************
24369 SUBROUTINE mp_alltoall_z54(sb, rb, count, comm)
24370
24371 COMPLEX(kind=real_8), &
24372 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
24373 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), CONTIGUOUS, &
24374 INTENT(OUT) :: rb
24375 INTEGER, INTENT(IN) :: count
24376 CLASS(mp_comm_type), INTENT(IN) :: comm
24377
24378 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_z54'
24379
24380 INTEGER :: handle
24381#if defined(__parallel)
24382 INTEGER :: ierr, msglen, np
24383#endif
24384
24385 CALL mp_timeset(routinen, handle)
24386
24387#if defined(__parallel)
24388 CALL mpi_alltoall(sb, count, mpi_double_complex, &
24389 rb, count, mpi_double_complex, comm%handle, ierr)
24390 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
24391 CALL mpi_comm_size(comm%handle, np, ierr)
24392 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
24393 msglen = 2*count*np
24394 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_8_size))
24395#else
24396 mark_used(count)
24397 mark_used(comm)
24398 rb = reshape(sb, shape(rb))
24399#endif
24400 CALL mp_timestop(handle)
24401
24402 END SUBROUTINE mp_alltoall_z54
24403
24404! **************************************************************************************************
24405!> \brief Send one datum to another process
24406!> \param[in] msg Scalar to send
24407!> \param[in] dest Destination process
24408!> \param[in] tag Transfer identifier
24409!> \param[in] comm Message passing environment identifier
24410!> \par MPI mapping
24411!> mpi_send
24412! **************************************************************************************************
24413 SUBROUTINE mp_send_z (msg, dest, tag, comm)
24414 COMPLEX(kind=real_8), INTENT(IN) :: msg
24415 INTEGER, INTENT(IN) :: dest, tag
24416 CLASS(mp_comm_type), INTENT(IN) :: comm
24417
24418 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_z'
24419
24420 INTEGER :: handle
24421#if defined(__parallel)
24422 INTEGER :: ierr, msglen
24423#endif
24424
24425 CALL mp_timeset(routinen, handle)
24426
24427#if defined(__parallel)
24428 msglen = 1
24429 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24430 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24431 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24432#else
24433 mark_used(msg)
24434 mark_used(dest)
24435 mark_used(tag)
24436 mark_used(comm)
24437 ! only defined in parallel
24438 cpabort("not in parallel mode")
24439#endif
24440 CALL mp_timestop(handle)
24441 END SUBROUTINE mp_send_z
24442
24443! **************************************************************************************************
24444!> \brief Send rank-1 data to another process
24445!> \param[in] msg Rank-1 data to send
24446!> \param dest ...
24447!> \param tag ...
24448!> \param comm ...
24449!> \note see mp_send_z
24450! **************************************************************************************************
24451 SUBROUTINE mp_send_zv(msg, dest, tag, comm)
24452 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
24453 INTEGER, INTENT(IN) :: dest, tag
24454 CLASS(mp_comm_type), INTENT(IN) :: comm
24455
24456 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_zv'
24457
24458 INTEGER :: handle
24459#if defined(__parallel)
24460 INTEGER :: ierr, msglen
24461#endif
24462
24463 CALL mp_timeset(routinen, handle)
24464
24465#if defined(__parallel)
24466 msglen = SIZE(msg)
24467 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24468 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24469 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24470#else
24471 mark_used(msg)
24472 mark_used(dest)
24473 mark_used(tag)
24474 mark_used(comm)
24475 ! only defined in parallel
24476 cpabort("not in parallel mode")
24477#endif
24478 CALL mp_timestop(handle)
24479 END SUBROUTINE mp_send_zv
24480
24481! **************************************************************************************************
24482!> \brief Send rank-2 data to another process
24483!> \param[in] msg Rank-2 data to send
24484!> \param dest ...
24485!> \param tag ...
24486!> \param comm ...
24487!> \note see mp_send_z
24488! **************************************************************************************************
24489 SUBROUTINE mp_send_zm2(msg, dest, tag, comm)
24490 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
24491 INTEGER, INTENT(IN) :: dest, tag
24492 CLASS(mp_comm_type), INTENT(IN) :: comm
24493
24494 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_zm2'
24495
24496 INTEGER :: handle
24497#if defined(__parallel)
24498 INTEGER :: ierr, msglen
24499#endif
24500
24501 CALL mp_timeset(routinen, handle)
24502
24503#if defined(__parallel)
24504 msglen = SIZE(msg)
24505 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24506 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24507 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24508#else
24509 mark_used(msg)
24510 mark_used(dest)
24511 mark_used(tag)
24512 mark_used(comm)
24513 ! only defined in parallel
24514 cpabort("not in parallel mode")
24515#endif
24516 CALL mp_timestop(handle)
24517 END SUBROUTINE mp_send_zm2
24518
24519! **************************************************************************************************
24520!> \brief Send rank-3 data to another process
24521!> \param[in] msg Rank-3 data to send
24522!> \param dest ...
24523!> \param tag ...
24524!> \param comm ...
24525!> \note see mp_send_z
24526! **************************************************************************************************
24527 SUBROUTINE mp_send_zm3(msg, dest, tag, comm)
24528 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
24529 INTEGER, INTENT(IN) :: dest, tag
24530 CLASS(mp_comm_type), INTENT(IN) :: comm
24531
24532 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
24533
24534 INTEGER :: handle
24535#if defined(__parallel)
24536 INTEGER :: ierr, msglen
24537#endif
24538
24539 CALL mp_timeset(routinen, handle)
24540
24541#if defined(__parallel)
24542 msglen = SIZE(msg)
24543 CALL mpi_send(msg, msglen, mpi_double_complex, dest, tag, comm%handle, ierr)
24544 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
24545 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_8_size))
24546#else
24547 mark_used(msg)
24548 mark_used(dest)
24549 mark_used(tag)
24550 mark_used(comm)
24551 ! only defined in parallel
24552 cpabort("not in parallel mode")
24553#endif
24554 CALL mp_timestop(handle)
24555 END SUBROUTINE mp_send_zm3
24556
24557! **************************************************************************************************
24558!> \brief Receive one datum from another process
24559!> \param[in,out] msg Place received data into this variable
24560!> \param[in,out] source Process to receive from
24561!> \param[in,out] tag Transfer identifier
24562!> \param[in] comm Message passing environment identifier
24563!> \par MPI mapping
24564!> mpi_send
24565! **************************************************************************************************
24566 SUBROUTINE mp_recv_z (msg, source, tag, comm)
24567 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24568 INTEGER, INTENT(INOUT) :: source, tag
24569 CLASS(mp_comm_type), INTENT(IN) :: comm
24570
24571 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_z'
24572
24573 INTEGER :: handle
24574#if defined(__parallel)
24575 INTEGER :: ierr, msglen
24576 mpi_status_type :: status
24577#endif
24578
24579 CALL mp_timeset(routinen, handle)
24580
24581#if defined(__parallel)
24582 msglen = 1
24583 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24584 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24585 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24586 ELSE
24587 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24588 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24589 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24590 source = status mpi_status_extract(mpi_source)
24591 tag = status mpi_status_extract(mpi_tag)
24592 END IF
24593#else
24594 mark_used(msg)
24595 mark_used(source)
24596 mark_used(tag)
24597 mark_used(comm)
24598 ! only defined in parallel
24599 cpabort("not in parallel mode")
24600#endif
24601 CALL mp_timestop(handle)
24602 END SUBROUTINE mp_recv_z
24603
24604! **************************************************************************************************
24605!> \brief Receive rank-1 data from another process
24606!> \param[in,out] msg Place received data into this rank-1 array
24607!> \param source ...
24608!> \param tag ...
24609!> \param comm ...
24610!> \note see mp_recv_z
24611! **************************************************************************************************
24612 SUBROUTINE mp_recv_zv(msg, source, tag, comm)
24613 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24614 INTEGER, INTENT(INOUT) :: source, tag
24615 CLASS(mp_comm_type), INTENT(IN) :: comm
24616
24617 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zv'
24618
24619 INTEGER :: handle
24620#if defined(__parallel)
24621 INTEGER :: ierr, msglen
24622 mpi_status_type :: status
24623#endif
24624
24625 CALL mp_timeset(routinen, handle)
24626
24627#if defined(__parallel)
24628 msglen = SIZE(msg)
24629 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24630 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24631 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24632 ELSE
24633 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24634 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24635 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24636 source = status mpi_status_extract(mpi_source)
24637 tag = status mpi_status_extract(mpi_tag)
24638 END IF
24639#else
24640 mark_used(msg)
24641 mark_used(source)
24642 mark_used(tag)
24643 mark_used(comm)
24644 ! only defined in parallel
24645 cpabort("not in parallel mode")
24646#endif
24647 CALL mp_timestop(handle)
24648 END SUBROUTINE mp_recv_zv
24649
24650! **************************************************************************************************
24651!> \brief Receive rank-2 data from another process
24652!> \param[in,out] msg Place received data into this rank-2 array
24653!> \param source ...
24654!> \param tag ...
24655!> \param comm ...
24656!> \note see mp_recv_z
24657! **************************************************************************************************
24658 SUBROUTINE mp_recv_zm2(msg, source, tag, comm)
24659 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24660 INTEGER, INTENT(INOUT) :: source, tag
24661 CLASS(mp_comm_type), INTENT(IN) :: comm
24662
24663 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zm2'
24664
24665 INTEGER :: handle
24666#if defined(__parallel)
24667 INTEGER :: ierr, msglen
24668 mpi_status_type :: status
24669#endif
24670
24671 CALL mp_timeset(routinen, handle)
24672
24673#if defined(__parallel)
24674 msglen = SIZE(msg)
24675 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24676 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24677 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24678 ELSE
24679 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24680 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24681 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24682 source = status mpi_status_extract(mpi_source)
24683 tag = status mpi_status_extract(mpi_tag)
24684 END IF
24685#else
24686 mark_used(msg)
24687 mark_used(source)
24688 mark_used(tag)
24689 mark_used(comm)
24690 ! only defined in parallel
24691 cpabort("not in parallel mode")
24692#endif
24693 CALL mp_timestop(handle)
24694 END SUBROUTINE mp_recv_zm2
24695
24696! **************************************************************************************************
24697!> \brief Receive rank-3 data from another process
24698!> \param[in,out] msg Place received data into this rank-3 array
24699!> \param source ...
24700!> \param tag ...
24701!> \param comm ...
24702!> \note see mp_recv_z
24703! **************************************************************************************************
24704 SUBROUTINE mp_recv_zm3(msg, source, tag, comm)
24705 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
24706 INTEGER, INTENT(INOUT) :: source, tag
24707 CLASS(mp_comm_type), INTENT(IN) :: comm
24708
24709 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_zm3'
24710
24711 INTEGER :: handle
24712#if defined(__parallel)
24713 INTEGER :: ierr, msglen
24714 mpi_status_type :: status
24715#endif
24716
24717 CALL mp_timeset(routinen, handle)
24718
24719#if defined(__parallel)
24720 msglen = SIZE(msg)
24721 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
24722 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
24723 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24724 ELSE
24725 CALL mpi_recv(msg, msglen, mpi_double_complex, source, tag, comm%handle, status, ierr)
24726 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
24727 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_8_size))
24728 source = status mpi_status_extract(mpi_source)
24729 tag = status mpi_status_extract(mpi_tag)
24730 END IF
24731#else
24732 mark_used(msg)
24733 mark_used(source)
24734 mark_used(tag)
24735 mark_used(comm)
24736 ! only defined in parallel
24737 cpabort("not in parallel mode")
24738#endif
24739 CALL mp_timestop(handle)
24740 END SUBROUTINE mp_recv_zm3
24741
24742! **************************************************************************************************
24743!> \brief Broadcasts a datum to all processes.
24744!> \param[in] msg Datum to broadcast
24745!> \param[in] source Processes which broadcasts
24746!> \param[in] comm Message passing environment identifier
24747!> \par MPI mapping
24748!> mpi_bcast
24749! **************************************************************************************************
24750 SUBROUTINE mp_bcast_z (msg, source, comm)
24751 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24752 INTEGER, INTENT(IN) :: source
24753 CLASS(mp_comm_type), INTENT(IN) :: comm
24754
24755 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z'
24756
24757 INTEGER :: handle
24758#if defined(__parallel)
24759 INTEGER :: ierr, msglen
24760#endif
24761
24762 CALL mp_timeset(routinen, handle)
24763
24764#if defined(__parallel)
24765 msglen = 1
24766 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24767 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24768 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24769#else
24770 mark_used(msg)
24771 mark_used(source)
24772 mark_used(comm)
24773#endif
24774 CALL mp_timestop(handle)
24775 END SUBROUTINE mp_bcast_z
24776
24777! **************************************************************************************************
24778!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
24779!> \param[in] msg Datum to broadcast
24780!> \param[in] comm Message passing environment identifier
24781!> \par MPI mapping
24782!> mpi_bcast
24783! **************************************************************************************************
24784 SUBROUTINE mp_bcast_z_src(msg, comm)
24785 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24786 CLASS(mp_comm_type), INTENT(IN) :: comm
24787
24788 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z_src'
24789
24790 INTEGER :: handle
24791#if defined(__parallel)
24792 INTEGER :: ierr, msglen
24793#endif
24794
24795 CALL mp_timeset(routinen, handle)
24796
24797#if defined(__parallel)
24798 msglen = 1
24799 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24800 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24801 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24802#else
24803 mark_used(msg)
24804 mark_used(comm)
24805#endif
24806 CALL mp_timestop(handle)
24807 END SUBROUTINE mp_bcast_z_src
24808
24809! **************************************************************************************************
24810!> \brief Broadcasts a datum to all processes.
24811!> \param[in] msg Datum to broadcast
24812!> \param[in] source Processes which broadcasts
24813!> \param[in] comm Message passing environment identifier
24814!> \par MPI mapping
24815!> mpi_bcast
24816! **************************************************************************************************
24817 SUBROUTINE mp_ibcast_z (msg, source, comm, request)
24818 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
24819 INTEGER, INTENT(IN) :: source
24820 CLASS(mp_comm_type), INTENT(IN) :: comm
24821 TYPE(mp_request_type), INTENT(OUT) :: request
24822
24823 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_z'
24824
24825 INTEGER :: handle
24826#if defined(__parallel)
24827 INTEGER :: ierr, msglen
24828#endif
24829
24830 CALL mp_timeset(routinen, handle)
24831
24832#if defined(__parallel)
24833 msglen = 1
24834 CALL mpi_ibcast(msg, msglen, mpi_double_complex, source, comm%handle, request%handle, ierr)
24835 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
24836 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_8_size))
24837#else
24838 mark_used(msg)
24839 mark_used(source)
24840 mark_used(comm)
24841 request = mp_request_null
24842#endif
24843 CALL mp_timestop(handle)
24844 END SUBROUTINE mp_ibcast_z
24845
24846! **************************************************************************************************
24847!> \brief Broadcasts rank-1 data to all processes
24848!> \param[in] msg Data to broadcast
24849!> \param source ...
24850!> \param comm ...
24851!> \note see mp_bcast_z1
24852! **************************************************************************************************
24853 SUBROUTINE mp_bcast_zv(msg, source, comm)
24854 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24855 INTEGER, INTENT(IN) :: source
24856 CLASS(mp_comm_type), INTENT(IN) :: comm
24857
24858 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zv'
24859
24860 INTEGER :: handle
24861#if defined(__parallel)
24862 INTEGER :: ierr, msglen
24863#endif
24864
24865 CALL mp_timeset(routinen, handle)
24866
24867#if defined(__parallel)
24868 msglen = SIZE(msg)
24869 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24870 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24871 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24872#else
24873 mark_used(msg)
24874 mark_used(source)
24875 mark_used(comm)
24876#endif
24877 CALL mp_timestop(handle)
24878 END SUBROUTINE mp_bcast_zv
24879
24880! **************************************************************************************************
24881!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
24882!> \param[in] msg Data to broadcast
24883!> \param comm ...
24884!> \note see mp_bcast_z1
24885! **************************************************************************************************
24886 SUBROUTINE mp_bcast_zv_src(msg, comm)
24887 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
24888 CLASS(mp_comm_type), INTENT(IN) :: comm
24889
24890 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zv_src'
24891
24892 INTEGER :: handle
24893#if defined(__parallel)
24894 INTEGER :: ierr, msglen
24895#endif
24896
24897 CALL mp_timeset(routinen, handle)
24898
24899#if defined(__parallel)
24900 msglen = SIZE(msg)
24901 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
24902 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24903 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24904#else
24905 mark_used(msg)
24906 mark_used(comm)
24907#endif
24908 CALL mp_timestop(handle)
24909 END SUBROUTINE mp_bcast_zv_src
24910
24911! **************************************************************************************************
24912!> \brief Broadcasts rank-1 data to all processes
24913!> \param[in] msg Data to broadcast
24914!> \param source ...
24915!> \param comm ...
24916!> \note see mp_bcast_z1
24917! **************************************************************************************************
24918 SUBROUTINE mp_ibcast_zv(msg, source, comm, request)
24919 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
24920 INTEGER, INTENT(IN) :: source
24921 CLASS(mp_comm_type), INTENT(IN) :: comm
24922 TYPE(mp_request_type) :: request
24923
24924 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_zv'
24925
24926 INTEGER :: handle
24927#if defined(__parallel)
24928 INTEGER :: ierr, msglen
24929#endif
24930
24931 CALL mp_timeset(routinen, handle)
24932
24933#if defined(__parallel)
24934#if !defined(__GNUC__) || __GNUC__ >= 9
24935 cpassert(is_contiguous(msg))
24936#endif
24937 msglen = SIZE(msg)
24938 CALL mpi_ibcast(msg, msglen, mpi_double_complex, source, comm%handle, request%handle, ierr)
24939 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
24940 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_8_size))
24941#else
24942 mark_used(msg)
24943 mark_used(source)
24944 mark_used(comm)
24945 request = mp_request_null
24946#endif
24947 CALL mp_timestop(handle)
24948 END SUBROUTINE mp_ibcast_zv
24949
24950! **************************************************************************************************
24951!> \brief Broadcasts rank-2 data to all processes
24952!> \param[in] msg Data to broadcast
24953!> \param source ...
24954!> \param comm ...
24955!> \note see mp_bcast_z1
24956! **************************************************************************************************
24957 SUBROUTINE mp_bcast_zm(msg, source, comm)
24958 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24959 INTEGER, INTENT(IN) :: source
24960 CLASS(mp_comm_type), INTENT(IN) :: comm
24961
24962 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zm'
24963
24964 INTEGER :: handle
24965#if defined(__parallel)
24966 INTEGER :: ierr, msglen
24967#endif
24968
24969 CALL mp_timeset(routinen, handle)
24970
24971#if defined(__parallel)
24972 msglen = SIZE(msg)
24973 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
24974 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
24975 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
24976#else
24977 mark_used(msg)
24978 mark_used(source)
24979 mark_used(comm)
24980#endif
24981 CALL mp_timestop(handle)
24982 END SUBROUTINE mp_bcast_zm
24983
24984! **************************************************************************************************
24985!> \brief Broadcasts rank-2 data to all processes
24986!> \param[in] msg Data to broadcast
24987!> \param source ...
24988!> \param comm ...
24989!> \note see mp_bcast_z1
24990! **************************************************************************************************
24991 SUBROUTINE mp_bcast_zm_src(msg, comm)
24992 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
24993 CLASS(mp_comm_type), INTENT(IN) :: comm
24994
24995 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_zm_src'
24996
24997 INTEGER :: handle
24998#if defined(__parallel)
24999 INTEGER :: ierr, msglen
25000#endif
25001
25002 CALL mp_timeset(routinen, handle)
25003
25004#if defined(__parallel)
25005 msglen = SIZE(msg)
25006 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25007 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25008 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25009#else
25010 mark_used(msg)
25011 mark_used(comm)
25012#endif
25013 CALL mp_timestop(handle)
25014 END SUBROUTINE mp_bcast_zm_src
25015
25016! **************************************************************************************************
25017!> \brief Broadcasts rank-3 data to all processes
25018!> \param[in] msg Data to broadcast
25019!> \param source ...
25020!> \param comm ...
25021!> \note see mp_bcast_z1
25022! **************************************************************************************************
25023 SUBROUTINE mp_bcast_z3(msg, source, comm)
25024 COMPLEX(kind=real_8), CONTIGUOUS :: msg(:, :, :)
25025 INTEGER, INTENT(IN) :: source
25026 CLASS(mp_comm_type), INTENT(IN) :: comm
25027
25028 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z3'
25029
25030 INTEGER :: handle
25031#if defined(__parallel)
25032 INTEGER :: ierr, msglen
25033#endif
25034
25035 CALL mp_timeset(routinen, handle)
25036
25037#if defined(__parallel)
25038 msglen = SIZE(msg)
25039 CALL mpi_bcast(msg, msglen, mpi_double_complex, source, comm%handle, ierr)
25040 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25041 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25042#else
25043 mark_used(msg)
25044 mark_used(source)
25045 mark_used(comm)
25046#endif
25047 CALL mp_timestop(handle)
25048 END SUBROUTINE mp_bcast_z3
25049
25050! **************************************************************************************************
25051!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
25052!> \param[in] msg Data to broadcast
25053!> \param source ...
25054!> \param comm ...
25055!> \note see mp_bcast_z1
25056! **************************************************************************************************
25057 SUBROUTINE mp_bcast_z3_src(msg, comm)
25058 COMPLEX(kind=real_8), CONTIGUOUS :: msg(:, :, :)
25059 CLASS(mp_comm_type), INTENT(IN) :: comm
25060
25061 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_z3_src'
25062
25063 INTEGER :: handle
25064#if defined(__parallel)
25065 INTEGER :: ierr, msglen
25066#endif
25067
25068 CALL mp_timeset(routinen, handle)
25069
25070#if defined(__parallel)
25071 msglen = SIZE(msg)
25072 CALL mpi_bcast(msg, msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25073 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
25074 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_8_size))
25075#else
25076 mark_used(msg)
25077 mark_used(comm)
25078#endif
25079 CALL mp_timestop(handle)
25080 END SUBROUTINE mp_bcast_z3_src
25081
25082! **************************************************************************************************
25083!> \brief Sums a datum from all processes with result left on all processes.
25084!> \param[in,out] msg Datum to sum (input) and result (output)
25085!> \param[in] comm Message passing environment identifier
25086!> \par MPI mapping
25087!> mpi_allreduce
25088! **************************************************************************************************
25089 SUBROUTINE mp_sum_z (msg, comm)
25090 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25091 CLASS(mp_comm_type), INTENT(IN) :: comm
25092
25093 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_z'
25094
25095 INTEGER :: handle
25096#if defined(__parallel)
25097 INTEGER :: ierr, msglen
25098#endif
25099
25100 CALL mp_timeset(routinen, handle)
25101
25102#if defined(__parallel)
25103 msglen = 1
25104 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25105 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25106 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25107#else
25108 mark_used(msg)
25109 mark_used(comm)
25110#endif
25111 CALL mp_timestop(handle)
25112 END SUBROUTINE mp_sum_z
25113
25114! **************************************************************************************************
25115!> \brief Element-wise sum of a rank-1 array on all processes.
25116!> \param[in,out] msg Vector to sum and result
25117!> \param comm ...
25118!> \note see mp_sum_z
25119! **************************************************************************************************
25120 SUBROUTINE mp_sum_zv(msg, comm)
25121 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25122 CLASS(mp_comm_type), INTENT(IN) :: comm
25123
25124 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zv'
25125
25126 INTEGER :: handle
25127#if defined(__parallel)
25128 INTEGER :: ierr, msglen
25129#endif
25130
25131 CALL mp_timeset(routinen, handle)
25132
25133#if defined(__parallel)
25134 msglen = SIZE(msg)
25135 IF (msglen > 0) THEN
25136 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25137 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25138 END IF
25139 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25140#else
25141 mark_used(msg)
25142 mark_used(comm)
25143#endif
25144 CALL mp_timestop(handle)
25145 END SUBROUTINE mp_sum_zv
25146
25147! **************************************************************************************************
25148!> \brief Element-wise sum of a rank-1 array on all processes.
25149!> \param[in,out] msg Vector to sum and result
25150!> \param comm ...
25151!> \note see mp_sum_z
25152! **************************************************************************************************
25153 SUBROUTINE mp_isum_zv(msg, comm, request)
25154 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25155 CLASS(mp_comm_type), INTENT(IN) :: comm
25156 TYPE(mp_request_type), INTENT(OUT) :: request
25157
25158 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_zv'
25159
25160 INTEGER :: handle
25161#if defined(__parallel)
25162 INTEGER :: ierr, msglen
25163#endif
25164
25165 CALL mp_timeset(routinen, handle)
25166
25167#if defined(__parallel)
25168#if !defined(__GNUC__) || __GNUC__ >= 9
25169 cpassert(is_contiguous(msg))
25170#endif
25171 msglen = SIZE(msg)
25172 IF (msglen > 0) THEN
25173 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, request%handle, ierr)
25174 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
25175 ELSE
25176 request = mp_request_null
25177 END IF
25178 CALL add_perf(perf_id=23, count=1, msg_size=msglen*(2*real_8_size))
25179#else
25180 mark_used(msg)
25181 mark_used(comm)
25182 request = mp_request_null
25183#endif
25184 CALL mp_timestop(handle)
25185 END SUBROUTINE mp_isum_zv
25186
25187! **************************************************************************************************
25188!> \brief Element-wise sum of a rank-2 array on all processes.
25189!> \param[in] msg Matrix to sum and result
25190!> \param comm ...
25191!> \note see mp_sum_z
25192! **************************************************************************************************
25193 SUBROUTINE mp_sum_zm(msg, comm)
25194 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25195 CLASS(mp_comm_type), INTENT(IN) :: comm
25196
25197 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm'
25198
25199 INTEGER :: handle
25200#if defined(__parallel)
25201 INTEGER, PARAMETER :: max_msg = 2**25
25202 INTEGER :: ierr, m1, msglen, step, msglensum
25203#endif
25204
25205 CALL mp_timeset(routinen, handle)
25206
25207#if defined(__parallel)
25208 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
25209 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
25210 msglensum = 0
25211 DO m1 = lbound(msg, 2), ubound(msg, 2), step
25212 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
25213 msglensum = msglensum + msglen
25214 IF (msglen > 0) THEN
25215 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25216 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25217 END IF
25218 END DO
25219 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_8_size))
25220#else
25221 mark_used(msg)
25222 mark_used(comm)
25223#endif
25224 CALL mp_timestop(handle)
25225 END SUBROUTINE mp_sum_zm
25226
25227! **************************************************************************************************
25228!> \brief Element-wise sum of a rank-3 array on all processes.
25229!> \param[in] msg Array to sum and result
25230!> \param comm ...
25231!> \note see mp_sum_z
25232! **************************************************************************************************
25233 SUBROUTINE mp_sum_zm3(msg, comm)
25234 COMPLEX(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
25235 CLASS(mp_comm_type), INTENT(IN) :: comm
25236
25237 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm3'
25238
25239 INTEGER :: handle
25240#if defined(__parallel)
25241 INTEGER :: ierr, msglen
25242#endif
25243
25244 CALL mp_timeset(routinen, handle)
25245
25246#if defined(__parallel)
25247 msglen = SIZE(msg)
25248 IF (msglen > 0) THEN
25249 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25250 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25251 END IF
25252 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25253#else
25254 mark_used(msg)
25255 mark_used(comm)
25256#endif
25257 CALL mp_timestop(handle)
25258 END SUBROUTINE mp_sum_zm3
25259
25260! **************************************************************************************************
25261!> \brief Element-wise sum of a rank-4 array on all processes.
25262!> \param[in] msg Array to sum and result
25263!> \param comm ...
25264!> \note see mp_sum_z
25265! **************************************************************************************************
25266 SUBROUTINE mp_sum_zm4(msg, comm)
25267 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
25268 CLASS(mp_comm_type), INTENT(IN) :: comm
25269
25270 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_zm4'
25271
25272 INTEGER :: handle
25273#if defined(__parallel)
25274 INTEGER :: ierr, msglen
25275#endif
25276
25277 CALL mp_timeset(routinen, handle)
25278
25279#if defined(__parallel)
25280 msglen = SIZE(msg)
25281 IF (msglen > 0) THEN
25282 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25283 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25284 END IF
25285 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25286#else
25287 mark_used(msg)
25288 mark_used(comm)
25289#endif
25290 CALL mp_timestop(handle)
25291 END SUBROUTINE mp_sum_zm4
25292
25293! **************************************************************************************************
25294!> \brief Element-wise sum of data from all processes with result left only on
25295!> one.
25296!> \param[in,out] msg Vector to sum (input) and (only on process root)
25297!> result (output)
25298!> \param root ...
25299!> \param[in] comm Message passing environment identifier
25300!> \par MPI mapping
25301!> mpi_reduce
25302! **************************************************************************************************
25303 SUBROUTINE mp_sum_root_zv(msg, root, comm)
25304 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25305 INTEGER, INTENT(IN) :: root
25306 CLASS(mp_comm_type), INTENT(IN) :: comm
25307
25308 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_zv'
25309
25310 INTEGER :: handle
25311#if defined(__parallel)
25312 INTEGER :: ierr, m1, msglen, taskid
25313 COMPLEX(kind=real_8), ALLOCATABLE :: res(:)
25314#endif
25315
25316 CALL mp_timeset(routinen, handle)
25317
25318#if defined(__parallel)
25319 msglen = SIZE(msg)
25320 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25321 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25322 IF (msglen > 0) THEN
25323 m1 = SIZE(msg, 1)
25324 ALLOCATE (res(m1))
25325 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_sum, &
25326 root, comm%handle, ierr)
25327 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25328 IF (taskid == root) THEN
25329 msg = res
25330 END IF
25331 DEALLOCATE (res)
25332 END IF
25333 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25334#else
25335 mark_used(msg)
25336 mark_used(root)
25337 mark_used(comm)
25338#endif
25339 CALL mp_timestop(handle)
25340 END SUBROUTINE mp_sum_root_zv
25341
25342! **************************************************************************************************
25343!> \brief Element-wise sum of data from all processes with result left only on
25344!> one.
25345!> \param[in,out] msg Matrix to sum (input) and (only on process root)
25346!> result (output)
25347!> \param root ...
25348!> \param comm ...
25349!> \note see mp_sum_root_zv
25350! **************************************************************************************************
25351 SUBROUTINE mp_sum_root_zm(msg, root, comm)
25352 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25353 INTEGER, INTENT(IN) :: root
25354 CLASS(mp_comm_type), INTENT(IN) :: comm
25355
25356 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
25357
25358 INTEGER :: handle
25359#if defined(__parallel)
25360 INTEGER :: ierr, m1, m2, msglen, taskid
25361 COMPLEX(kind=real_8), ALLOCATABLE :: res(:, :)
25362#endif
25363
25364 CALL mp_timeset(routinen, handle)
25365
25366#if defined(__parallel)
25367 msglen = SIZE(msg)
25368 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25369 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25370 IF (msglen > 0) THEN
25371 m1 = SIZE(msg, 1)
25372 m2 = SIZE(msg, 2)
25373 ALLOCATE (res(m1, m2))
25374 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_sum, root, comm%handle, ierr)
25375 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25376 IF (taskid == root) THEN
25377 msg = res
25378 END IF
25379 DEALLOCATE (res)
25380 END IF
25381 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25382#else
25383 mark_used(root)
25384 mark_used(msg)
25385 mark_used(comm)
25386#endif
25387 CALL mp_timestop(handle)
25388 END SUBROUTINE mp_sum_root_zm
25389
25390! **************************************************************************************************
25391!> \brief Partial sum of data from all processes with result on each process.
25392!> \param[in] msg Matrix to sum (input)
25393!> \param[out] res Matrix containing result (output)
25394!> \param[in] comm Message passing environment identifier
25395! **************************************************************************************************
25396 SUBROUTINE mp_sum_partial_zm(msg, res, comm)
25397 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
25398 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: res(:, :)
25399 CLASS(mp_comm_type), INTENT(IN) :: comm
25400
25401 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_zm'
25402
25403 INTEGER :: handle
25404#if defined(__parallel)
25405 INTEGER :: ierr, msglen, taskid
25406#endif
25407
25408 CALL mp_timeset(routinen, handle)
25409
25410#if defined(__parallel)
25411 msglen = SIZE(msg)
25412 CALL mpi_comm_rank(comm%handle, taskid, ierr)
25413 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
25414 IF (msglen > 0) THEN
25415 CALL mpi_scan(msg, res, msglen, mpi_double_complex, mpi_sum, comm%handle, ierr)
25416 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
25417 END IF
25418 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25419 ! perf_id is same as for other summation routines
25420#else
25421 res = msg
25422 mark_used(comm)
25423#endif
25424 CALL mp_timestop(handle)
25425 END SUBROUTINE mp_sum_partial_zm
25426
25427! **************************************************************************************************
25428!> \brief Finds the maximum of a datum with the result left on all processes.
25429!> \param[in,out] msg Find maximum among these data (input) and
25430!> maximum (output)
25431!> \param[in] comm Message passing environment identifier
25432!> \par MPI mapping
25433!> mpi_allreduce
25434! **************************************************************************************************
25435 SUBROUTINE mp_max_z (msg, comm)
25436 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25437 CLASS(mp_comm_type), INTENT(IN) :: comm
25438
25439 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_z'
25440
25441 INTEGER :: handle
25442#if defined(__parallel)
25443 INTEGER :: ierr, msglen
25444#endif
25445
25446 CALL mp_timeset(routinen, handle)
25447
25448#if defined(__parallel)
25449 msglen = 1
25450 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25451 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
25457 CALL mp_timestop(handle)
25458 END SUBROUTINE mp_max_z
25459
25460! **************************************************************************************************
25461!> \brief Finds the maximum of a datum with the result left on all processes.
25462!> \param[in,out] msg Find maximum among these data (input) and
25463!> maximum (output)
25464!> \param[in] comm Message passing environment identifier
25465!> \par MPI mapping
25466!> mpi_allreduce
25467! **************************************************************************************************
25468 SUBROUTINE mp_max_root_z (msg, root, comm)
25469 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25470 INTEGER, INTENT(IN) :: root
25471 CLASS(mp_comm_type), INTENT(IN) :: comm
25472
25473 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_z'
25474
25475 INTEGER :: handle
25476#if defined(__parallel)
25477 INTEGER :: ierr, msglen
25478 COMPLEX(kind=real_8) :: res
25479#endif
25480
25481 CALL mp_timeset(routinen, handle)
25482
25483#if defined(__parallel)
25484 msglen = 1
25485 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_max, root, comm%handle, ierr)
25486 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
25487 IF (root == comm%mepos) msg = res
25488 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25489#else
25490 mark_used(msg)
25491 mark_used(comm)
25492 mark_used(root)
25493#endif
25494 CALL mp_timestop(handle)
25495 END SUBROUTINE mp_max_root_z
25496
25497! **************************************************************************************************
25498!> \brief Finds the element-wise maximum of a vector with the result left on
25499!> all processes.
25500!> \param[in,out] msg Find maximum among these data (input) and
25501!> maximum (output)
25502!> \param comm ...
25503!> \note see mp_max_z
25504! **************************************************************************************************
25505 SUBROUTINE mp_max_zv(msg, comm)
25506 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
25507 CLASS(mp_comm_type), INTENT(IN) :: comm
25508
25509 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_zv'
25510
25511 INTEGER :: handle
25512#if defined(__parallel)
25513 INTEGER :: ierr, msglen
25514#endif
25515
25516 CALL mp_timeset(routinen, handle)
25517
25518#if defined(__parallel)
25519 msglen = SIZE(msg)
25520 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_max, comm%handle, ierr)
25521 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
25527 CALL mp_timestop(handle)
25528 END SUBROUTINE mp_max_zv
25529
25530! **************************************************************************************************
25531!> \brief Finds the element-wise maximum of a vector with the result left on
25532!> all processes.
25533!> \param[in,out] msg Find maximum among these data (input) and
25534!> maximum (output)
25535!> \param comm ...
25536!> \note see mp_max_z
25537! **************************************************************************************************
25538 SUBROUTINE mp_max_root_zm(msg, root, comm)
25539 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
25540 INTEGER :: root
25541 CLASS(mp_comm_type), INTENT(IN) :: comm
25542
25543 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_zm'
25544
25545 INTEGER :: handle
25546#if defined(__parallel)
25547 INTEGER :: ierr, msglen
25548 COMPLEX(kind=real_8) :: res(size(msg, 1), size(msg, 2))
25549#endif
25550
25551 CALL mp_timeset(routinen, handle)
25552
25553#if defined(__parallel)
25554 msglen = SIZE(msg)
25555 CALL mpi_reduce(msg, res, msglen, mpi_double_complex, mpi_max, root, comm%handle, ierr)
25556 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25557 IF (root == comm%mepos) msg = res
25558 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25559#else
25560 mark_used(msg)
25561 mark_used(comm)
25562 mark_used(root)
25563#endif
25564 CALL mp_timestop(handle)
25565 END SUBROUTINE mp_max_root_zm
25566
25567! **************************************************************************************************
25568!> \brief Finds the minimum of a datum with the result left on all processes.
25569!> \param[in,out] msg Find minimum among these data (input) and
25570!> maximum (output)
25571!> \param[in] comm Message passing environment identifier
25572!> \par MPI mapping
25573!> mpi_allreduce
25574! **************************************************************************************************
25575 SUBROUTINE mp_min_z (msg, comm)
25576 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25577 CLASS(mp_comm_type), INTENT(IN) :: comm
25578
25579 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_z'
25580
25581 INTEGER :: handle
25582#if defined(__parallel)
25583 INTEGER :: ierr, msglen
25584#endif
25585
25586 CALL mp_timeset(routinen, handle)
25587
25588#if defined(__parallel)
25589 msglen = 1
25590 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
25591 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25592 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25593#else
25594 mark_used(msg)
25595 mark_used(comm)
25596#endif
25597 CALL mp_timestop(handle)
25598 END SUBROUTINE mp_min_z
25599
25600! **************************************************************************************************
25601!> \brief Finds the element-wise minimum of vector with the result left on
25602!> all processes.
25603!> \param[in,out] msg Find minimum among these data (input) and
25604!> maximum (output)
25605!> \param comm ...
25606!> \par MPI mapping
25607!> mpi_allreduce
25608!> \note see mp_min_z
25609! **************************************************************************************************
25610 SUBROUTINE mp_min_zv(msg, comm)
25611 COMPLEX(kind=real_8), INTENT(INOUT), CONTIGUOUS :: msg(:)
25612 CLASS(mp_comm_type), INTENT(IN) :: comm
25613
25614 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_zv'
25615
25616 INTEGER :: handle
25617#if defined(__parallel)
25618 INTEGER :: ierr, msglen
25619#endif
25620
25621 CALL mp_timeset(routinen, handle)
25622
25623#if defined(__parallel)
25624 msglen = SIZE(msg)
25625 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_min, comm%handle, ierr)
25626 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25627 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25628#else
25629 mark_used(msg)
25630 mark_used(comm)
25631#endif
25632 CALL mp_timestop(handle)
25633 END SUBROUTINE mp_min_zv
25634
25635! **************************************************************************************************
25636!> \brief Multiplies a set of numbers scattered across a number of processes,
25637!> then replicates the result.
25638!> \param[in,out] msg a number to multiply (input) and result (output)
25639!> \param[in] comm message passing environment identifier
25640!> \par MPI mapping
25641!> mpi_allreduce
25642! **************************************************************************************************
25643 SUBROUTINE mp_prod_z (msg, comm)
25644 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25645 CLASS(mp_comm_type), INTENT(IN) :: comm
25646
25647 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_z'
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 = 1
25658 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_double_complex, mpi_prod, comm%handle, ierr)
25659 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
25660 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_8_size))
25661#else
25662 mark_used(msg)
25663 mark_used(comm)
25664#endif
25665 CALL mp_timestop(handle)
25666 END SUBROUTINE mp_prod_z
25667
25668! **************************************************************************************************
25669!> \brief Scatters data from one processes to all others
25670!> \param[in] msg_scatter Data to scatter (for root process)
25671!> \param[out] msg Received data
25672!> \param[in] root Process which scatters data
25673!> \param[in] comm Message passing environment identifier
25674!> \par MPI mapping
25675!> mpi_scatter
25676! **************************************************************************************************
25677 SUBROUTINE mp_scatter_zv(msg_scatter, msg, root, comm)
25678 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
25679 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg(:)
25680 INTEGER, INTENT(IN) :: root
25681 CLASS(mp_comm_type), INTENT(IN) :: comm
25682
25683 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_zv'
25684
25685 INTEGER :: handle
25686#if defined(__parallel)
25687 INTEGER :: ierr, msglen
25688#endif
25689
25690 CALL mp_timeset(routinen, handle)
25691
25692#if defined(__parallel)
25693 msglen = SIZE(msg)
25694 CALL mpi_scatter(msg_scatter, msglen, mpi_double_complex, msg, &
25695 msglen, mpi_double_complex, root, comm%handle, ierr)
25696 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
25697 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25698#else
25699 mark_used(root)
25700 mark_used(comm)
25701 msg = msg_scatter
25702#endif
25703 CALL mp_timestop(handle)
25704 END SUBROUTINE mp_scatter_zv
25705
25706! **************************************************************************************************
25707!> \brief Scatters data from one processes to all others
25708!> \param[in] msg_scatter Data to scatter (for root process)
25709!> \param[in] root Process which scatters data
25710!> \param[in] comm Message passing environment identifier
25711!> \par MPI mapping
25712!> mpi_scatter
25713! **************************************************************************************************
25714 SUBROUTINE mp_iscatter_z (msg_scatter, msg, root, comm, request)
25715 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:)
25716 COMPLEX(kind=real_8), INTENT(INOUT) :: msg
25717 INTEGER, INTENT(IN) :: root
25718 CLASS(mp_comm_type), INTENT(IN) :: comm
25719 TYPE(mp_request_type), INTENT(OUT) :: request
25720
25721 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_z'
25722
25723 INTEGER :: handle
25724#if defined(__parallel)
25725 INTEGER :: ierr, msglen
25726#endif
25727
25728 CALL mp_timeset(routinen, handle)
25729
25730#if defined(__parallel)
25731#if !defined(__GNUC__) || __GNUC__ >= 9
25732 cpassert(is_contiguous(msg_scatter))
25733#endif
25734 msglen = 1
25735 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_complex, msg, &
25736 msglen, mpi_double_complex, root, comm%handle, request%handle, ierr)
25737 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
25738 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25739#else
25740 mark_used(root)
25741 mark_used(comm)
25742 msg = msg_scatter(1)
25743 request = mp_request_null
25744#endif
25745 CALL mp_timestop(handle)
25746 END SUBROUTINE mp_iscatter_z
25747
25748! **************************************************************************************************
25749!> \brief Scatters data from one processes to all others
25750!> \param[in] msg_scatter Data to scatter (for root process)
25751!> \param[in] root Process which scatters data
25752!> \param[in] comm Message passing environment identifier
25753!> \par MPI mapping
25754!> mpi_scatter
25755! **************************************************************************************************
25756 SUBROUTINE mp_iscatter_zv2(msg_scatter, msg, root, comm, request)
25757 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:, :)
25758 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25759 INTEGER, INTENT(IN) :: root
25760 CLASS(mp_comm_type), INTENT(IN) :: comm
25761 TYPE(mp_request_type), INTENT(OUT) :: request
25762
25763 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_zv2'
25764
25765 INTEGER :: handle
25766#if defined(__parallel)
25767 INTEGER :: ierr, msglen
25768#endif
25769
25770 CALL mp_timeset(routinen, handle)
25771
25772#if defined(__parallel)
25773#if !defined(__GNUC__) || __GNUC__ >= 9
25774 cpassert(is_contiguous(msg_scatter))
25775#endif
25776 msglen = SIZE(msg)
25777 CALL mpi_iscatter(msg_scatter, msglen, mpi_double_complex, msg, &
25778 msglen, mpi_double_complex, root, comm%handle, request%handle, ierr)
25779 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
25780 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25781#else
25782 mark_used(root)
25783 mark_used(comm)
25784 msg(:) = msg_scatter(:, 1)
25785 request = mp_request_null
25786#endif
25787 CALL mp_timestop(handle)
25788 END SUBROUTINE mp_iscatter_zv2
25789
25790! **************************************************************************************************
25791!> \brief Scatters data from one processes to all others
25792!> \param[in] msg_scatter Data to scatter (for root process)
25793!> \param[in] root Process which scatters data
25794!> \param[in] comm Message passing environment identifier
25795!> \par MPI mapping
25796!> mpi_scatter
25797! **************************************************************************************************
25798 SUBROUTINE mp_iscatterv_zv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
25799 COMPLEX(kind=real_8), INTENT(IN) :: msg_scatter(:)
25800 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
25801 COMPLEX(kind=real_8), INTENT(INOUT) :: msg(:)
25802 INTEGER, INTENT(IN) :: recvcount, root
25803 CLASS(mp_comm_type), INTENT(IN) :: comm
25804 TYPE(mp_request_type), INTENT(OUT) :: request
25805
25806 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_zv'
25807
25808 INTEGER :: handle
25809#if defined(__parallel)
25810 INTEGER :: ierr
25811#endif
25812
25813 CALL mp_timeset(routinen, handle)
25814
25815#if defined(__parallel)
25816#if !defined(__GNUC__) || __GNUC__ >= 9
25817 cpassert(is_contiguous(msg_scatter))
25818 cpassert(is_contiguous(msg))
25819 cpassert(is_contiguous(sendcounts))
25820 cpassert(is_contiguous(displs))
25821#endif
25822 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_double_complex, msg, &
25823 recvcount, mpi_double_complex, root, comm%handle, request%handle, ierr)
25824 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
25825 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_8_size))
25826#else
25827 mark_used(sendcounts)
25828 mark_used(displs)
25829 mark_used(recvcount)
25830 mark_used(root)
25831 mark_used(comm)
25832 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
25833 request = mp_request_null
25834#endif
25835 CALL mp_timestop(handle)
25836 END SUBROUTINE mp_iscatterv_zv
25837
25838! **************************************************************************************************
25839!> \brief Gathers a datum from all processes to one
25840!> \param[in] msg Datum to send to root
25841!> \param[out] msg_gather Received data (on root)
25842!> \param[in] root Process which gathers the data
25843!> \param[in] comm Message passing environment identifier
25844!> \par MPI mapping
25845!> mpi_gather
25846! **************************************************************************************************
25847 SUBROUTINE mp_gather_z (msg, msg_gather, root, comm)
25848 COMPLEX(kind=real_8), INTENT(IN) :: msg
25849 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25850 INTEGER, INTENT(IN) :: root
25851 CLASS(mp_comm_type), INTENT(IN) :: comm
25852
25853 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_z'
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, root, 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(root)
25870 mark_used(comm)
25871 msg_gather(1) = msg
25872#endif
25873 CALL mp_timestop(handle)
25874 END SUBROUTINE mp_gather_z
25875
25876! **************************************************************************************************
25877!> \brief Gathers a datum from all processes to one, uses the source process of comm
25878!> \param[in] msg Datum to send to root
25879!> \param[out] msg_gather Received data (on root)
25880!> \param[in] comm Message passing environment identifier
25881!> \par MPI mapping
25882!> mpi_gather
25883! **************************************************************************************************
25884 SUBROUTINE mp_gather_z_src(msg, msg_gather, comm)
25885 COMPLEX(kind=real_8), INTENT(IN) :: msg
25886 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25887 CLASS(mp_comm_type), INTENT(IN) :: comm
25888
25889 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_z_src'
25890
25891 INTEGER :: handle
25892#if defined(__parallel)
25893 INTEGER :: ierr, msglen
25894#endif
25895
25896 CALL mp_timeset(routinen, handle)
25897
25898#if defined(__parallel)
25899 msglen = 1
25900 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25901 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25902 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25903 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25904#else
25905 mark_used(comm)
25906 msg_gather(1) = msg
25907#endif
25908 CALL mp_timestop(handle)
25909 END SUBROUTINE mp_gather_z_src
25910
25911! **************************************************************************************************
25912!> \brief Gathers data from all processes to one
25913!> \param[in] msg Datum to send to root
25914!> \param msg_gather ...
25915!> \param root ...
25916!> \param comm ...
25917!> \par Data length
25918!> All data (msg) is equal-sized
25919!> \par MPI mapping
25920!> mpi_gather
25921!> \note see mp_gather_z
25922! **************************************************************************************************
25923 SUBROUTINE mp_gather_zv(msg, msg_gather, root, comm)
25924 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
25925 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25926 INTEGER, INTENT(IN) :: root
25927 CLASS(mp_comm_type), INTENT(IN) :: comm
25928
25929 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zv'
25930
25931 INTEGER :: handle
25932#if defined(__parallel)
25933 INTEGER :: ierr, msglen
25934#endif
25935
25936 CALL mp_timeset(routinen, handle)
25937
25938#if defined(__parallel)
25939 msglen = SIZE(msg)
25940 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25941 msglen, mpi_double_complex, root, comm%handle, ierr)
25942 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25943 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25944#else
25945 mark_used(root)
25946 mark_used(comm)
25947 msg_gather = msg
25948#endif
25949 CALL mp_timestop(handle)
25950 END SUBROUTINE mp_gather_zv
25951
25952! **************************************************************************************************
25953!> \brief Gathers data from all processes to one. Gathers from comm%source
25954!> \param[in] msg Datum to send to root
25955!> \param msg_gather ...
25956!> \param comm ...
25957!> \par Data length
25958!> All data (msg) is equal-sized
25959!> \par MPI mapping
25960!> mpi_gather
25961!> \note see mp_gather_z
25962! **************************************************************************************************
25963 SUBROUTINE mp_gather_zv_src(msg, msg_gather, comm)
25964 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
25965 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
25966 CLASS(mp_comm_type), INTENT(IN) :: comm
25967
25968 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zv_src'
25969
25970 INTEGER :: handle
25971#if defined(__parallel)
25972 INTEGER :: ierr, msglen
25973#endif
25974
25975 CALL mp_timeset(routinen, handle)
25976
25977#if defined(__parallel)
25978 msglen = SIZE(msg)
25979 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
25980 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
25981 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
25982 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
25983#else
25984 mark_used(comm)
25985 msg_gather = msg
25986#endif
25987 CALL mp_timestop(handle)
25988 END SUBROUTINE mp_gather_zv_src
25989
25990! **************************************************************************************************
25991!> \brief Gathers data from all processes to one
25992!> \param[in] msg Datum to send to root
25993!> \param msg_gather ...
25994!> \param root ...
25995!> \param comm ...
25996!> \par Data length
25997!> All data (msg) is equal-sized
25998!> \par MPI mapping
25999!> mpi_gather
26000!> \note see mp_gather_z
26001! **************************************************************************************************
26002 SUBROUTINE mp_gather_zm(msg, msg_gather, root, comm)
26003 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
26004 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
26005 INTEGER, INTENT(IN) :: root
26006 CLASS(mp_comm_type), INTENT(IN) :: comm
26007
26008 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zm'
26009
26010 INTEGER :: handle
26011#if defined(__parallel)
26012 INTEGER :: ierr, msglen
26013#endif
26014
26015 CALL mp_timeset(routinen, handle)
26016
26017#if defined(__parallel)
26018 msglen = SIZE(msg)
26019 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26020 msglen, mpi_double_complex, root, comm%handle, ierr)
26021 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26022 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26023#else
26024 mark_used(root)
26025 mark_used(comm)
26026 msg_gather = msg
26027#endif
26028 CALL mp_timestop(handle)
26029 END SUBROUTINE mp_gather_zm
26030
26031! **************************************************************************************************
26032!> \brief Gathers data from all processes to one. Gathers from comm%source
26033!> \param[in] msg Datum to send to root
26034!> \param msg_gather ...
26035!> \param comm ...
26036!> \par Data length
26037!> All data (msg) is equal-sized
26038!> \par MPI mapping
26039!> mpi_gather
26040!> \note see mp_gather_z
26041! **************************************************************************************************
26042 SUBROUTINE mp_gather_zm_src(msg, msg_gather, comm)
26043 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:, :)
26044 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
26045 CLASS(mp_comm_type), INTENT(IN) :: comm
26046
26047 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_zm_src'
26048
26049 INTEGER :: handle
26050#if defined(__parallel)
26051 INTEGER :: ierr, msglen
26052#endif
26053
26054 CALL mp_timeset(routinen, handle)
26055
26056#if defined(__parallel)
26057 msglen = SIZE(msg)
26058 CALL mpi_gather(msg, msglen, mpi_double_complex, msg_gather, &
26059 msglen, mpi_double_complex, comm%source, comm%handle, ierr)
26060 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
26061 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_8_size))
26062#else
26063 mark_used(comm)
26064 msg_gather = msg
26065#endif
26066 CALL mp_timestop(handle)
26067 END SUBROUTINE mp_gather_zm_src
26068
26069! **************************************************************************************************
26070!> \brief Gathers data from all processes to one.
26071!> \param[in] sendbuf Data to send to root
26072!> \param[out] recvbuf Received data (on root)
26073!> \param[in] recvcounts Sizes of data received from processes
26074!> \param[in] displs Offsets of data received from processes
26075!> \param[in] root Process which gathers the data
26076!> \param[in] comm Message passing environment identifier
26077!> \par Data length
26078!> Data can have different lengths
26079!> \par Offsets
26080!> Offsets start at 0
26081!> \par MPI mapping
26082!> mpi_gather
26083! **************************************************************************************************
26084 SUBROUTINE mp_gatherv_zv(sendbuf, recvbuf, recvcounts, displs, root, comm)
26085
26086 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
26087 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
26088 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26089 INTEGER, INTENT(IN) :: root
26090 CLASS(mp_comm_type), INTENT(IN) :: comm
26091
26092 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zv'
26093
26094 INTEGER :: handle
26095#if defined(__parallel)
26096 INTEGER :: ierr, sendcount
26097#endif
26098
26099 CALL mp_timeset(routinen, handle)
26100
26101#if defined(__parallel)
26102 sendcount = SIZE(sendbuf)
26103 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26104 recvbuf, recvcounts, displs, mpi_double_complex, &
26105 root, comm%handle, ierr)
26106 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26107 CALL add_perf(perf_id=4, &
26108 count=1, &
26109 msg_size=sendcount*(2*real_8_size))
26110#else
26111 mark_used(recvcounts)
26112 mark_used(root)
26113 mark_used(comm)
26114 recvbuf(1 + displs(1):) = sendbuf
26115#endif
26116 CALL mp_timestop(handle)
26117 END SUBROUTINE mp_gatherv_zv
26118
26119! **************************************************************************************************
26120!> \brief Gathers data from all processes to one. Gathers from comm%source
26121!> \param[in] sendbuf Data to send to root
26122!> \param[out] recvbuf Received data (on root)
26123!> \param[in] recvcounts Sizes of data received from processes
26124!> \param[in] displs Offsets of data received from processes
26125!> \param[in] comm Message passing environment identifier
26126!> \par Data length
26127!> Data can have different lengths
26128!> \par Offsets
26129!> Offsets start at 0
26130!> \par MPI mapping
26131!> mpi_gather
26132! **************************************************************************************************
26133 SUBROUTINE mp_gatherv_zv_src(sendbuf, recvbuf, recvcounts, displs, comm)
26134
26135 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
26136 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
26137 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26138 CLASS(mp_comm_type), INTENT(IN) :: comm
26139
26140 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zv_src'
26141
26142 INTEGER :: handle
26143#if defined(__parallel)
26144 INTEGER :: ierr, sendcount
26145#endif
26146
26147 CALL mp_timeset(routinen, handle)
26148
26149#if defined(__parallel)
26150 sendcount = SIZE(sendbuf)
26151 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26152 recvbuf, recvcounts, displs, mpi_double_complex, &
26153 comm%source, comm%handle, ierr)
26154 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26155 CALL add_perf(perf_id=4, &
26156 count=1, &
26157 msg_size=sendcount*(2*real_8_size))
26158#else
26159 mark_used(recvcounts)
26160 mark_used(comm)
26161 recvbuf(1 + displs(1):) = sendbuf
26162#endif
26163 CALL mp_timestop(handle)
26164 END SUBROUTINE mp_gatherv_zv_src
26165
26166! **************************************************************************************************
26167!> \brief Gathers data from all processes to one.
26168!> \param[in] sendbuf Data to send to root
26169!> \param[out] recvbuf Received data (on root)
26170!> \param[in] recvcounts Sizes of data received from processes
26171!> \param[in] displs Offsets of data received from processes
26172!> \param[in] root Process which gathers the data
26173!> \param[in] comm Message passing environment identifier
26174!> \par Data length
26175!> Data can have different lengths
26176!> \par Offsets
26177!> Offsets start at 0
26178!> \par MPI mapping
26179!> mpi_gather
26180! **************************************************************************************************
26181 SUBROUTINE mp_gatherv_zm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
26182
26183 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
26184 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
26185 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26186 INTEGER, INTENT(IN) :: root
26187 CLASS(mp_comm_type), INTENT(IN) :: comm
26188
26189 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zm2'
26190
26191 INTEGER :: handle
26192#if defined(__parallel)
26193 INTEGER :: ierr, sendcount
26194#endif
26195
26196 CALL mp_timeset(routinen, handle)
26197
26198#if defined(__parallel)
26199 sendcount = SIZE(sendbuf)
26200 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26201 recvbuf, recvcounts, displs, mpi_double_complex, &
26202 root, comm%handle, ierr)
26203 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26204 CALL add_perf(perf_id=4, &
26205 count=1, &
26206 msg_size=sendcount*(2*real_8_size))
26207#else
26208 mark_used(recvcounts)
26209 mark_used(root)
26210 mark_used(comm)
26211 recvbuf(:, 1 + displs(1):) = sendbuf
26212#endif
26213 CALL mp_timestop(handle)
26214 END SUBROUTINE mp_gatherv_zm2
26215
26216! **************************************************************************************************
26217!> \brief Gathers data from all processes to one.
26218!> \param[in] sendbuf Data to send to root
26219!> \param[out] recvbuf Received data (on root)
26220!> \param[in] recvcounts Sizes of data received from processes
26221!> \param[in] displs Offsets of data received from processes
26222!> \param[in] comm Message passing environment identifier
26223!> \par Data length
26224!> Data can have different lengths
26225!> \par Offsets
26226!> Offsets start at 0
26227!> \par MPI mapping
26228!> mpi_gather
26229! **************************************************************************************************
26230 SUBROUTINE mp_gatherv_zm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
26231
26232 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
26233 COMPLEX(kind=real_8), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
26234 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26235 CLASS(mp_comm_type), INTENT(IN) :: comm
26236
26237 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_zm2_src'
26238
26239 INTEGER :: handle
26240#if defined(__parallel)
26241 INTEGER :: ierr, sendcount
26242#endif
26243
26244 CALL mp_timeset(routinen, handle)
26245
26246#if defined(__parallel)
26247 sendcount = SIZE(sendbuf)
26248 CALL mpi_gatherv(sendbuf, sendcount, mpi_double_complex, &
26249 recvbuf, recvcounts, displs, mpi_double_complex, &
26250 comm%source, comm%handle, ierr)
26251 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26252 CALL add_perf(perf_id=4, &
26253 count=1, &
26254 msg_size=sendcount*(2*real_8_size))
26255#else
26256 mark_used(recvcounts)
26257 mark_used(comm)
26258 recvbuf(:, 1 + displs(1):) = sendbuf
26259#endif
26260 CALL mp_timestop(handle)
26261 END SUBROUTINE mp_gatherv_zm2_src
26262
26263! **************************************************************************************************
26264!> \brief Gathers data from all processes to one.
26265!> \param[in] sendbuf Data to send to root
26266!> \param[out] recvbuf Received data (on root)
26267!> \param[in] recvcounts Sizes of data received from processes
26268!> \param[in] displs Offsets of data received from processes
26269!> \param[in] root Process which gathers the data
26270!> \param[in] comm Message passing environment identifier
26271!> \par Data length
26272!> Data can have different lengths
26273!> \par Offsets
26274!> Offsets start at 0
26275!> \par MPI mapping
26276!> mpi_gather
26277! **************************************************************************************************
26278 SUBROUTINE mp_igatherv_zv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
26279 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: sendbuf
26280 COMPLEX(kind=real_8), DIMENSION(:), INTENT(OUT) :: recvbuf
26281 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
26282 INTEGER, INTENT(IN) :: sendcount, root
26283 CLASS(mp_comm_type), INTENT(IN) :: comm
26284 TYPE(mp_request_type), INTENT(OUT) :: request
26285
26286 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_zv'
26287
26288 INTEGER :: handle
26289#if defined(__parallel)
26290 INTEGER :: ierr
26291#endif
26292
26293 CALL mp_timeset(routinen, handle)
26294
26295#if defined(__parallel)
26296#if !defined(__GNUC__) || __GNUC__ >= 9
26297 cpassert(is_contiguous(sendbuf))
26298 cpassert(is_contiguous(recvbuf))
26299 cpassert(is_contiguous(recvcounts))
26300 cpassert(is_contiguous(displs))
26301#endif
26302 CALL mpi_igatherv(sendbuf, sendcount, mpi_double_complex, &
26303 recvbuf, recvcounts, displs, mpi_double_complex, &
26304 root, comm%handle, request%handle, ierr)
26305 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
26306 CALL add_perf(perf_id=24, &
26307 count=1, &
26308 msg_size=sendcount*(2*real_8_size))
26309#else
26310 mark_used(sendcount)
26311 mark_used(recvcounts)
26312 mark_used(root)
26313 mark_used(comm)
26314 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
26315 request = mp_request_null
26316#endif
26317 CALL mp_timestop(handle)
26318 END SUBROUTINE mp_igatherv_zv
26319
26320! **************************************************************************************************
26321!> \brief Gathers a datum from all processes and all processes receive the
26322!> same data
26323!> \param[in] msgout Datum to send
26324!> \param[out] msgin Received data
26325!> \param[in] comm Message passing environment identifier
26326!> \par Data size
26327!> All processes send equal-sized data
26328!> \par MPI mapping
26329!> mpi_allgather
26330! **************************************************************************************************
26331 SUBROUTINE mp_allgather_z (msgout, msgin, comm)
26332 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26333 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:)
26334 CLASS(mp_comm_type), INTENT(IN) :: comm
26335
26336 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z'
26337
26338 INTEGER :: handle
26339#if defined(__parallel)
26340 INTEGER :: ierr, rcount, scount
26341#endif
26342
26343 CALL mp_timeset(routinen, handle)
26344
26345#if defined(__parallel)
26346 scount = 1
26347 rcount = 1
26348 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26349 msgin, rcount, mpi_double_complex, &
26350 comm%handle, ierr)
26351 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26352#else
26353 mark_used(comm)
26354 msgin = msgout
26355#endif
26356 CALL mp_timestop(handle)
26357 END SUBROUTINE mp_allgather_z
26358
26359! **************************************************************************************************
26360!> \brief Gathers a datum from all processes and all processes receive the
26361!> same data
26362!> \param[in] msgout Datum to send
26363!> \param[out] msgin Received data
26364!> \param[in] comm Message passing environment identifier
26365!> \par Data size
26366!> All processes send equal-sized data
26367!> \par MPI mapping
26368!> mpi_allgather
26369! **************************************************************************************************
26370 SUBROUTINE mp_allgather_z2(msgout, msgin, comm)
26371 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26372 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26373 CLASS(mp_comm_type), INTENT(IN) :: comm
26374
26375 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z2'
26376
26377 INTEGER :: handle
26378#if defined(__parallel)
26379 INTEGER :: ierr, rcount, scount
26380#endif
26381
26382 CALL mp_timeset(routinen, handle)
26383
26384#if defined(__parallel)
26385 scount = 1
26386 rcount = 1
26387 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26388 msgin, rcount, mpi_double_complex, &
26389 comm%handle, ierr)
26390 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26391#else
26392 mark_used(comm)
26393 msgin = msgout
26394#endif
26395 CALL mp_timestop(handle)
26396 END SUBROUTINE mp_allgather_z2
26397
26398! **************************************************************************************************
26399!> \brief Gathers a datum from all processes and all processes receive the
26400!> same data
26401!> \param[in] msgout Datum to send
26402!> \param[out] msgin Received data
26403!> \param[in] comm Message passing environment identifier
26404!> \par Data size
26405!> All processes send equal-sized data
26406!> \par MPI mapping
26407!> mpi_allgather
26408! **************************************************************************************************
26409 SUBROUTINE mp_iallgather_z (msgout, msgin, comm, request)
26410 COMPLEX(kind=real_8), INTENT(IN) :: msgout
26411 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26412 CLASS(mp_comm_type), INTENT(IN) :: comm
26413 TYPE(mp_request_type), INTENT(OUT) :: request
26414
26415 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z'
26416
26417 INTEGER :: handle
26418#if defined(__parallel)
26419 INTEGER :: ierr, rcount, scount
26420#endif
26421
26422 CALL mp_timeset(routinen, handle)
26423
26424#if defined(__parallel)
26425#if !defined(__GNUC__) || __GNUC__ >= 9
26426 cpassert(is_contiguous(msgin))
26427#endif
26428 scount = 1
26429 rcount = 1
26430 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26431 msgin, rcount, mpi_double_complex, &
26432 comm%handle, request%handle, ierr)
26433 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26434#else
26435 mark_used(comm)
26436 msgin = msgout
26437 request = mp_request_null
26438#endif
26439 CALL mp_timestop(handle)
26440 END SUBROUTINE mp_iallgather_z
26441
26442! **************************************************************************************************
26443!> \brief Gathers vector data from all processes and all processes receive the
26444!> same data
26445!> \param[in] msgout Rank-1 data to send
26446!> \param[out] msgin Received data
26447!> \param[in] comm Message passing environment identifier
26448!> \par Data size
26449!> All processes send equal-sized data
26450!> \par Ranks
26451!> The last rank counts the processes
26452!> \par MPI mapping
26453!> mpi_allgather
26454! **************************************************************************************************
26455 SUBROUTINE mp_allgather_z12(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_z12'
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_z12
26482
26483! **************************************************************************************************
26484!> \brief Gathers matrix data from all processes and all processes receive the
26485!> same data
26486!> \param[in] msgout Rank-2 data to send
26487!> \param msgin ...
26488!> \param comm ...
26489!> \note see mp_allgather_z12
26490! **************************************************************************************************
26491 SUBROUTINE mp_allgather_z23(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_z23'
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_z23
26518
26519! **************************************************************************************************
26520!> \brief Gathers rank-3 data from all processes and all processes receive the
26521!> same data
26522!> \param[in] msgout Rank-3 data to send
26523!> \param msgin ...
26524!> \param comm ...
26525!> \note see mp_allgather_z12
26526! **************************************************************************************************
26527 SUBROUTINE mp_allgather_z34(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_z34'
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(:, :, :, 1) = msgout(:, :, :)
26551#endif
26552 CALL mp_timestop(handle)
26553 END SUBROUTINE mp_allgather_z34
26554
26555! **************************************************************************************************
26556!> \brief Gathers rank-2 data from all processes and all processes receive the
26557!> same data
26558!> \param[in] msgout Rank-2 data to send
26559!> \param msgin ...
26560!> \param comm ...
26561!> \note see mp_allgather_z12
26562! **************************************************************************************************
26563 SUBROUTINE mp_allgather_z22(msgout, msgin, comm)
26564 COMPLEX(kind=real_8), INTENT(IN), CONTIGUOUS :: msgout(:, :)
26565 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
26566 CLASS(mp_comm_type), INTENT(IN) :: comm
26567
26568 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_z22'
26569
26570 INTEGER :: handle
26571#if defined(__parallel)
26572 INTEGER :: ierr, rcount, scount
26573#endif
26574
26575 CALL mp_timeset(routinen, handle)
26576
26577#if defined(__parallel)
26578 scount = SIZE(msgout(:, :))
26579 rcount = scount
26580 CALL mpi_allgather(msgout, scount, mpi_double_complex, &
26581 msgin, rcount, mpi_double_complex, &
26582 comm%handle, ierr)
26583 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
26584#else
26585 mark_used(comm)
26586 msgin(:, :) = msgout(:, :)
26587#endif
26588 CALL mp_timestop(handle)
26589 END SUBROUTINE mp_allgather_z22
26590
26591! **************************************************************************************************
26592!> \brief Gathers rank-1 data from all processes and all processes receive the
26593!> same data
26594!> \param[in] msgout Rank-1 data to send
26595!> \param msgin ...
26596!> \param comm ...
26597!> \param request ...
26598!> \note see mp_allgather_z11
26599! **************************************************************************************************
26600 SUBROUTINE mp_iallgather_z11(msgout, msgin, comm, request)
26601 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26602 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26603 CLASS(mp_comm_type), INTENT(IN) :: comm
26604 TYPE(mp_request_type), INTENT(OUT) :: request
26605
26606 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z11'
26607
26608 INTEGER :: handle
26609#if defined(__parallel)
26610 INTEGER :: ierr, rcount, scount
26611#endif
26612
26613 CALL mp_timeset(routinen, handle)
26614
26615#if defined(__parallel)
26616#if !defined(__GNUC__) || __GNUC__ >= 9
26617 cpassert(is_contiguous(msgout))
26618 cpassert(is_contiguous(msgin))
26619#endif
26620 scount = SIZE(msgout(:))
26621 rcount = scount
26622 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26623 msgin, rcount, mpi_double_complex, &
26624 comm%handle, request%handle, ierr)
26625 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26626#else
26627 mark_used(comm)
26628 msgin = msgout
26629 request = mp_request_null
26630#endif
26631 CALL mp_timestop(handle)
26632 END SUBROUTINE mp_iallgather_z11
26633
26634! **************************************************************************************************
26635!> \brief Gathers rank-2 data from all processes and all processes receive the
26636!> same data
26637!> \param[in] msgout Rank-2 data to send
26638!> \param msgin ...
26639!> \param comm ...
26640!> \param request ...
26641!> \note see mp_allgather_z12
26642! **************************************************************************************************
26643 SUBROUTINE mp_iallgather_z13(msgout, msgin, comm, request)
26644 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26645 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
26646 CLASS(mp_comm_type), INTENT(IN) :: comm
26647 TYPE(mp_request_type), INTENT(OUT) :: request
26648
26649 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z13'
26650
26651 INTEGER :: handle
26652#if defined(__parallel)
26653 INTEGER :: ierr, rcount, scount
26654#endif
26655
26656 CALL mp_timeset(routinen, handle)
26657
26658#if defined(__parallel)
26659#if !defined(__GNUC__) || __GNUC__ >= 9
26660 cpassert(is_contiguous(msgout))
26661 cpassert(is_contiguous(msgin))
26662#endif
26663
26664 scount = SIZE(msgout(:))
26665 rcount = scount
26666 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26667 msgin, rcount, mpi_double_complex, &
26668 comm%handle, request%handle, ierr)
26669 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26670#else
26671 mark_used(comm)
26672 msgin(:, 1, 1) = msgout(:)
26673 request = mp_request_null
26674#endif
26675 CALL mp_timestop(handle)
26676 END SUBROUTINE mp_iallgather_z13
26677
26678! **************************************************************************************************
26679!> \brief Gathers rank-2 data from all processes and all processes receive the
26680!> same data
26681!> \param[in] msgout Rank-2 data to send
26682!> \param msgin ...
26683!> \param comm ...
26684!> \param request ...
26685!> \note see mp_allgather_z12
26686! **************************************************************************************************
26687 SUBROUTINE mp_iallgather_z22(msgout, msgin, comm, request)
26688 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :)
26689 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :)
26690 CLASS(mp_comm_type), INTENT(IN) :: comm
26691 TYPE(mp_request_type), INTENT(OUT) :: request
26692
26693 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z22'
26694
26695 INTEGER :: handle
26696#if defined(__parallel)
26697 INTEGER :: ierr, rcount, scount
26698#endif
26699
26700 CALL mp_timeset(routinen, handle)
26701
26702#if defined(__parallel)
26703#if !defined(__GNUC__) || __GNUC__ >= 9
26704 cpassert(is_contiguous(msgout))
26705 cpassert(is_contiguous(msgin))
26706#endif
26707
26708 scount = SIZE(msgout(:, :))
26709 rcount = scount
26710 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26711 msgin, rcount, mpi_double_complex, &
26712 comm%handle, request%handle, ierr)
26713 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26714#else
26715 mark_used(comm)
26716 msgin(:, :) = msgout(:, :)
26717 request = mp_request_null
26718#endif
26719 CALL mp_timestop(handle)
26720 END SUBROUTINE mp_iallgather_z22
26721
26722! **************************************************************************************************
26723!> \brief Gathers rank-2 data from all processes and all processes receive the
26724!> same data
26725!> \param[in] msgout Rank-2 data to send
26726!> \param msgin ...
26727!> \param comm ...
26728!> \param request ...
26729!> \note see mp_allgather_z12
26730! **************************************************************************************************
26731 SUBROUTINE mp_iallgather_z24(msgout, msgin, comm, request)
26732 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :)
26733 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :, :)
26734 CLASS(mp_comm_type), INTENT(IN) :: comm
26735 TYPE(mp_request_type), INTENT(OUT) :: request
26736
26737 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z24'
26738
26739 INTEGER :: handle
26740#if defined(__parallel)
26741 INTEGER :: ierr, rcount, scount
26742#endif
26743
26744 CALL mp_timeset(routinen, handle)
26745
26746#if defined(__parallel)
26747#if !defined(__GNUC__) || __GNUC__ >= 9
26748 cpassert(is_contiguous(msgout))
26749 cpassert(is_contiguous(msgin))
26750#endif
26751
26752 scount = SIZE(msgout(:, :))
26753 rcount = scount
26754 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26755 msgin, rcount, mpi_double_complex, &
26756 comm%handle, request%handle, ierr)
26757 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26758#else
26759 mark_used(comm)
26760 msgin(:, :, 1, 1) = msgout(:, :)
26761 request = mp_request_null
26762#endif
26763 CALL mp_timestop(handle)
26764 END SUBROUTINE mp_iallgather_z24
26765
26766! **************************************************************************************************
26767!> \brief Gathers rank-3 data from all processes and all processes receive the
26768!> same data
26769!> \param[in] msgout Rank-3 data to send
26770!> \param msgin ...
26771!> \param comm ...
26772!> \param request ...
26773!> \note see mp_allgather_z12
26774! **************************************************************************************************
26775 SUBROUTINE mp_iallgather_z33(msgout, msgin, comm, request)
26776 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:, :, :)
26777 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:, :, :)
26778 CLASS(mp_comm_type), INTENT(IN) :: comm
26779 TYPE(mp_request_type), INTENT(OUT) :: request
26780
26781 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_z33'
26782
26783 INTEGER :: handle
26784#if defined(__parallel)
26785 INTEGER :: ierr, rcount, scount
26786#endif
26787
26788 CALL mp_timeset(routinen, handle)
26789
26790#if defined(__parallel)
26791#if !defined(__GNUC__) || __GNUC__ >= 9
26792 cpassert(is_contiguous(msgout))
26793 cpassert(is_contiguous(msgin))
26794#endif
26795
26796 scount = SIZE(msgout(:, :, :))
26797 rcount = scount
26798 CALL mpi_iallgather(msgout, scount, mpi_double_complex, &
26799 msgin, rcount, mpi_double_complex, &
26800 comm%handle, request%handle, ierr)
26801 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
26802#else
26803 mark_used(comm)
26804 msgin(:, :, :) = msgout(:, :, :)
26805 request = mp_request_null
26806#endif
26807 CALL mp_timestop(handle)
26808 END SUBROUTINE mp_iallgather_z33
26809
26810! **************************************************************************************************
26811!> \brief Gathers vector data from all processes and all processes receive the
26812!> same data
26813!> \param[in] msgout Rank-1 data to send
26814!> \param[out] msgin Received data
26815!> \param[in] rcount Size of sent data for every process
26816!> \param[in] rdispl Offset of sent data for every process
26817!> \param[in] comm Message passing environment identifier
26818!> \par Data size
26819!> Processes can send different-sized data
26820!> \par Ranks
26821!> The last rank counts the processes
26822!> \par Offsets
26823!> Offsets are from 0
26824!> \par MPI mapping
26825!> mpi_allgather
26826! **************************************************************************************************
26827 SUBROUTINE mp_allgatherv_zv(msgout, msgin, rcount, rdispl, comm)
26828 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
26829 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
26830 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26831 CLASS(mp_comm_type), INTENT(IN) :: comm
26832
26833 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_zv'
26834
26835 INTEGER :: handle
26836#if defined(__parallel)
26837 INTEGER :: ierr, scount
26838#endif
26839
26840 CALL mp_timeset(routinen, handle)
26841
26842#if defined(__parallel)
26843 scount = SIZE(msgout)
26844 CALL mpi_allgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
26845 rdispl, mpi_double_complex, comm%handle, ierr)
26846 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
26847#else
26848 mark_used(rcount)
26849 mark_used(rdispl)
26850 mark_used(comm)
26851 msgin = msgout
26852#endif
26853 CALL mp_timestop(handle)
26854 END SUBROUTINE mp_allgatherv_zv
26855
26856! **************************************************************************************************
26857!> \brief Gathers vector data from all processes and all processes receive the
26858!> same data
26859!> \param[in] msgout Rank-1 data to send
26860!> \param[out] msgin Received data
26861!> \param[in] rcount Size of sent data for every process
26862!> \param[in] rdispl Offset of sent data for every process
26863!> \param[in] comm Message passing environment identifier
26864!> \par Data size
26865!> Processes can send different-sized data
26866!> \par Ranks
26867!> The last rank counts the processes
26868!> \par Offsets
26869!> Offsets are from 0
26870!> \par MPI mapping
26871!> mpi_allgather
26872! **************************************************************************************************
26873 SUBROUTINE mp_allgatherv_zm2(msgout, msgin, rcount, rdispl, comm)
26874 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
26875 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
26876 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26877 CLASS(mp_comm_type), INTENT(IN) :: comm
26878
26879 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_zv'
26880
26881 INTEGER :: handle
26882#if defined(__parallel)
26883 INTEGER :: ierr, scount
26884#endif
26885
26886 CALL mp_timeset(routinen, handle)
26887
26888#if defined(__parallel)
26889 scount = SIZE(msgout)
26890 CALL mpi_allgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
26891 rdispl, mpi_double_complex, comm%handle, ierr)
26892 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
26893#else
26894 mark_used(rcount)
26895 mark_used(rdispl)
26896 mark_used(comm)
26897 msgin = msgout
26898#endif
26899 CALL mp_timestop(handle)
26900 END SUBROUTINE mp_allgatherv_zm2
26901
26902! **************************************************************************************************
26903!> \brief Gathers vector data from all processes and all processes receive the
26904!> same data
26905!> \param[in] msgout Rank-1 data to send
26906!> \param[out] msgin Received data
26907!> \param[in] rcount Size of sent data for every process
26908!> \param[in] rdispl Offset of sent data for every process
26909!> \param[in] comm Message passing environment identifier
26910!> \par Data size
26911!> Processes can send different-sized data
26912!> \par Ranks
26913!> The last rank counts the processes
26914!> \par Offsets
26915!> Offsets are from 0
26916!> \par MPI mapping
26917!> mpi_allgather
26918! **************************************************************************************************
26919 SUBROUTINE mp_iallgatherv_zv(msgout, msgin, rcount, rdispl, comm, request)
26920 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26921 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26922 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
26923 CLASS(mp_comm_type), INTENT(IN) :: comm
26924 TYPE(mp_request_type), INTENT(OUT) :: request
26925
26926 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_zv'
26927
26928 INTEGER :: handle
26929#if defined(__parallel)
26930 INTEGER :: ierr, scount, rsize
26931#endif
26932
26933 CALL mp_timeset(routinen, handle)
26934
26935#if defined(__parallel)
26936#if !defined(__GNUC__) || __GNUC__ >= 9
26937 cpassert(is_contiguous(msgout))
26938 cpassert(is_contiguous(msgin))
26939 cpassert(is_contiguous(rcount))
26940 cpassert(is_contiguous(rdispl))
26941#endif
26942
26943 scount = SIZE(msgout)
26944 rsize = SIZE(rcount)
26945 CALL mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, &
26946 rdispl, comm, request, ierr)
26947 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
26948#else
26949 mark_used(rcount)
26950 mark_used(rdispl)
26951 mark_used(comm)
26952 msgin = msgout
26953 request = mp_request_null
26954#endif
26955 CALL mp_timestop(handle)
26956 END SUBROUTINE mp_iallgatherv_zv
26957
26958! **************************************************************************************************
26959!> \brief Gathers vector data from all processes and all processes receive the
26960!> same data
26961!> \param[in] msgout Rank-1 data to send
26962!> \param[out] msgin Received data
26963!> \param[in] rcount Size of sent data for every process
26964!> \param[in] rdispl Offset of sent data for every process
26965!> \param[in] comm Message passing environment identifier
26966!> \par Data size
26967!> Processes can send different-sized data
26968!> \par Ranks
26969!> The last rank counts the processes
26970!> \par Offsets
26971!> Offsets are from 0
26972!> \par MPI mapping
26973!> mpi_allgather
26974! **************************************************************************************************
26975 SUBROUTINE mp_iallgatherv_zv2(msgout, msgin, rcount, rdispl, comm, request)
26976 COMPLEX(kind=real_8), INTENT(IN) :: msgout(:)
26977 COMPLEX(kind=real_8), INTENT(OUT) :: msgin(:)
26978 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
26979 CLASS(mp_comm_type), INTENT(IN) :: comm
26980 TYPE(mp_request_type), INTENT(OUT) :: request
26981
26982 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_zv2'
26983
26984 INTEGER :: handle
26985#if defined(__parallel)
26986 INTEGER :: ierr, scount, rsize
26987#endif
26988
26989 CALL mp_timeset(routinen, handle)
26990
26991#if defined(__parallel)
26992#if !defined(__GNUC__) || __GNUC__ >= 9
26993 cpassert(is_contiguous(msgout))
26994 cpassert(is_contiguous(msgin))
26995 cpassert(is_contiguous(rcount))
26996 cpassert(is_contiguous(rdispl))
26997#endif
26998
26999 scount = SIZE(msgout)
27000 rsize = SIZE(rcount)
27001 CALL mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, &
27002 rdispl, comm, request, ierr)
27003 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
27004#else
27005 mark_used(rcount)
27006 mark_used(rdispl)
27007 mark_used(comm)
27008 msgin = msgout
27009 request = mp_request_null
27010#endif
27011 CALL mp_timestop(handle)
27012 END SUBROUTINE mp_iallgatherv_zv2
27013
27014! **************************************************************************************************
27015!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
27016!> the issue is with the rank of rcount and rdispl
27017!> \param count ...
27018!> \param array_of_requests ...
27019!> \param array_of_statuses ...
27020!> \param ierr ...
27021!> \author Alfio Lazzaro
27022! **************************************************************************************************
27023#if defined(__parallel)
27024 SUBROUTINE mp_iallgatherv_zv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
27025 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:)
27026 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
27027 INTEGER, INTENT(IN) :: rsize
27028 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
27029 CLASS(mp_comm_type), INTENT(IN) :: comm
27030 TYPE(mp_request_type), INTENT(OUT) :: request
27031 INTEGER, INTENT(INOUT) :: ierr
27032
27033 CALL mpi_iallgatherv(msgout, scount, mpi_double_complex, msgin, rcount, &
27034 rdispl, mpi_double_complex, comm%handle, request%handle, ierr)
27035
27036 END SUBROUTINE mp_iallgatherv_zv_internal
27037#endif
27038
27039! **************************************************************************************************
27040!> \brief Sums a vector and partitions the result among processes
27041!> \param[in] msgout Data to sum
27042!> \param[out] msgin Received portion of summed data
27043!> \param[in] rcount Partition sizes of the summed data for
27044!> every process
27045!> \param[in] comm Message passing environment identifier
27046! **************************************************************************************************
27047 SUBROUTINE mp_sum_scatter_zv(msgout, msgin, rcount, comm)
27048 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
27049 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgin(:)
27050 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
27051 CLASS(mp_comm_type), INTENT(IN) :: comm
27052
27053 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_zv'
27054
27055 INTEGER :: handle
27056#if defined(__parallel)
27057 INTEGER :: ierr
27058#endif
27059
27060 CALL mp_timeset(routinen, handle)
27061
27062#if defined(__parallel)
27063 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_double_complex, mpi_sum, &
27064 comm%handle, ierr)
27065 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
27066
27067 CALL add_perf(perf_id=3, count=1, &
27068 msg_size=rcount(1)*2*(2*real_8_size))
27069#else
27070 mark_used(rcount)
27071 mark_used(comm)
27072 msgin = msgout(:, 1)
27073#endif
27074 CALL mp_timestop(handle)
27075 END SUBROUTINE mp_sum_scatter_zv
27076
27077! **************************************************************************************************
27078!> \brief Sends and receives vector data
27079!> \param[in] msgin Data to send
27080!> \param[in] dest Process to send data to
27081!> \param[out] msgout Received data
27082!> \param[in] source Process from which to receive
27083!> \param[in] comm Message passing environment identifier
27084!> \param[in] tag Send and recv tag (default: 0)
27085! **************************************************************************************************
27086 SUBROUTINE mp_sendrecv_z (msgin, dest, msgout, source, comm, tag)
27087 COMPLEX(kind=real_8), INTENT(IN) :: msgin
27088 INTEGER, INTENT(IN) :: dest
27089 COMPLEX(kind=real_8), INTENT(OUT) :: msgout
27090 INTEGER, INTENT(IN) :: source
27091 CLASS(mp_comm_type), INTENT(IN) :: comm
27092 INTEGER, INTENT(IN), OPTIONAL :: tag
27093
27094 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_z'
27095
27096 INTEGER :: handle
27097#if defined(__parallel)
27098 INTEGER :: ierr, msglen_in, msglen_out, &
27099 recv_tag, send_tag
27100#endif
27101
27102 CALL mp_timeset(routinen, handle)
27103
27104#if defined(__parallel)
27105 msglen_in = 1
27106 msglen_out = 1
27107 send_tag = 0 ! cannot think of something better here, this might be dangerous
27108 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27109 IF (PRESENT(tag)) THEN
27110 send_tag = tag
27111 recv_tag = tag
27112 END IF
27113 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27114 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27115 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27116 CALL add_perf(perf_id=7, count=1, &
27117 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27118#else
27119 mark_used(dest)
27120 mark_used(source)
27121 mark_used(comm)
27122 mark_used(tag)
27123 msgout = msgin
27124#endif
27125 CALL mp_timestop(handle)
27126 END SUBROUTINE mp_sendrecv_z
27127
27128! **************************************************************************************************
27129!> \brief Sends and receives vector data
27130!> \param[in] msgin Data to send
27131!> \param[in] dest Process to send data to
27132!> \param[out] msgout Received data
27133!> \param[in] source Process from which to receive
27134!> \param[in] comm Message passing environment identifier
27135!> \param[in] tag Send and recv tag (default: 0)
27136! **************************************************************************************************
27137 SUBROUTINE mp_sendrecv_zv(msgin, dest, msgout, source, comm, tag)
27138 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:)
27139 INTEGER, INTENT(IN) :: dest
27140 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:)
27141 INTEGER, INTENT(IN) :: source
27142 CLASS(mp_comm_type), INTENT(IN) :: comm
27143 INTEGER, INTENT(IN), OPTIONAL :: tag
27144
27145 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zv'
27146
27147 INTEGER :: handle
27148#if defined(__parallel)
27149 INTEGER :: ierr, msglen_in, msglen_out, &
27150 recv_tag, send_tag
27151#endif
27152
27153 CALL mp_timeset(routinen, handle)
27154
27155#if defined(__parallel)
27156 msglen_in = SIZE(msgin)
27157 msglen_out = SIZE(msgout)
27158 send_tag = 0 ! cannot think of something better here, this might be dangerous
27159 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27160 IF (PRESENT(tag)) THEN
27161 send_tag = tag
27162 recv_tag = tag
27163 END IF
27164 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27165 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27166 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27167 CALL add_perf(perf_id=7, count=1, &
27168 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27169#else
27170 mark_used(dest)
27171 mark_used(source)
27172 mark_used(comm)
27173 mark_used(tag)
27174 msgout = msgin
27175#endif
27176 CALL mp_timestop(handle)
27177 END SUBROUTINE mp_sendrecv_zv
27178
27179! **************************************************************************************************
27180!> \brief Sends and receives matrix data
27181!> \param msgin ...
27182!> \param dest ...
27183!> \param msgout ...
27184!> \param source ...
27185!> \param comm ...
27186!> \param tag ...
27187!> \note see mp_sendrecv_zv
27188! **************************************************************************************************
27189 SUBROUTINE mp_sendrecv_zm2(msgin, dest, msgout, source, comm, tag)
27190 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
27191 INTEGER, INTENT(IN) :: dest
27192 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
27193 INTEGER, INTENT(IN) :: source
27194 CLASS(mp_comm_type), INTENT(IN) :: comm
27195 INTEGER, INTENT(IN), OPTIONAL :: tag
27196
27197 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm2'
27198
27199 INTEGER :: handle
27200#if defined(__parallel)
27201 INTEGER :: ierr, msglen_in, msglen_out, &
27202 recv_tag, send_tag
27203#endif
27204
27205 CALL mp_timeset(routinen, handle)
27206
27207#if defined(__parallel)
27208 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
27209 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
27210 send_tag = 0 ! cannot think of something better here, this might be dangerous
27211 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27212 IF (PRESENT(tag)) THEN
27213 send_tag = tag
27214 recv_tag = tag
27215 END IF
27216 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27217 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27218 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27219 CALL add_perf(perf_id=7, count=1, &
27220 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27221#else
27222 mark_used(dest)
27223 mark_used(source)
27224 mark_used(comm)
27225 mark_used(tag)
27226 msgout = msgin
27227#endif
27228 CALL mp_timestop(handle)
27229 END SUBROUTINE mp_sendrecv_zm2
27230
27231! **************************************************************************************************
27232!> \brief Sends and receives rank-3 data
27233!> \param msgin ...
27234!> \param dest ...
27235!> \param msgout ...
27236!> \param source ...
27237!> \param comm ...
27238!> \note see mp_sendrecv_zv
27239! **************************************************************************************************
27240 SUBROUTINE mp_sendrecv_zm3(msgin, dest, msgout, source, comm, tag)
27241 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
27242 INTEGER, INTENT(IN) :: dest
27243 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
27244 INTEGER, INTENT(IN) :: source
27245 CLASS(mp_comm_type), INTENT(IN) :: comm
27246 INTEGER, INTENT(IN), OPTIONAL :: tag
27247
27248 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm3'
27249
27250 INTEGER :: handle
27251#if defined(__parallel)
27252 INTEGER :: ierr, msglen_in, msglen_out, &
27253 recv_tag, send_tag
27254#endif
27255
27256 CALL mp_timeset(routinen, handle)
27257
27258#if defined(__parallel)
27259 msglen_in = SIZE(msgin)
27260 msglen_out = SIZE(msgout)
27261 send_tag = 0 ! cannot think of something better here, this might be dangerous
27262 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27263 IF (PRESENT(tag)) THEN
27264 send_tag = tag
27265 recv_tag = tag
27266 END IF
27267 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27268 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27269 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27270 CALL add_perf(perf_id=7, count=1, &
27271 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27272#else
27273 mark_used(dest)
27274 mark_used(source)
27275 mark_used(comm)
27276 mark_used(tag)
27277 msgout = msgin
27278#endif
27279 CALL mp_timestop(handle)
27280 END SUBROUTINE mp_sendrecv_zm3
27281
27282! **************************************************************************************************
27283!> \brief Sends and receives rank-4 data
27284!> \param msgin ...
27285!> \param dest ...
27286!> \param msgout ...
27287!> \param source ...
27288!> \param comm ...
27289!> \note see mp_sendrecv_zv
27290! **************************************************************************************************
27291 SUBROUTINE mp_sendrecv_zm4(msgin, dest, msgout, source, comm, tag)
27292 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
27293 INTEGER, INTENT(IN) :: dest
27294 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
27295 INTEGER, INTENT(IN) :: source
27296 CLASS(mp_comm_type), INTENT(IN) :: comm
27297 INTEGER, INTENT(IN), OPTIONAL :: tag
27298
27299 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_zm4'
27300
27301 INTEGER :: handle
27302#if defined(__parallel)
27303 INTEGER :: ierr, msglen_in, msglen_out, &
27304 recv_tag, send_tag
27305#endif
27306
27307 CALL mp_timeset(routinen, handle)
27308
27309#if defined(__parallel)
27310 msglen_in = SIZE(msgin)
27311 msglen_out = SIZE(msgout)
27312 send_tag = 0 ! cannot think of something better here, this might be dangerous
27313 recv_tag = 0 ! cannot think of something better here, this might be dangerous
27314 IF (PRESENT(tag)) THEN
27315 send_tag = tag
27316 recv_tag = tag
27317 END IF
27318 CALL mpi_sendrecv(msgin, msglen_in, mpi_double_complex, dest, send_tag, msgout, &
27319 msglen_out, mpi_double_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
27320 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
27321 CALL add_perf(perf_id=7, count=1, &
27322 msg_size=(msglen_in + msglen_out)*(2*real_8_size)/2)
27323#else
27324 mark_used(dest)
27325 mark_used(source)
27326 mark_used(comm)
27327 mark_used(tag)
27328 msgout = msgin
27329#endif
27330 CALL mp_timestop(handle)
27331 END SUBROUTINE mp_sendrecv_zm4
27332
27333! **************************************************************************************************
27334!> \brief Non-blocking send and receive of a scalar
27335!> \param[in] msgin Scalar data to send
27336!> \param[in] dest Which process to send to
27337!> \param[out] msgout Receive data into this pointer
27338!> \param[in] source Process to receive from
27339!> \param[in] comm Message passing environment identifier
27340!> \param[out] send_request Request handle for the send
27341!> \param[out] recv_request Request handle for the receive
27342!> \param[in] tag (optional) tag to differentiate requests
27343!> \par Implementation
27344!> Calls mpi_isend and mpi_irecv.
27345!> \par History
27346!> 02.2005 created [Alfio Lazzaro]
27347! **************************************************************************************************
27348 SUBROUTINE mp_isendrecv_z (msgin, dest, msgout, source, comm, send_request, &
27349 recv_request, tag)
27350 COMPLEX(kind=real_8), INTENT(IN) :: msgin
27351 INTEGER, INTENT(IN) :: dest
27352 COMPLEX(kind=real_8), INTENT(INOUT) :: msgout
27353 INTEGER, INTENT(IN) :: source
27354 CLASS(mp_comm_type), INTENT(IN) :: comm
27355 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
27356 INTEGER, INTENT(in), OPTIONAL :: tag
27357
27358 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_z'
27359
27360 INTEGER :: handle
27361#if defined(__parallel)
27362 INTEGER :: ierr, my_tag
27363#endif
27364
27365 CALL mp_timeset(routinen, handle)
27366
27367#if defined(__parallel)
27368 my_tag = 0
27369 IF (PRESENT(tag)) my_tag = tag
27370
27371 CALL mpi_irecv(msgout, 1, mpi_double_complex, source, my_tag, &
27372 comm%handle, recv_request%handle, ierr)
27373 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27374
27375 CALL mpi_isend(msgin, 1, mpi_double_complex, dest, my_tag, &
27376 comm%handle, send_request%handle, ierr)
27377 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27378
27379 CALL add_perf(perf_id=8, count=1, msg_size=2*(2*real_8_size))
27380#else
27381 mark_used(dest)
27382 mark_used(source)
27383 mark_used(comm)
27384 mark_used(tag)
27385 send_request = mp_request_null
27386 recv_request = mp_request_null
27387 msgout = msgin
27388#endif
27389 CALL mp_timestop(handle)
27390 END SUBROUTINE mp_isendrecv_z
27391
27392! **************************************************************************************************
27393!> \brief Non-blocking send and receive of a vector
27394!> \param[in] msgin Vector data to send
27395!> \param[in] dest Which process to send to
27396!> \param[out] msgout Receive data into this pointer
27397!> \param[in] source Process to receive from
27398!> \param[in] comm Message passing environment identifier
27399!> \param[out] send_request Request handle for the send
27400!> \param[out] recv_request Request handle for the receive
27401!> \param[in] tag (optional) tag to differentiate requests
27402!> \par Implementation
27403!> Calls mpi_isend and mpi_irecv.
27404!> \par History
27405!> 11.2004 created [Joost VandeVondele]
27406!> \note
27407!> arrays can be pointers or assumed shape, but they must be contiguous!
27408! **************************************************************************************************
27409 SUBROUTINE mp_isendrecv_zv(msgin, dest, msgout, source, comm, send_request, &
27410 recv_request, tag)
27411 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
27412 INTEGER, INTENT(IN) :: dest
27413 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
27414 INTEGER, INTENT(IN) :: source
27415 CLASS(mp_comm_type), INTENT(IN) :: comm
27416 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
27417 INTEGER, INTENT(in), OPTIONAL :: tag
27418
27419 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_zv'
27420
27421 INTEGER :: handle
27422#if defined(__parallel)
27423 INTEGER :: ierr, msglen, my_tag
27424 COMPLEX(kind=real_8) :: foo
27425#endif
27426
27427 CALL mp_timeset(routinen, handle)
27428
27429#if defined(__parallel)
27430#if !defined(__GNUC__) || __GNUC__ >= 9
27431 cpassert(is_contiguous(msgout))
27432 cpassert(is_contiguous(msgin))
27433#endif
27434
27435 my_tag = 0
27436 IF (PRESENT(tag)) my_tag = tag
27437
27438 msglen = SIZE(msgout, 1)
27439 IF (msglen > 0) THEN
27440 CALL mpi_irecv(msgout(1), msglen, mpi_double_complex, source, my_tag, &
27441 comm%handle, recv_request%handle, ierr)
27442 ELSE
27443 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27444 comm%handle, recv_request%handle, ierr)
27445 END IF
27446 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27447
27448 msglen = SIZE(msgin, 1)
27449 IF (msglen > 0) THEN
27450 CALL mpi_isend(msgin(1), msglen, mpi_double_complex, dest, my_tag, &
27451 comm%handle, send_request%handle, ierr)
27452 ELSE
27453 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27454 comm%handle, send_request%handle, ierr)
27455 END IF
27456 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27457
27458 msglen = (msglen + SIZE(msgout, 1) + 1)/2
27459 CALL add_perf(perf_id=8, count=1, msg_size=msglen*(2*real_8_size))
27460#else
27461 mark_used(dest)
27462 mark_used(source)
27463 mark_used(comm)
27464 mark_used(tag)
27465 send_request = mp_request_null
27466 recv_request = mp_request_null
27467 msgout = msgin
27468#endif
27469 CALL mp_timestop(handle)
27470 END SUBROUTINE mp_isendrecv_zv
27471
27472! **************************************************************************************************
27473!> \brief Non-blocking send of vector data
27474!> \param msgin ...
27475!> \param dest ...
27476!> \param comm ...
27477!> \param request ...
27478!> \param tag ...
27479!> \par History
27480!> 08.2003 created [f&j]
27481!> \note see mp_isendrecv_zv
27482!> \note
27483!> arrays can be pointers or assumed shape, but they must be contiguous!
27484! **************************************************************************************************
27485 SUBROUTINE mp_isend_zv(msgin, dest, comm, request, tag)
27486 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: msgin
27487 INTEGER, INTENT(IN) :: dest
27488 CLASS(mp_comm_type), INTENT(IN) :: comm
27489 TYPE(mp_request_type), INTENT(out) :: request
27490 INTEGER, INTENT(in), OPTIONAL :: tag
27491
27492 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zv'
27493
27494 INTEGER :: handle, ierr
27495#if defined(__parallel)
27496 INTEGER :: msglen, my_tag
27497 COMPLEX(kind=real_8) :: foo(1)
27498#endif
27499
27500 CALL mp_timeset(routinen, handle)
27501
27502#if defined(__parallel)
27503#if !defined(__GNUC__) || __GNUC__ >= 9
27504 cpassert(is_contiguous(msgin))
27505#endif
27506 my_tag = 0
27507 IF (PRESENT(tag)) my_tag = tag
27508
27509 msglen = SIZE(msgin)
27510 IF (msglen > 0) THEN
27511 CALL mpi_isend(msgin(1), msglen, mpi_double_complex, dest, my_tag, &
27512 comm%handle, request%handle, ierr)
27513 ELSE
27514 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27515 comm%handle, request%handle, ierr)
27516 END IF
27517 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27518
27519 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27520#else
27521 mark_used(msgin)
27522 mark_used(dest)
27523 mark_used(comm)
27524 mark_used(request)
27525 mark_used(tag)
27526 ierr = 1
27527 request = mp_request_null
27528 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27529#endif
27530 CALL mp_timestop(handle)
27531 END SUBROUTINE mp_isend_zv
27532
27533! **************************************************************************************************
27534!> \brief Non-blocking send of matrix data
27535!> \param msgin ...
27536!> \param dest ...
27537!> \param comm ...
27538!> \param request ...
27539!> \param tag ...
27540!> \par History
27541!> 2009-11-25 [UB] Made type-generic for templates
27542!> \author fawzi
27543!> \note see mp_isendrecv_zv
27544!> \note see mp_isend_zv
27545!> \note
27546!> arrays can be pointers or assumed shape, but they must be contiguous!
27547! **************************************************************************************************
27548 SUBROUTINE mp_isend_zm2(msgin, dest, comm, request, tag)
27549 COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(IN) :: msgin
27550 INTEGER, INTENT(IN) :: dest
27551 CLASS(mp_comm_type), INTENT(IN) :: comm
27552 TYPE(mp_request_type), INTENT(out) :: request
27553 INTEGER, INTENT(in), OPTIONAL :: tag
27554
27555 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm2'
27556
27557 INTEGER :: handle, ierr
27558#if defined(__parallel)
27559 INTEGER :: msglen, my_tag
27560 COMPLEX(kind=real_8) :: foo(1)
27561#endif
27562
27563 CALL mp_timeset(routinen, handle)
27564
27565#if defined(__parallel)
27566#if !defined(__GNUC__) || __GNUC__ >= 9
27567 cpassert(is_contiguous(msgin))
27568#endif
27569
27570 my_tag = 0
27571 IF (PRESENT(tag)) my_tag = tag
27572
27573 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
27574 IF (msglen > 0) THEN
27575 CALL mpi_isend(msgin(1, 1), msglen, mpi_double_complex, dest, my_tag, &
27576 comm%handle, request%handle, ierr)
27577 ELSE
27578 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27579 comm%handle, request%handle, ierr)
27580 END IF
27581 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27582
27583 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27584#else
27585 mark_used(msgin)
27586 mark_used(dest)
27587 mark_used(comm)
27588 mark_used(request)
27589 mark_used(tag)
27590 ierr = 1
27591 request = mp_request_null
27592 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27593#endif
27594 CALL mp_timestop(handle)
27595 END SUBROUTINE mp_isend_zm2
27596
27597! **************************************************************************************************
27598!> \brief Non-blocking send of rank-3 data
27599!> \param msgin ...
27600!> \param dest ...
27601!> \param comm ...
27602!> \param request ...
27603!> \param tag ...
27604!> \par History
27605!> 9.2008 added _rm3 subroutine [Iain Bethune]
27606!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
27607!> 2009-11-25 [UB] Made type-generic for templates
27608!> \author fawzi
27609!> \note see mp_isendrecv_zv
27610!> \note see mp_isend_zv
27611!> \note
27612!> arrays can be pointers or assumed shape, but they must be contiguous!
27613! **************************************************************************************************
27614 SUBROUTINE mp_isend_zm3(msgin, dest, comm, request, tag)
27615 COMPLEX(kind=real_8), DIMENSION(:, :, :), INTENT(IN) :: msgin
27616 INTEGER, INTENT(IN) :: dest
27617 CLASS(mp_comm_type), INTENT(IN) :: comm
27618 TYPE(mp_request_type), INTENT(out) :: request
27619 INTEGER, INTENT(in), OPTIONAL :: tag
27620
27621 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm3'
27622
27623 INTEGER :: handle, ierr
27624#if defined(__parallel)
27625 INTEGER :: msglen, my_tag
27626 COMPLEX(kind=real_8) :: foo(1)
27627#endif
27628
27629 CALL mp_timeset(routinen, handle)
27630
27631#if defined(__parallel)
27632#if !defined(__GNUC__) || __GNUC__ >= 9
27633 cpassert(is_contiguous(msgin))
27634#endif
27635
27636 my_tag = 0
27637 IF (PRESENT(tag)) my_tag = tag
27638
27639 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
27640 IF (msglen > 0) THEN
27641 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_double_complex, dest, my_tag, &
27642 comm%handle, request%handle, ierr)
27643 ELSE
27644 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27645 comm%handle, request%handle, ierr)
27646 END IF
27647 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27648
27649 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27650#else
27651 mark_used(msgin)
27652 mark_used(dest)
27653 mark_used(comm)
27654 mark_used(request)
27655 mark_used(tag)
27656 ierr = 1
27657 request = mp_request_null
27658 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27659#endif
27660 CALL mp_timestop(handle)
27661 END SUBROUTINE mp_isend_zm3
27662
27663! **************************************************************************************************
27664!> \brief Non-blocking send of rank-4 data
27665!> \param msgin the input message
27666!> \param dest the destination processor
27667!> \param comm the communicator object
27668!> \param request the communication request id
27669!> \param tag the message tag
27670!> \par History
27671!> 2.2016 added _zm4 subroutine [Nico Holmberg]
27672!> \author fawzi
27673!> \note see mp_isend_zv
27674!> \note
27675!> arrays can be pointers or assumed shape, but they must be contiguous!
27676! **************************************************************************************************
27677 SUBROUTINE mp_isend_zm4(msgin, dest, comm, request, tag)
27678 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
27679 INTEGER, INTENT(IN) :: dest
27680 CLASS(mp_comm_type), INTENT(IN) :: comm
27681 TYPE(mp_request_type), INTENT(out) :: request
27682 INTEGER, INTENT(in), OPTIONAL :: tag
27683
27684 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_zm4'
27685
27686 INTEGER :: handle, ierr
27687#if defined(__parallel)
27688 INTEGER :: msglen, my_tag
27689 COMPLEX(kind=real_8) :: foo(1)
27690#endif
27691
27692 CALL mp_timeset(routinen, handle)
27693
27694#if defined(__parallel)
27695#if !defined(__GNUC__) || __GNUC__ >= 9
27696 cpassert(is_contiguous(msgin))
27697#endif
27698
27699 my_tag = 0
27700 IF (PRESENT(tag)) my_tag = tag
27701
27702 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
27703 IF (msglen > 0) THEN
27704 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_double_complex, dest, my_tag, &
27705 comm%handle, request%handle, ierr)
27706 ELSE
27707 CALL mpi_isend(foo, msglen, mpi_double_complex, dest, my_tag, &
27708 comm%handle, request%handle, ierr)
27709 END IF
27710 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
27711
27712 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_8_size))
27713#else
27714 mark_used(msgin)
27715 mark_used(dest)
27716 mark_used(comm)
27717 mark_used(request)
27718 mark_used(tag)
27719 ierr = 1
27720 request = mp_request_null
27721 CALL mp_stop(ierr, "mp_isend called in non parallel case")
27722#endif
27723 CALL mp_timestop(handle)
27724 END SUBROUTINE mp_isend_zm4
27725
27726! **************************************************************************************************
27727!> \brief Non-blocking receive of vector data
27728!> \param msgout ...
27729!> \param source ...
27730!> \param comm ...
27731!> \param request ...
27732!> \param tag ...
27733!> \par History
27734!> 08.2003 created [f&j]
27735!> 2009-11-25 [UB] Made type-generic for templates
27736!> \note see mp_isendrecv_zv
27737!> \note
27738!> arrays can be pointers or assumed shape, but they must be contiguous!
27739! **************************************************************************************************
27740 SUBROUTINE mp_irecv_zv(msgout, source, comm, request, tag)
27741 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT) :: msgout
27742 INTEGER, INTENT(IN) :: source
27743 CLASS(mp_comm_type), INTENT(IN) :: comm
27744 TYPE(mp_request_type), INTENT(out) :: request
27745 INTEGER, INTENT(in), OPTIONAL :: tag
27746
27747 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zv'
27748
27749 INTEGER :: handle
27750#if defined(__parallel)
27751 INTEGER :: ierr, msglen, my_tag
27752 COMPLEX(kind=real_8) :: foo(1)
27753#endif
27754
27755 CALL mp_timeset(routinen, handle)
27756
27757#if defined(__parallel)
27758#if !defined(__GNUC__) || __GNUC__ >= 9
27759 cpassert(is_contiguous(msgout))
27760#endif
27761
27762 my_tag = 0
27763 IF (PRESENT(tag)) my_tag = tag
27764
27765 msglen = SIZE(msgout)
27766 IF (msglen > 0) THEN
27767 CALL mpi_irecv(msgout(1), msglen, mpi_double_complex, source, my_tag, &
27768 comm%handle, request%handle, ierr)
27769 ELSE
27770 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27771 comm%handle, request%handle, ierr)
27772 END IF
27773 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27774
27775 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27776#else
27777 cpabort("mp_irecv called in non parallel case")
27778 mark_used(msgout)
27779 mark_used(source)
27780 mark_used(comm)
27781 mark_used(tag)
27782 request = mp_request_null
27783#endif
27784 CALL mp_timestop(handle)
27785 END SUBROUTINE mp_irecv_zv
27786
27787! **************************************************************************************************
27788!> \brief Non-blocking receive of matrix data
27789!> \param msgout ...
27790!> \param source ...
27791!> \param comm ...
27792!> \param request ...
27793!> \param tag ...
27794!> \par History
27795!> 2009-11-25 [UB] Made type-generic for templates
27796!> \author fawzi
27797!> \note see mp_isendrecv_zv
27798!> \note see mp_irecv_zv
27799!> \note
27800!> arrays can be pointers or assumed shape, but they must be contiguous!
27801! **************************************************************************************************
27802 SUBROUTINE mp_irecv_zm2(msgout, source, comm, request, tag)
27803 COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(INOUT) :: msgout
27804 INTEGER, INTENT(IN) :: source
27805 CLASS(mp_comm_type), INTENT(IN) :: comm
27806 TYPE(mp_request_type), INTENT(out) :: request
27807 INTEGER, INTENT(in), OPTIONAL :: tag
27808
27809 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm2'
27810
27811 INTEGER :: handle
27812#if defined(__parallel)
27813 INTEGER :: ierr, msglen, my_tag
27814 COMPLEX(kind=real_8) :: foo(1)
27815#endif
27816
27817 CALL mp_timeset(routinen, handle)
27818
27819#if defined(__parallel)
27820#if !defined(__GNUC__) || __GNUC__ >= 9
27821 cpassert(is_contiguous(msgout))
27822#endif
27823
27824 my_tag = 0
27825 IF (PRESENT(tag)) my_tag = tag
27826
27827 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
27828 IF (msglen > 0) THEN
27829 CALL mpi_irecv(msgout(1, 1), msglen, mpi_double_complex, source, my_tag, &
27830 comm%handle, request%handle, ierr)
27831 ELSE
27832 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27833 comm%handle, request%handle, ierr)
27834 END IF
27835 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
27836
27837 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27838#else
27839 mark_used(msgout)
27840 mark_used(source)
27841 mark_used(comm)
27842 mark_used(tag)
27843 request = mp_request_null
27844 cpabort("mp_irecv called in non parallel case")
27845#endif
27846 CALL mp_timestop(handle)
27847 END SUBROUTINE mp_irecv_zm2
27848
27849! **************************************************************************************************
27850!> \brief Non-blocking send of rank-3 data
27851!> \param msgout ...
27852!> \param source ...
27853!> \param comm ...
27854!> \param request ...
27855!> \param tag ...
27856!> \par History
27857!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
27858!> 2009-11-25 [UB] Made type-generic for templates
27859!> \author fawzi
27860!> \note see mp_isendrecv_zv
27861!> \note see mp_irecv_zv
27862!> \note
27863!> arrays can be pointers or assumed shape, but they must be contiguous!
27864! **************************************************************************************************
27865 SUBROUTINE mp_irecv_zm3(msgout, source, comm, request, tag)
27866 COMPLEX(kind=real_8), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
27867 INTEGER, INTENT(IN) :: source
27868 CLASS(mp_comm_type), INTENT(IN) :: comm
27869 TYPE(mp_request_type), INTENT(out) :: request
27870 INTEGER, INTENT(in), OPTIONAL :: tag
27871
27872 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm3'
27873
27874 INTEGER :: handle
27875#if defined(__parallel)
27876 INTEGER :: ierr, msglen, my_tag
27877 COMPLEX(kind=real_8) :: foo(1)
27878#endif
27879
27880 CALL mp_timeset(routinen, handle)
27881
27882#if defined(__parallel)
27883#if !defined(__GNUC__) || __GNUC__ >= 9
27884 cpassert(is_contiguous(msgout))
27885#endif
27886
27887 my_tag = 0
27888 IF (PRESENT(tag)) my_tag = tag
27889
27890 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
27891 IF (msglen > 0) THEN
27892 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_double_complex, source, my_tag, &
27893 comm%handle, request%handle, ierr)
27894 ELSE
27895 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27896 comm%handle, request%handle, ierr)
27897 END IF
27898 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
27899
27900 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27901#else
27902 mark_used(msgout)
27903 mark_used(source)
27904 mark_used(comm)
27905 mark_used(tag)
27906 request = mp_request_null
27907 cpabort("mp_irecv called in non parallel case")
27908#endif
27909 CALL mp_timestop(handle)
27910 END SUBROUTINE mp_irecv_zm3
27911
27912! **************************************************************************************************
27913!> \brief Non-blocking receive of rank-4 data
27914!> \param msgout the output message
27915!> \param source the source processor
27916!> \param comm the communicator object
27917!> \param request the communication request id
27918!> \param tag the message tag
27919!> \par History
27920!> 2.2016 added _zm4 subroutine [Nico Holmberg]
27921!> \author fawzi
27922!> \note see mp_irecv_zv
27923!> \note
27924!> arrays can be pointers or assumed shape, but they must be contiguous!
27925! **************************************************************************************************
27926 SUBROUTINE mp_irecv_zm4(msgout, source, comm, request, tag)
27927 COMPLEX(kind=real_8), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
27928 INTEGER, INTENT(IN) :: source
27929 CLASS(mp_comm_type), INTENT(IN) :: comm
27930 TYPE(mp_request_type), INTENT(out) :: request
27931 INTEGER, INTENT(in), OPTIONAL :: tag
27932
27933 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_zm4'
27934
27935 INTEGER :: handle
27936#if defined(__parallel)
27937 INTEGER :: ierr, msglen, my_tag
27938 COMPLEX(kind=real_8) :: foo(1)
27939#endif
27940
27941 CALL mp_timeset(routinen, handle)
27942
27943#if defined(__parallel)
27944#if !defined(__GNUC__) || __GNUC__ >= 9
27945 cpassert(is_contiguous(msgout))
27946#endif
27947
27948 my_tag = 0
27949 IF (PRESENT(tag)) my_tag = tag
27950
27951 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
27952 IF (msglen > 0) THEN
27953 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_double_complex, source, my_tag, &
27954 comm%handle, request%handle, ierr)
27955 ELSE
27956 CALL mpi_irecv(foo, msglen, mpi_double_complex, source, my_tag, &
27957 comm%handle, request%handle, ierr)
27958 END IF
27959 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
27960
27961 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_8_size))
27962#else
27963 mark_used(msgout)
27964 mark_used(source)
27965 mark_used(comm)
27966 mark_used(tag)
27967 request = mp_request_null
27968 cpabort("mp_irecv called in non parallel case")
27969#endif
27970 CALL mp_timestop(handle)
27971 END SUBROUTINE mp_irecv_zm4
27972
27973! **************************************************************************************************
27974!> \brief Window initialization function for vector data
27975!> \param base ...
27976!> \param comm ...
27977!> \param win ...
27978!> \par History
27979!> 02.2015 created [Alfio Lazzaro]
27980!> \note
27981!> arrays can be pointers or assumed shape, but they must be contiguous!
27982! **************************************************************************************************
27983 SUBROUTINE mp_win_create_zv(base, comm, win)
27984 COMPLEX(kind=real_8), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
27985 TYPE(mp_comm_type), INTENT(IN) :: comm
27986 CLASS(mp_win_type), INTENT(INOUT) :: win
27987
27988 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_zv'
27989
27990 INTEGER :: handle
27991#if defined(__parallel)
27992 INTEGER :: ierr
27993 INTEGER(kind=mpi_address_kind) :: len
27994 COMPLEX(kind=real_8) :: foo(1)
27995#endif
27996
27997 CALL mp_timeset(routinen, handle)
27998
27999#if defined(__parallel)
28000
28001 len = SIZE(base)*(2*real_8_size)
28002 IF (len > 0) THEN
28003 CALL mpi_win_create(base(1), len, (2*real_8_size), mpi_info_null, comm%handle, win%handle, ierr)
28004 ELSE
28005 CALL mpi_win_create(foo, len, (2*real_8_size), mpi_info_null, comm%handle, win%handle, ierr)
28006 END IF
28007 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
28008
28009 CALL add_perf(perf_id=20, count=1)
28010#else
28011 mark_used(base)
28012 mark_used(comm)
28013 win%handle = mp_win_null_handle
28014#endif
28015 CALL mp_timestop(handle)
28016 END SUBROUTINE mp_win_create_zv
28017
28018! **************************************************************************************************
28019!> \brief Single-sided get function for vector data
28020!> \param base ...
28021!> \param comm ...
28022!> \param win ...
28023!> \par History
28024!> 02.2015 created [Alfio Lazzaro]
28025!> \note
28026!> arrays can be pointers or assumed shape, but they must be contiguous!
28027! **************************************************************************************************
28028 SUBROUTINE mp_rget_zv(base, source, win, win_data, myproc, disp, request, &
28029 origin_datatype, target_datatype)
28030 COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
28031 INTEGER, INTENT(IN) :: source
28032 CLASS(mp_win_type), INTENT(IN) :: win
28033 COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN) :: win_data
28034 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
28035 TYPE(mp_request_type), INTENT(OUT) :: request
28036 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
28037
28038 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_zv'
28039
28040 INTEGER :: handle
28041#if defined(__parallel)
28042 INTEGER :: ierr, len, &
28043 origin_len, target_len
28044 LOGICAL :: do_local_copy
28045 INTEGER(kind=mpi_address_kind) :: disp_aint
28046 mpi_data_type :: handle_origin_datatype, handle_target_datatype
28047#endif
28048
28049 CALL mp_timeset(routinen, handle)
28050
28051#if defined(__parallel)
28052 len = SIZE(base)
28053 disp_aint = 0
28054 IF (PRESENT(disp)) THEN
28055 disp_aint = int(disp, kind=mpi_address_kind)
28056 END IF
28057 handle_origin_datatype = mpi_double_complex
28058 origin_len = len
28059 IF (PRESENT(origin_datatype)) THEN
28060 handle_origin_datatype = origin_datatype%type_handle
28061 origin_len = 1
28062 END IF
28063 handle_target_datatype = mpi_double_complex
28064 target_len = len
28065 IF (PRESENT(target_datatype)) THEN
28066 handle_target_datatype = target_datatype%type_handle
28067 target_len = 1
28068 END IF
28069 IF (len > 0) THEN
28070 do_local_copy = .false.
28071 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
28072 IF (myproc .EQ. source) do_local_copy = .true.
28073 END IF
28074 IF (do_local_copy) THEN
28075 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
28076 base(:) = win_data(disp_aint + 1:disp_aint + len)
28077 !$OMP END PARALLEL WORKSHARE
28078 request = mp_request_null
28079 ierr = 0
28080 ELSE
28081 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
28082 target_len, handle_target_datatype, win%handle, request%handle, ierr)
28083 END IF
28084 ELSE
28085 request = mp_request_null
28086 ierr = 0
28087 END IF
28088 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
28089
28090 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*(2*real_8_size))
28091#else
28092 mark_used(source)
28093 mark_used(win)
28094 mark_used(myproc)
28095 mark_used(origin_datatype)
28096 mark_used(target_datatype)
28097
28098 request = mp_request_null
28099 !
28100 IF (PRESENT(disp)) THEN
28101 base(:) = win_data(disp + 1:disp + SIZE(base))
28102 ELSE
28103 base(:) = win_data(:SIZE(base))
28104 END IF
28105
28106#endif
28107 CALL mp_timestop(handle)
28108 END SUBROUTINE mp_rget_zv
28109
28110! **************************************************************************************************
28111!> \brief ...
28112!> \param count ...
28113!> \param lengths ...
28114!> \param displs ...
28115!> \return ...
28116! ***************************************************************************
28117 FUNCTION mp_type_indexed_make_z (count, lengths, displs) &
28118 result(type_descriptor)
28119 INTEGER, INTENT(IN) :: count
28120 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
28121 TYPE(mp_type_descriptor_type) :: type_descriptor
28122
28123 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_z'
28124
28125 INTEGER :: handle
28126#if defined(__parallel)
28127 INTEGER :: ierr
28128#endif
28129
28130 CALL mp_timeset(routinen, handle)
28131
28132#if defined(__parallel)
28133 CALL mpi_type_indexed(count, lengths, displs, mpi_double_complex, &
28134 type_descriptor%type_handle, ierr)
28135 IF (ierr /= 0) &
28136 cpabort("MPI_Type_Indexed @ "//routinen)
28137 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
28138 IF (ierr /= 0) &
28139 cpabort("MPI_Type_commit @ "//routinen)
28140#else
28141 type_descriptor%type_handle = 7
28142#endif
28143 type_descriptor%length = count
28144 NULLIFY (type_descriptor%subtype)
28145 type_descriptor%vector_descriptor(1:2) = 1
28146 type_descriptor%has_indexing = .true.
28147 type_descriptor%index_descriptor%index => lengths
28148 type_descriptor%index_descriptor%chunks => displs
28149
28150 CALL mp_timestop(handle)
28151
28152 END FUNCTION mp_type_indexed_make_z
28153
28154! **************************************************************************************************
28155!> \brief Allocates special parallel memory
28156!> \param[in] DATA pointer to integer array to allocate
28157!> \param[in] len number of integers to allocate
28158!> \param[out] stat (optional) allocation status result
28159!> \author UB
28160! **************************************************************************************************
28161 SUBROUTINE mp_allocate_z (DATA, len, stat)
28162 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
28163 INTEGER, INTENT(IN) :: len
28164 INTEGER, INTENT(OUT), OPTIONAL :: stat
28165
28166 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_z'
28167
28168 INTEGER :: handle, ierr
28169
28170 CALL mp_timeset(routinen, handle)
28171
28172#if defined(__parallel)
28173 NULLIFY (data)
28174 CALL mp_alloc_mem(DATA, len, stat=ierr)
28175 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
28176 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
28177 CALL add_perf(perf_id=15, count=1)
28178#else
28179 ALLOCATE (DATA(len), stat=ierr)
28180 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
28181 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
28182#endif
28183 IF (PRESENT(stat)) stat = ierr
28184 CALL mp_timestop(handle)
28185 END SUBROUTINE mp_allocate_z
28186
28187! **************************************************************************************************
28188!> \brief Deallocates special parallel memory
28189!> \param[in] DATA pointer to special memory to deallocate
28190!> \param stat ...
28191!> \author UB
28192! **************************************************************************************************
28193 SUBROUTINE mp_deallocate_z (DATA, stat)
28194 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
28195 INTEGER, INTENT(OUT), OPTIONAL :: stat
28196
28197 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_z'
28198
28199 INTEGER :: handle
28200#if defined(__parallel)
28201 INTEGER :: ierr
28202#endif
28203
28204 CALL mp_timeset(routinen, handle)
28205
28206#if defined(__parallel)
28207 CALL mp_free_mem(DATA, ierr)
28208 IF (PRESENT(stat)) THEN
28209 stat = ierr
28210 ELSE
28211 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
28212 END IF
28213 NULLIFY (data)
28214 CALL add_perf(perf_id=15, count=1)
28215#else
28216 DEALLOCATE (data)
28217 IF (PRESENT(stat)) stat = 0
28218#endif
28219 CALL mp_timestop(handle)
28220 END SUBROUTINE mp_deallocate_z
28221
28222! **************************************************************************************************
28223!> \brief (parallel) Blocking individual file write using explicit offsets
28224!> (serial) Unformatted stream write
28225!> \param[in] fh file handle (file storage unit)
28226!> \param[in] offset file offset (position)
28227!> \param[in] msg data to be written to the file
28228!> \param msglen ...
28229!> \par MPI-I/O mapping mpi_file_write_at
28230!> \par STREAM-I/O mapping WRITE
28231!> \param[in](optional) msglen number of the elements of data
28232! **************************************************************************************************
28233 SUBROUTINE mp_file_write_at_zv(fh, offset, msg, msglen)
28234 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
28235 CLASS(mp_file_type), INTENT(IN) :: fh
28236 INTEGER, INTENT(IN), OPTIONAL :: msglen
28237 INTEGER(kind=file_offset), INTENT(IN) :: offset
28238
28239 INTEGER :: msg_len
28240#if defined(__parallel)
28241 INTEGER :: ierr
28242#endif
28243
28244 msg_len = SIZE(msg)
28245 IF (PRESENT(msglen)) msg_len = msglen
28246#if defined(__parallel)
28247 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28248 IF (ierr .NE. 0) &
28249 cpabort("mpi_file_write_at_zv @ mp_file_write_at_zv")
28250#else
28251 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28252#endif
28253 END SUBROUTINE mp_file_write_at_zv
28254
28255! **************************************************************************************************
28256!> \brief ...
28257!> \param fh ...
28258!> \param offset ...
28259!> \param msg ...
28260! **************************************************************************************************
28261 SUBROUTINE mp_file_write_at_z (fh, offset, msg)
28262 COMPLEX(kind=real_8), INTENT(IN) :: msg
28263 CLASS(mp_file_type), INTENT(IN) :: fh
28264 INTEGER(kind=file_offset), INTENT(IN) :: offset
28265
28266#if defined(__parallel)
28267 INTEGER :: ierr
28268
28269 ierr = 0
28270 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28271 IF (ierr .NE. 0) &
28272 cpabort("mpi_file_write_at_z @ mp_file_write_at_z")
28273#else
28274 WRITE (unit=fh%handle, pos=offset + 1) msg
28275#endif
28276 END SUBROUTINE mp_file_write_at_z
28277
28278! **************************************************************************************************
28279!> \brief (parallel) Blocking collective file write using explicit offsets
28280!> (serial) Unformatted stream write
28281!> \param fh ...
28282!> \param offset ...
28283!> \param msg ...
28284!> \param msglen ...
28285!> \par MPI-I/O mapping mpi_file_write_at_all
28286!> \par STREAM-I/O mapping WRITE
28287! **************************************************************************************************
28288 SUBROUTINE mp_file_write_at_all_zv(fh, offset, msg, msglen)
28289 COMPLEX(kind=real_8), CONTIGUOUS, INTENT(IN) :: msg(:)
28290 CLASS(mp_file_type), INTENT(IN) :: fh
28291 INTEGER, INTENT(IN), OPTIONAL :: msglen
28292 INTEGER(kind=file_offset), INTENT(IN) :: offset
28293
28294 INTEGER :: msg_len
28295#if defined(__parallel)
28296 INTEGER :: ierr
28297#endif
28298
28299 msg_len = SIZE(msg)
28300 IF (PRESENT(msglen)) msg_len = msglen
28301#if defined(__parallel)
28302 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28303 IF (ierr .NE. 0) &
28304 cpabort("mpi_file_write_at_all_zv @ mp_file_write_at_all_zv")
28305#else
28306 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28307#endif
28308 END SUBROUTINE mp_file_write_at_all_zv
28309
28310! **************************************************************************************************
28311!> \brief ...
28312!> \param fh ...
28313!> \param offset ...
28314!> \param msg ...
28315! **************************************************************************************************
28316 SUBROUTINE mp_file_write_at_all_z (fh, offset, msg)
28317 COMPLEX(kind=real_8), INTENT(IN) :: msg
28318 CLASS(mp_file_type), INTENT(IN) :: fh
28319 INTEGER(kind=file_offset), INTENT(IN) :: offset
28320
28321#if defined(__parallel)
28322 INTEGER :: ierr
28323
28324 ierr = 0
28325 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28326 IF (ierr .NE. 0) &
28327 cpabort("mpi_file_write_at_all_z @ mp_file_write_at_all_z")
28328#else
28329 WRITE (unit=fh%handle, pos=offset + 1) msg
28330#endif
28331 END SUBROUTINE mp_file_write_at_all_z
28332
28333! **************************************************************************************************
28334!> \brief (parallel) Blocking individual file read using explicit offsets
28335!> (serial) Unformatted stream read
28336!> \param[in] fh file handle (file storage unit)
28337!> \param[in] offset file offset (position)
28338!> \param[out] msg data to be read from the file
28339!> \param msglen ...
28340!> \par MPI-I/O mapping mpi_file_read_at
28341!> \par STREAM-I/O mapping READ
28342!> \param[in](optional) msglen number of elements of data
28343! **************************************************************************************************
28344 SUBROUTINE mp_file_read_at_zv(fh, offset, msg, msglen)
28345 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
28346 CLASS(mp_file_type), INTENT(IN) :: fh
28347 INTEGER, INTENT(IN), OPTIONAL :: msglen
28348 INTEGER(kind=file_offset), INTENT(IN) :: offset
28349
28350 INTEGER :: msg_len
28351#if defined(__parallel)
28352 INTEGER :: ierr
28353#endif
28354
28355 msg_len = SIZE(msg)
28356 IF (PRESENT(msglen)) msg_len = msglen
28357#if defined(__parallel)
28358 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28359 IF (ierr .NE. 0) &
28360 cpabort("mpi_file_read_at_zv @ mp_file_read_at_zv")
28361#else
28362 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28363#endif
28364 END SUBROUTINE mp_file_read_at_zv
28365
28366! **************************************************************************************************
28367!> \brief ...
28368!> \param fh ...
28369!> \param offset ...
28370!> \param msg ...
28371! **************************************************************************************************
28372 SUBROUTINE mp_file_read_at_z (fh, offset, msg)
28373 COMPLEX(kind=real_8), INTENT(OUT) :: msg
28374 CLASS(mp_file_type), INTENT(IN) :: fh
28375 INTEGER(kind=file_offset), INTENT(IN) :: offset
28376
28377#if defined(__parallel)
28378 INTEGER :: ierr
28379
28380 ierr = 0
28381 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28382 IF (ierr .NE. 0) &
28383 cpabort("mpi_file_read_at_z @ mp_file_read_at_z")
28384#else
28385 READ (unit=fh%handle, pos=offset + 1) msg
28386#endif
28387 END SUBROUTINE mp_file_read_at_z
28388
28389! **************************************************************************************************
28390!> \brief (parallel) Blocking collective file read using explicit offsets
28391!> (serial) Unformatted stream read
28392!> \param fh ...
28393!> \param offset ...
28394!> \param msg ...
28395!> \param msglen ...
28396!> \par MPI-I/O mapping mpi_file_read_at_all
28397!> \par STREAM-I/O mapping READ
28398! **************************************************************************************************
28399 SUBROUTINE mp_file_read_at_all_zv(fh, offset, msg, msglen)
28400 COMPLEX(kind=real_8), INTENT(OUT), CONTIGUOUS :: msg(:)
28401 CLASS(mp_file_type), INTENT(IN) :: fh
28402 INTEGER, INTENT(IN), OPTIONAL :: msglen
28403 INTEGER(kind=file_offset), INTENT(IN) :: offset
28404
28405 INTEGER :: msg_len
28406#if defined(__parallel)
28407 INTEGER :: ierr
28408#endif
28409
28410 msg_len = SIZE(msg)
28411 IF (PRESENT(msglen)) msg_len = msglen
28412#if defined(__parallel)
28413 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_double_complex, mpi_status_ignore, ierr)
28414 IF (ierr .NE. 0) &
28415 cpabort("mpi_file_read_at_all_zv @ mp_file_read_at_all_zv")
28416#else
28417 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
28418#endif
28419 END SUBROUTINE mp_file_read_at_all_zv
28420
28421! **************************************************************************************************
28422!> \brief ...
28423!> \param fh ...
28424!> \param offset ...
28425!> \param msg ...
28426! **************************************************************************************************
28427 SUBROUTINE mp_file_read_at_all_z (fh, offset, msg)
28428 COMPLEX(kind=real_8), INTENT(OUT) :: msg
28429 CLASS(mp_file_type), INTENT(IN) :: fh
28430 INTEGER(kind=file_offset), INTENT(IN) :: offset
28431
28432#if defined(__parallel)
28433 INTEGER :: ierr
28434
28435 ierr = 0
28436 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_double_complex, mpi_status_ignore, ierr)
28437 IF (ierr .NE. 0) &
28438 cpabort("mpi_file_read_at_all_z @ mp_file_read_at_all_z")
28439#else
28440 READ (unit=fh%handle, pos=offset + 1) msg
28441#endif
28442 END SUBROUTINE mp_file_read_at_all_z
28443
28444! **************************************************************************************************
28445!> \brief ...
28446!> \param ptr ...
28447!> \param vector_descriptor ...
28448!> \param index_descriptor ...
28449!> \return ...
28450! **************************************************************************************************
28451 FUNCTION mp_type_make_z (ptr, &
28452 vector_descriptor, index_descriptor) &
28453 result(type_descriptor)
28454 COMPLEX(kind=real_8), DIMENSION(:), TARGET, asynchronous :: ptr
28455 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
28456 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
28457 TYPE(mp_type_descriptor_type) :: type_descriptor
28458
28459 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_z'
28460
28461#if defined(__parallel)
28462 INTEGER :: ierr
28463#endif
28464
28465 NULLIFY (type_descriptor%subtype)
28466 type_descriptor%length = SIZE(ptr)
28467#if defined(__parallel)
28468 type_descriptor%type_handle = mpi_double_complex
28469 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
28470 IF (ierr /= 0) &
28471 cpabort("MPI_Get_address @ "//routinen)
28472#else
28473 type_descriptor%type_handle = 7
28474#endif
28475 type_descriptor%vector_descriptor(1:2) = 1
28476 type_descriptor%has_indexing = .false.
28477 type_descriptor%data_z => ptr
28478 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
28479 cpabort(routinen//": Vectors and indices NYI")
28480 END IF
28481 END FUNCTION mp_type_make_z
28482
28483! **************************************************************************************************
28484!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
28485!> as the Fortran version returns an integer, which we take to be a C_PTR
28486!> \param DATA data array to allocate
28487!> \param[in] len length (in data elements) of data array allocation
28488!> \param[out] stat (optional) allocation status result
28489! **************************************************************************************************
28490 SUBROUTINE mp_alloc_mem_z (DATA, len, stat)
28491 COMPLEX(kind=real_8), CONTIGUOUS, DIMENSION(:), POINTER :: data
28492 INTEGER, INTENT(IN) :: len
28493 INTEGER, INTENT(OUT), OPTIONAL :: stat
28494
28495#if defined(__parallel)
28496 INTEGER :: size, ierr, length, &
28497 mp_res
28498 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
28499 TYPE(c_ptr) :: mp_baseptr
28500 mpi_info_type :: mp_info
28501
28502 length = max(len, 1)
28503 CALL mpi_type_size(mpi_double_complex, size, ierr)
28504 mp_size = int(length, kind=mpi_address_kind)*size
28505 IF (mp_size .GT. mp_max_memory_size) THEN
28506 cpabort("MPI cannot allocate more than 2 GiByte")
28507 END IF
28508 mp_info = mpi_info_null
28509 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
28510 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
28511 IF (PRESENT(stat)) stat = mp_res
28512#else
28513 INTEGER :: length, mystat
28514 length = max(len, 1)
28515 IF (PRESENT(stat)) THEN
28516 ALLOCATE (DATA(length), stat=mystat)
28517 stat = mystat ! show to convention checker that stat is used
28518 ELSE
28519 ALLOCATE (DATA(length))
28520 END IF
28521#endif
28522 END SUBROUTINE mp_alloc_mem_z
28523
28524! **************************************************************************************************
28525!> \brief Deallocates am array, ... this is hackish
28526!> as the Fortran version takes an integer, which we hope to get by reference
28527!> \param DATA data array to allocate
28528!> \param[out] stat (optional) allocation status result
28529! **************************************************************************************************
28530 SUBROUTINE mp_free_mem_z (DATA, stat)
28531 COMPLEX(kind=real_8), DIMENSION(:), &
28532 POINTER, asynchronous :: data
28533 INTEGER, INTENT(OUT), OPTIONAL :: stat
28534
28535#if defined(__parallel)
28536 INTEGER :: mp_res
28537 CALL mpi_free_mem(DATA, mp_res)
28538 IF (PRESENT(stat)) stat = mp_res
28539#else
28540 DEALLOCATE (data)
28541 IF (PRESENT(stat)) stat = 0
28542#endif
28543 END SUBROUTINE mp_free_mem_z
28544! **************************************************************************************************
28545!> \brief Shift around the data in msg
28546!> \param[in,out] msg Rank-2 data to shift
28547!> \param[in] comm message passing environment identifier
28548!> \param[in] displ_in displacements (?)
28549!> \par Example
28550!> msg will be moved from rank to rank+displ_in (in a circular way)
28551!> \par Limitations
28552!> * displ_in will be 1 by default (others not tested)
28553!> * the message array needs to be the same size on all processes
28554! **************************************************************************************************
28555 SUBROUTINE mp_shift_cm(msg, comm, displ_in)
28556
28557 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
28558 CLASS(mp_comm_type), INTENT(IN) :: comm
28559 INTEGER, INTENT(IN), OPTIONAL :: displ_in
28560
28561 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_cm'
28562
28563 INTEGER :: handle, ierror
28564#if defined(__parallel)
28565 INTEGER :: displ, left, &
28566 msglen, myrank, nprocs, &
28567 right, tag
28568#endif
28569
28570 ierror = 0
28571 CALL mp_timeset(routinen, handle)
28572
28573#if defined(__parallel)
28574 CALL mpi_comm_rank(comm%handle, myrank, ierror)
28575 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
28576 CALL mpi_comm_size(comm%handle, nprocs, ierror)
28577 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
28578 IF (PRESENT(displ_in)) THEN
28579 displ = displ_in
28580 ELSE
28581 displ = 1
28582 END IF
28583 right = modulo(myrank + displ, nprocs)
28584 left = modulo(myrank - displ, nprocs)
28585 tag = 17
28586 msglen = SIZE(msg)
28587 CALL mpi_sendrecv_replace(msg, msglen, mpi_complex, right, tag, left, tag, &
28588 comm%handle, mpi_status_ignore, ierror)
28589 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
28590 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_4_size))
28591#else
28592 mark_used(msg)
28593 mark_used(comm)
28594 mark_used(displ_in)
28595#endif
28596 CALL mp_timestop(handle)
28597
28598 END SUBROUTINE mp_shift_cm
28599
28600! **************************************************************************************************
28601!> \brief Shift around the data in msg
28602!> \param[in,out] msg Data to shift
28603!> \param[in] comm message passing environment identifier
28604!> \param[in] displ_in displacements (?)
28605!> \par Example
28606!> msg will be moved from rank to rank+displ_in (in a circular way)
28607!> \par Limitations
28608!> * displ_in will be 1 by default (others not tested)
28609!> * the message array needs to be the same size on all processes
28610! **************************************************************************************************
28611 SUBROUTINE mp_shift_c (msg, comm, displ_in)
28612
28613 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
28614 CLASS(mp_comm_type), INTENT(IN) :: comm
28615 INTEGER, INTENT(IN), OPTIONAL :: displ_in
28616
28617 CHARACTER(len=*), PARAMETER :: routinen = 'mp_shift_c'
28618
28619 INTEGER :: handle, ierror
28620#if defined(__parallel)
28621 INTEGER :: displ, left, &
28622 msglen, myrank, nprocs, &
28623 right, tag
28624#endif
28625
28626 ierror = 0
28627 CALL mp_timeset(routinen, handle)
28628
28629#if defined(__parallel)
28630 CALL mpi_comm_rank(comm%handle, myrank, ierror)
28631 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routinen)
28632 CALL mpi_comm_size(comm%handle, nprocs, ierror)
28633 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routinen)
28634 IF (PRESENT(displ_in)) THEN
28635 displ = displ_in
28636 ELSE
28637 displ = 1
28638 END IF
28639 right = modulo(myrank + displ, nprocs)
28640 left = modulo(myrank - displ, nprocs)
28641 tag = 19
28642 msglen = SIZE(msg)
28643 CALL mpi_sendrecv_replace(msg, msglen, mpi_complex, right, tag, left, &
28644 tag, comm%handle, mpi_status_ignore, ierror)
28645 IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routinen)
28646 CALL add_perf(perf_id=7, count=1, msg_size=msglen*(2*real_4_size))
28647#else
28648 mark_used(msg)
28649 mark_used(comm)
28650 mark_used(displ_in)
28651#endif
28652 CALL mp_timestop(handle)
28653
28654 END SUBROUTINE mp_shift_c
28655
28656! **************************************************************************************************
28657!> \brief All-to-all data exchange, rank-1 data of different sizes
28658!> \param[in] sb Data to send
28659!> \param[in] scount Data counts for data sent to other processes
28660!> \param[in] sdispl Respective data offsets for data sent to process
28661!> \param[in,out] rb Buffer into which to receive data
28662!> \param[in] rcount Data counts for data received from other
28663!> processes
28664!> \param[in] rdispl Respective data offsets for data received from
28665!> other processes
28666!> \param[in] comm Message passing environment identifier
28667!> \par MPI mapping
28668!> mpi_alltoallv
28669!> \par Array sizes
28670!> The scount, rcount, and the sdispl and rdispl arrays have a
28671!> size equal to the number of processes.
28672!> \par Offsets
28673!> Values in sdispl and rdispl start with 0.
28674! **************************************************************************************************
28675 SUBROUTINE mp_alltoall_c11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
28676
28677 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
28678 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
28679 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
28680 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
28681 CLASS(mp_comm_type), INTENT(IN) :: comm
28682
28683 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c11v'
28684
28685 INTEGER :: handle
28686#if defined(__parallel)
28687 INTEGER :: ierr, msglen
28688#else
28689 INTEGER :: i
28690#endif
28691
28692 CALL mp_timeset(routinen, handle)
28693
28694#if defined(__parallel)
28695 CALL mpi_alltoallv(sb, scount, sdispl, mpi_complex, &
28696 rb, rcount, rdispl, mpi_complex, comm%handle, ierr)
28697 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
28698 msglen = sum(scount) + sum(rcount)
28699 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28700#else
28701 mark_used(comm)
28702 mark_used(scount)
28703 mark_used(sdispl)
28704 !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
28705 DO i = 1, rcount(1)
28706 rb(rdispl(1) + i) = sb(sdispl(1) + i)
28707 END DO
28708#endif
28709 CALL mp_timestop(handle)
28710
28711 END SUBROUTINE mp_alltoall_c11v
28712
28713! **************************************************************************************************
28714!> \brief All-to-all data exchange, rank-2 data of different sizes
28715!> \param sb ...
28716!> \param scount ...
28717!> \param sdispl ...
28718!> \param rb ...
28719!> \param rcount ...
28720!> \param rdispl ...
28721!> \param comm ...
28722!> \par MPI mapping
28723!> mpi_alltoallv
28724!> \note see mp_alltoall_c11v
28725! **************************************************************************************************
28726 SUBROUTINE mp_alltoall_c22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
28727
28728 COMPLEX(kind=real_4), DIMENSION(:, :), &
28729 INTENT(IN), CONTIGUOUS :: sb
28730 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
28731 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, &
28732 INTENT(INOUT) :: rb
28733 INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
28734 CLASS(mp_comm_type), INTENT(IN) :: comm
28735
28736 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c22v'
28737
28738 INTEGER :: handle
28739#if defined(__parallel)
28740 INTEGER :: ierr, msglen
28741#endif
28742
28743 CALL mp_timeset(routinen, handle)
28744
28745#if defined(__parallel)
28746 CALL mpi_alltoallv(sb, scount, sdispl, mpi_complex, &
28747 rb, rcount, rdispl, mpi_complex, comm%handle, ierr)
28748 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routinen)
28749 msglen = sum(scount) + sum(rcount)
28750 CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*(2*real_4_size))
28751#else
28752 mark_used(comm)
28753 mark_used(scount)
28754 mark_used(sdispl)
28755 mark_used(rcount)
28756 mark_used(rdispl)
28757 rb = sb
28758#endif
28759 CALL mp_timestop(handle)
28760
28761 END SUBROUTINE mp_alltoall_c22v
28762
28763! **************************************************************************************************
28764!> \brief All-to-all data exchange, rank 1 arrays, equal sizes
28765!> \param[in] sb array with data to send
28766!> \param[out] rb array into which data is received
28767!> \param[in] count number of elements to send/receive (product of the
28768!> extents of the first two dimensions)
28769!> \param[in] comm Message passing environment identifier
28770!> \par Index meaning
28771!> \par The first two indices specify the data while the last index counts
28772!> the processes
28773!> \par Sizes of ranks
28774!> All processes have the same data size.
28775!> \par MPI mapping
28776!> mpi_alltoall
28777! **************************************************************************************************
28778 SUBROUTINE mp_alltoall_c (sb, rb, count, comm)
28779
28780 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
28781 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
28782 INTEGER, INTENT(IN) :: count
28783 CLASS(mp_comm_type), INTENT(IN) :: comm
28784
28785 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c'
28786
28787 INTEGER :: handle
28788#if defined(__parallel)
28789 INTEGER :: ierr, msglen, np
28790#endif
28791
28792 CALL mp_timeset(routinen, handle)
28793
28794#if defined(__parallel)
28795 CALL mpi_alltoall(sb, count, mpi_complex, &
28796 rb, count, mpi_complex, comm%handle, ierr)
28797 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28798 CALL mpi_comm_size(comm%handle, np, ierr)
28799 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28800 msglen = 2*count*np
28801 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28802#else
28803 mark_used(count)
28804 mark_used(comm)
28805 rb = sb
28806#endif
28807 CALL mp_timestop(handle)
28808
28809 END SUBROUTINE mp_alltoall_c
28810
28811! **************************************************************************************************
28812!> \brief All-to-all data exchange, rank-2 arrays, equal sizes
28813!> \param sb ...
28814!> \param rb ...
28815!> \param count ...
28816!> \param commp ...
28817!> \note see mp_alltoall_c
28818! **************************************************************************************************
28819 SUBROUTINE mp_alltoall_c22(sb, rb, count, comm)
28820
28821 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
28822 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
28823 INTEGER, INTENT(IN) :: count
28824 CLASS(mp_comm_type), INTENT(IN) :: comm
28825
28826 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c22'
28827
28828 INTEGER :: handle
28829#if defined(__parallel)
28830 INTEGER :: ierr, msglen, np
28831#endif
28832
28833 CALL mp_timeset(routinen, handle)
28834
28835#if defined(__parallel)
28836 CALL mpi_alltoall(sb, count, mpi_complex, &
28837 rb, count, mpi_complex, comm%handle, ierr)
28838 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28839 CALL mpi_comm_size(comm%handle, np, ierr)
28840 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28841 msglen = 2*SIZE(sb)*np
28842 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28843#else
28844 mark_used(count)
28845 mark_used(comm)
28846 rb = sb
28847#endif
28848 CALL mp_timestop(handle)
28849
28850 END SUBROUTINE mp_alltoall_c22
28851
28852! **************************************************************************************************
28853!> \brief All-to-all data exchange, rank-3 data with equal sizes
28854!> \param sb ...
28855!> \param rb ...
28856!> \param count ...
28857!> \param comm ...
28858!> \note see mp_alltoall_c
28859! **************************************************************************************************
28860 SUBROUTINE mp_alltoall_c33(sb, rb, count, comm)
28861
28862 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
28863 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
28864 INTEGER, INTENT(IN) :: count
28865 CLASS(mp_comm_type), INTENT(IN) :: comm
28866
28867 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c33'
28868
28869 INTEGER :: handle
28870#if defined(__parallel)
28871 INTEGER :: ierr, msglen, np
28872#endif
28873
28874 CALL mp_timeset(routinen, handle)
28875
28876#if defined(__parallel)
28877 CALL mpi_alltoall(sb, count, mpi_complex, &
28878 rb, count, mpi_complex, comm%handle, ierr)
28879 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28880 CALL mpi_comm_size(comm%handle, np, ierr)
28881 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28882 msglen = 2*count*np
28883 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28884#else
28885 mark_used(count)
28886 mark_used(comm)
28887 rb = sb
28888#endif
28889 CALL mp_timestop(handle)
28890
28891 END SUBROUTINE mp_alltoall_c33
28892
28893! **************************************************************************************************
28894!> \brief All-to-all data exchange, rank 4 data, equal sizes
28895!> \param sb ...
28896!> \param rb ...
28897!> \param count ...
28898!> \param comm ...
28899!> \note see mp_alltoall_c
28900! **************************************************************************************************
28901 SUBROUTINE mp_alltoall_c44(sb, rb, count, comm)
28902
28903 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28904 INTENT(IN) :: sb
28905 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28906 INTENT(OUT) :: rb
28907 INTEGER, INTENT(IN) :: count
28908 CLASS(mp_comm_type), INTENT(IN) :: comm
28909
28910 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c44'
28911
28912 INTEGER :: handle
28913#if defined(__parallel)
28914 INTEGER :: ierr, msglen, np
28915#endif
28916
28917 CALL mp_timeset(routinen, handle)
28918
28919#if defined(__parallel)
28920 CALL mpi_alltoall(sb, count, mpi_complex, &
28921 rb, count, mpi_complex, comm%handle, ierr)
28922 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28923 CALL mpi_comm_size(comm%handle, np, ierr)
28924 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28925 msglen = 2*count*np
28926 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28927#else
28928 mark_used(count)
28929 mark_used(comm)
28930 rb = sb
28931#endif
28932 CALL mp_timestop(handle)
28933
28934 END SUBROUTINE mp_alltoall_c44
28935
28936! **************************************************************************************************
28937!> \brief All-to-all data exchange, rank 5 data, equal sizes
28938!> \param sb ...
28939!> \param rb ...
28940!> \param count ...
28941!> \param comm ...
28942!> \note see mp_alltoall_c
28943! **************************************************************************************************
28944 SUBROUTINE mp_alltoall_c55(sb, rb, count, comm)
28945
28946 COMPLEX(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
28947 INTENT(IN) :: sb
28948 COMPLEX(kind=real_4), DIMENSION(:, :, :, :, :), CONTIGUOUS, &
28949 INTENT(OUT) :: rb
28950 INTEGER, INTENT(IN) :: count
28951 CLASS(mp_comm_type), INTENT(IN) :: comm
28952
28953 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c55'
28954
28955 INTEGER :: handle
28956#if defined(__parallel)
28957 INTEGER :: ierr, msglen, np
28958#endif
28959
28960 CALL mp_timeset(routinen, handle)
28961
28962#if defined(__parallel)
28963 CALL mpi_alltoall(sb, count, mpi_complex, &
28964 rb, count, mpi_complex, comm%handle, ierr)
28965 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
28966 CALL mpi_comm_size(comm%handle, np, ierr)
28967 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
28968 msglen = 2*count*np
28969 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
28970#else
28971 mark_used(count)
28972 mark_used(comm)
28973 rb = sb
28974#endif
28975 CALL mp_timestop(handle)
28976
28977 END SUBROUTINE mp_alltoall_c55
28978
28979! **************************************************************************************************
28980!> \brief All-to-all data exchange, rank-4 data to rank-5 data
28981!> \param sb ...
28982!> \param rb ...
28983!> \param count ...
28984!> \param comm ...
28985!> \note see mp_alltoall_c
28986!> \note User must ensure size consistency.
28987! **************************************************************************************************
28988 SUBROUTINE mp_alltoall_c45(sb, rb, count, comm)
28989
28990 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
28991 INTENT(IN) :: sb
28992 COMPLEX(kind=real_4), &
28993 DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
28994 INTEGER, INTENT(IN) :: count
28995 CLASS(mp_comm_type), INTENT(IN) :: comm
28996
28997 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c45'
28998
28999 INTEGER :: handle
29000#if defined(__parallel)
29001 INTEGER :: ierr, msglen, np
29002#endif
29003
29004 CALL mp_timeset(routinen, handle)
29005
29006#if defined(__parallel)
29007 CALL mpi_alltoall(sb, count, mpi_complex, &
29008 rb, count, mpi_complex, comm%handle, ierr)
29009 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29010 CALL mpi_comm_size(comm%handle, np, ierr)
29011 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29012 msglen = 2*count*np
29013 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29014#else
29015 mark_used(count)
29016 mark_used(comm)
29017 rb = reshape(sb, shape(rb))
29018#endif
29019 CALL mp_timestop(handle)
29020
29021 END SUBROUTINE mp_alltoall_c45
29022
29023! **************************************************************************************************
29024!> \brief All-to-all data exchange, rank-3 data to rank-4 data
29025!> \param sb ...
29026!> \param rb ...
29027!> \param count ...
29028!> \param comm ...
29029!> \note see mp_alltoall_c
29030!> \note User must ensure size consistency.
29031! **************************************************************************************************
29032 SUBROUTINE mp_alltoall_c34(sb, rb, count, comm)
29033
29034 COMPLEX(kind=real_4), DIMENSION(:, :, :), CONTIGUOUS, &
29035 INTENT(IN) :: sb
29036 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29037 INTENT(OUT) :: rb
29038 INTEGER, INTENT(IN) :: count
29039 CLASS(mp_comm_type), INTENT(IN) :: comm
29040
29041 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c34'
29042
29043 INTEGER :: handle
29044#if defined(__parallel)
29045 INTEGER :: ierr, msglen, np
29046#endif
29047
29048 CALL mp_timeset(routinen, handle)
29049
29050#if defined(__parallel)
29051 CALL mpi_alltoall(sb, count, mpi_complex, &
29052 rb, count, mpi_complex, comm%handle, ierr)
29053 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29054 CALL mpi_comm_size(comm%handle, np, ierr)
29055 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29056 msglen = 2*count*np
29057 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29058#else
29059 mark_used(count)
29060 mark_used(comm)
29061 rb = reshape(sb, shape(rb))
29062#endif
29063 CALL mp_timestop(handle)
29064
29065 END SUBROUTINE mp_alltoall_c34
29066
29067! **************************************************************************************************
29068!> \brief All-to-all data exchange, rank-5 data to rank-4 data
29069!> \param sb ...
29070!> \param rb ...
29071!> \param count ...
29072!> \param comm ...
29073!> \note see mp_alltoall_c
29074!> \note User must ensure size consistency.
29075! **************************************************************************************************
29076 SUBROUTINE mp_alltoall_c54(sb, rb, count, comm)
29077
29078 COMPLEX(kind=real_4), &
29079 DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
29080 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), CONTIGUOUS, &
29081 INTENT(OUT) :: rb
29082 INTEGER, INTENT(IN) :: count
29083 CLASS(mp_comm_type), INTENT(IN) :: comm
29084
29085 CHARACTER(len=*), PARAMETER :: routinen = 'mp_alltoall_c54'
29086
29087 INTEGER :: handle
29088#if defined(__parallel)
29089 INTEGER :: ierr, msglen, np
29090#endif
29091
29092 CALL mp_timeset(routinen, handle)
29093
29094#if defined(__parallel)
29095 CALL mpi_alltoall(sb, count, mpi_complex, &
29096 rb, count, mpi_complex, comm%handle, ierr)
29097 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routinen)
29098 CALL mpi_comm_size(comm%handle, np, ierr)
29099 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routinen)
29100 msglen = 2*count*np
29101 CALL add_perf(perf_id=6, count=1, msg_size=msglen*(2*real_4_size))
29102#else
29103 mark_used(count)
29104 mark_used(comm)
29105 rb = reshape(sb, shape(rb))
29106#endif
29107 CALL mp_timestop(handle)
29108
29109 END SUBROUTINE mp_alltoall_c54
29110
29111! **************************************************************************************************
29112!> \brief Send one datum to another process
29113!> \param[in] msg Scalar to send
29114!> \param[in] dest Destination process
29115!> \param[in] tag Transfer identifier
29116!> \param[in] comm Message passing environment identifier
29117!> \par MPI mapping
29118!> mpi_send
29119! **************************************************************************************************
29120 SUBROUTINE mp_send_c (msg, dest, tag, comm)
29121 COMPLEX(kind=real_4), INTENT(IN) :: msg
29122 INTEGER, INTENT(IN) :: dest, tag
29123 CLASS(mp_comm_type), INTENT(IN) :: comm
29124
29125 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_c'
29126
29127 INTEGER :: handle
29128#if defined(__parallel)
29129 INTEGER :: ierr, msglen
29130#endif
29131
29132 CALL mp_timeset(routinen, handle)
29133
29134#if defined(__parallel)
29135 msglen = 1
29136 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29137 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29138 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29139#else
29140 mark_used(msg)
29141 mark_used(dest)
29142 mark_used(tag)
29143 mark_used(comm)
29144 ! only defined in parallel
29145 cpabort("not in parallel mode")
29146#endif
29147 CALL mp_timestop(handle)
29148 END SUBROUTINE mp_send_c
29149
29150! **************************************************************************************************
29151!> \brief Send rank-1 data to another process
29152!> \param[in] msg Rank-1 data to send
29153!> \param dest ...
29154!> \param tag ...
29155!> \param comm ...
29156!> \note see mp_send_c
29157! **************************************************************************************************
29158 SUBROUTINE mp_send_cv(msg, dest, tag, comm)
29159 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
29160 INTEGER, INTENT(IN) :: dest, tag
29161 CLASS(mp_comm_type), INTENT(IN) :: comm
29162
29163 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_cv'
29164
29165 INTEGER :: handle
29166#if defined(__parallel)
29167 INTEGER :: ierr, msglen
29168#endif
29169
29170 CALL mp_timeset(routinen, handle)
29171
29172#if defined(__parallel)
29173 msglen = SIZE(msg)
29174 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29175 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29176 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29177#else
29178 mark_used(msg)
29179 mark_used(dest)
29180 mark_used(tag)
29181 mark_used(comm)
29182 ! only defined in parallel
29183 cpabort("not in parallel mode")
29184#endif
29185 CALL mp_timestop(handle)
29186 END SUBROUTINE mp_send_cv
29187
29188! **************************************************************************************************
29189!> \brief Send rank-2 data to another process
29190!> \param[in] msg Rank-2 data to send
29191!> \param dest ...
29192!> \param tag ...
29193!> \param comm ...
29194!> \note see mp_send_c
29195! **************************************************************************************************
29196 SUBROUTINE mp_send_cm2(msg, dest, tag, comm)
29197 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
29198 INTEGER, INTENT(IN) :: dest, tag
29199 CLASS(mp_comm_type), INTENT(IN) :: comm
29200
29201 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_cm2'
29202
29203 INTEGER :: handle
29204#if defined(__parallel)
29205 INTEGER :: ierr, msglen
29206#endif
29207
29208 CALL mp_timeset(routinen, handle)
29209
29210#if defined(__parallel)
29211 msglen = SIZE(msg)
29212 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29213 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29214 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29215#else
29216 mark_used(msg)
29217 mark_used(dest)
29218 mark_used(tag)
29219 mark_used(comm)
29220 ! only defined in parallel
29221 cpabort("not in parallel mode")
29222#endif
29223 CALL mp_timestop(handle)
29224 END SUBROUTINE mp_send_cm2
29225
29226! **************************************************************************************************
29227!> \brief Send rank-3 data to another process
29228!> \param[in] msg Rank-3 data to send
29229!> \param dest ...
29230!> \param tag ...
29231!> \param comm ...
29232!> \note see mp_send_c
29233! **************************************************************************************************
29234 SUBROUTINE mp_send_cm3(msg, dest, tag, comm)
29235 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
29236 INTEGER, INTENT(IN) :: dest, tag
29237 CLASS(mp_comm_type), INTENT(IN) :: comm
29238
29239 CHARACTER(len=*), PARAMETER :: routinen = 'mp_send_${nametype1}m3'
29240
29241 INTEGER :: handle
29242#if defined(__parallel)
29243 INTEGER :: ierr, msglen
29244#endif
29245
29246 CALL mp_timeset(routinen, handle)
29247
29248#if defined(__parallel)
29249 msglen = SIZE(msg)
29250 CALL mpi_send(msg, msglen, mpi_complex, dest, tag, comm%handle, ierr)
29251 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routinen)
29252 CALL add_perf(perf_id=13, count=1, msg_size=msglen*(2*real_4_size))
29253#else
29254 mark_used(msg)
29255 mark_used(dest)
29256 mark_used(tag)
29257 mark_used(comm)
29258 ! only defined in parallel
29259 cpabort("not in parallel mode")
29260#endif
29261 CALL mp_timestop(handle)
29262 END SUBROUTINE mp_send_cm3
29263
29264! **************************************************************************************************
29265!> \brief Receive one datum from another process
29266!> \param[in,out] msg Place received data into this variable
29267!> \param[in,out] source Process to receive from
29268!> \param[in,out] tag Transfer identifier
29269!> \param[in] comm Message passing environment identifier
29270!> \par MPI mapping
29271!> mpi_send
29272! **************************************************************************************************
29273 SUBROUTINE mp_recv_c (msg, source, tag, comm)
29274 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29275 INTEGER, INTENT(INOUT) :: source, tag
29276 CLASS(mp_comm_type), INTENT(IN) :: comm
29277
29278 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_c'
29279
29280 INTEGER :: handle
29281#if defined(__parallel)
29282 INTEGER :: ierr, msglen
29283 mpi_status_type :: status
29284#endif
29285
29286 CALL mp_timeset(routinen, handle)
29287
29288#if defined(__parallel)
29289 msglen = 1
29290 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29291 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29292 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29293 ELSE
29294 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29295 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29296 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29297 source = status mpi_status_extract(mpi_source)
29298 tag = status mpi_status_extract(mpi_tag)
29299 END IF
29300#else
29301 mark_used(msg)
29302 mark_used(source)
29303 mark_used(tag)
29304 mark_used(comm)
29305 ! only defined in parallel
29306 cpabort("not in parallel mode")
29307#endif
29308 CALL mp_timestop(handle)
29309 END SUBROUTINE mp_recv_c
29310
29311! **************************************************************************************************
29312!> \brief Receive rank-1 data from another process
29313!> \param[in,out] msg Place received data into this rank-1 array
29314!> \param source ...
29315!> \param tag ...
29316!> \param comm ...
29317!> \note see mp_recv_c
29318! **************************************************************************************************
29319 SUBROUTINE mp_recv_cv(msg, source, tag, comm)
29320 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29321 INTEGER, INTENT(INOUT) :: source, tag
29322 CLASS(mp_comm_type), INTENT(IN) :: comm
29323
29324 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cv'
29325
29326 INTEGER :: handle
29327#if defined(__parallel)
29328 INTEGER :: ierr, msglen
29329 mpi_status_type :: status
29330#endif
29331
29332 CALL mp_timeset(routinen, handle)
29333
29334#if defined(__parallel)
29335 msglen = SIZE(msg)
29336 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29337 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29338 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29339 ELSE
29340 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29341 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29342 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29343 source = status mpi_status_extract(mpi_source)
29344 tag = status mpi_status_extract(mpi_tag)
29345 END IF
29346#else
29347 mark_used(msg)
29348 mark_used(source)
29349 mark_used(tag)
29350 mark_used(comm)
29351 ! only defined in parallel
29352 cpabort("not in parallel mode")
29353#endif
29354 CALL mp_timestop(handle)
29355 END SUBROUTINE mp_recv_cv
29356
29357! **************************************************************************************************
29358!> \brief Receive rank-2 data from another process
29359!> \param[in,out] msg Place received data into this rank-2 array
29360!> \param source ...
29361!> \param tag ...
29362!> \param comm ...
29363!> \note see mp_recv_c
29364! **************************************************************************************************
29365 SUBROUTINE mp_recv_cm2(msg, source, tag, comm)
29366 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29367 INTEGER, INTENT(INOUT) :: source, tag
29368 CLASS(mp_comm_type), INTENT(IN) :: comm
29369
29370 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cm2'
29371
29372 INTEGER :: handle
29373#if defined(__parallel)
29374 INTEGER :: ierr, msglen
29375 mpi_status_type :: status
29376#endif
29377
29378 CALL mp_timeset(routinen, handle)
29379
29380#if defined(__parallel)
29381 msglen = SIZE(msg)
29382 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29383 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29384 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29385 ELSE
29386 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29387 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29388 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29389 source = status mpi_status_extract(mpi_source)
29390 tag = status mpi_status_extract(mpi_tag)
29391 END IF
29392#else
29393 mark_used(msg)
29394 mark_used(source)
29395 mark_used(tag)
29396 mark_used(comm)
29397 ! only defined in parallel
29398 cpabort("not in parallel mode")
29399#endif
29400 CALL mp_timestop(handle)
29401 END SUBROUTINE mp_recv_cm2
29402
29403! **************************************************************************************************
29404!> \brief Receive rank-3 data from another process
29405!> \param[in,out] msg Place received data into this rank-3 array
29406!> \param source ...
29407!> \param tag ...
29408!> \param comm ...
29409!> \note see mp_recv_c
29410! **************************************************************************************************
29411 SUBROUTINE mp_recv_cm3(msg, source, tag, comm)
29412 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
29413 INTEGER, INTENT(INOUT) :: source, tag
29414 CLASS(mp_comm_type), INTENT(IN) :: comm
29415
29416 CHARACTER(len=*), PARAMETER :: routinen = 'mp_recv_cm3'
29417
29418 INTEGER :: handle
29419#if defined(__parallel)
29420 INTEGER :: ierr, msglen
29421 mpi_status_type :: status
29422#endif
29423
29424 CALL mp_timeset(routinen, handle)
29425
29426#if defined(__parallel)
29427 msglen = SIZE(msg)
29428 IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
29429 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, mpi_status_ignore, ierr)
29430 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29431 ELSE
29432 CALL mpi_recv(msg, msglen, mpi_complex, source, tag, comm%handle, status, ierr)
29433 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routinen)
29434 CALL add_perf(perf_id=14, count=1, msg_size=msglen*(2*real_4_size))
29435 source = status mpi_status_extract(mpi_source)
29436 tag = status mpi_status_extract(mpi_tag)
29437 END IF
29438#else
29439 mark_used(msg)
29440 mark_used(source)
29441 mark_used(tag)
29442 mark_used(comm)
29443 ! only defined in parallel
29444 cpabort("not in parallel mode")
29445#endif
29446 CALL mp_timestop(handle)
29447 END SUBROUTINE mp_recv_cm3
29448
29449! **************************************************************************************************
29450!> \brief Broadcasts a datum to all processes.
29451!> \param[in] msg Datum to broadcast
29452!> \param[in] source Processes which broadcasts
29453!> \param[in] comm Message passing environment identifier
29454!> \par MPI mapping
29455!> mpi_bcast
29456! **************************************************************************************************
29457 SUBROUTINE mp_bcast_c (msg, source, comm)
29458 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29459 INTEGER, INTENT(IN) :: source
29460 CLASS(mp_comm_type), INTENT(IN) :: comm
29461
29462 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c'
29463
29464 INTEGER :: handle
29465#if defined(__parallel)
29466 INTEGER :: ierr, msglen
29467#endif
29468
29469 CALL mp_timeset(routinen, handle)
29470
29471#if defined(__parallel)
29472 msglen = 1
29473 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29474 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29475 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29476#else
29477 mark_used(msg)
29478 mark_used(source)
29479 mark_used(comm)
29480#endif
29481 CALL mp_timestop(handle)
29482 END SUBROUTINE mp_bcast_c
29483
29484! **************************************************************************************************
29485!> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
29486!> \param[in] msg Datum to broadcast
29487!> \param[in] comm Message passing environment identifier
29488!> \par MPI mapping
29489!> mpi_bcast
29490! **************************************************************************************************
29491 SUBROUTINE mp_bcast_c_src(msg, comm)
29492 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29493 CLASS(mp_comm_type), INTENT(IN) :: comm
29494
29495 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c_src'
29496
29497 INTEGER :: handle
29498#if defined(__parallel)
29499 INTEGER :: ierr, msglen
29500#endif
29501
29502 CALL mp_timeset(routinen, handle)
29503
29504#if defined(__parallel)
29505 msglen = 1
29506 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29507 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29508 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29509#else
29510 mark_used(msg)
29511 mark_used(comm)
29512#endif
29513 CALL mp_timestop(handle)
29514 END SUBROUTINE mp_bcast_c_src
29515
29516! **************************************************************************************************
29517!> \brief Broadcasts a datum to all processes.
29518!> \param[in] msg Datum to broadcast
29519!> \param[in] source Processes which broadcasts
29520!> \param[in] comm Message passing environment identifier
29521!> \par MPI mapping
29522!> mpi_bcast
29523! **************************************************************************************************
29524 SUBROUTINE mp_ibcast_c (msg, source, comm, request)
29525 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29526 INTEGER, INTENT(IN) :: source
29527 CLASS(mp_comm_type), INTENT(IN) :: comm
29528 TYPE(mp_request_type), INTENT(OUT) :: request
29529
29530 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_c'
29531
29532 INTEGER :: handle
29533#if defined(__parallel)
29534 INTEGER :: ierr, msglen
29535#endif
29536
29537 CALL mp_timeset(routinen, handle)
29538
29539#if defined(__parallel)
29540 msglen = 1
29541 CALL mpi_ibcast(msg, msglen, mpi_complex, source, comm%handle, request%handle, ierr)
29542 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
29543 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_4_size))
29544#else
29545 mark_used(msg)
29546 mark_used(source)
29547 mark_used(comm)
29548 request = mp_request_null
29549#endif
29550 CALL mp_timestop(handle)
29551 END SUBROUTINE mp_ibcast_c
29552
29553! **************************************************************************************************
29554!> \brief Broadcasts rank-1 data to all processes
29555!> \param[in] msg Data to broadcast
29556!> \param source ...
29557!> \param comm ...
29558!> \note see mp_bcast_c1
29559! **************************************************************************************************
29560 SUBROUTINE mp_bcast_cv(msg, source, comm)
29561 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29562 INTEGER, INTENT(IN) :: source
29563 CLASS(mp_comm_type), INTENT(IN) :: comm
29564
29565 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cv'
29566
29567 INTEGER :: handle
29568#if defined(__parallel)
29569 INTEGER :: ierr, msglen
29570#endif
29571
29572 CALL mp_timeset(routinen, handle)
29573
29574#if defined(__parallel)
29575 msglen = SIZE(msg)
29576 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29577 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29578 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29579#else
29580 mark_used(msg)
29581 mark_used(source)
29582 mark_used(comm)
29583#endif
29584 CALL mp_timestop(handle)
29585 END SUBROUTINE mp_bcast_cv
29586
29587! **************************************************************************************************
29588!> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
29589!> \param[in] msg Data to broadcast
29590!> \param comm ...
29591!> \note see mp_bcast_c1
29592! **************************************************************************************************
29593 SUBROUTINE mp_bcast_cv_src(msg, comm)
29594 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29595 CLASS(mp_comm_type), INTENT(IN) :: comm
29596
29597 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cv_src'
29598
29599 INTEGER :: handle
29600#if defined(__parallel)
29601 INTEGER :: ierr, msglen
29602#endif
29603
29604 CALL mp_timeset(routinen, handle)
29605
29606#if defined(__parallel)
29607 msglen = SIZE(msg)
29608 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29609 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29610 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29611#else
29612 mark_used(msg)
29613 mark_used(comm)
29614#endif
29615 CALL mp_timestop(handle)
29616 END SUBROUTINE mp_bcast_cv_src
29617
29618! **************************************************************************************************
29619!> \brief Broadcasts rank-1 data to all processes
29620!> \param[in] msg Data to broadcast
29621!> \param source ...
29622!> \param comm ...
29623!> \note see mp_bcast_c1
29624! **************************************************************************************************
29625 SUBROUTINE mp_ibcast_cv(msg, source, comm, request)
29626 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
29627 INTEGER, INTENT(IN) :: source
29628 CLASS(mp_comm_type), INTENT(IN) :: comm
29629 TYPE(mp_request_type) :: request
29630
29631 CHARACTER(len=*), PARAMETER :: routinen = 'mp_ibcast_cv'
29632
29633 INTEGER :: handle
29634#if defined(__parallel)
29635 INTEGER :: ierr, msglen
29636#endif
29637
29638 CALL mp_timeset(routinen, handle)
29639
29640#if defined(__parallel)
29641#if !defined(__GNUC__) || __GNUC__ >= 9
29642 cpassert(is_contiguous(msg))
29643#endif
29644 msglen = SIZE(msg)
29645 CALL mpi_ibcast(msg, msglen, mpi_complex, source, comm%handle, request%handle, ierr)
29646 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routinen)
29647 CALL add_perf(perf_id=22, count=1, msg_size=msglen*(2*real_4_size))
29648#else
29649 mark_used(msg)
29650 mark_used(source)
29651 mark_used(comm)
29652 request = mp_request_null
29653#endif
29654 CALL mp_timestop(handle)
29655 END SUBROUTINE mp_ibcast_cv
29656
29657! **************************************************************************************************
29658!> \brief Broadcasts rank-2 data to all processes
29659!> \param[in] msg Data to broadcast
29660!> \param source ...
29661!> \param comm ...
29662!> \note see mp_bcast_c1
29663! **************************************************************************************************
29664 SUBROUTINE mp_bcast_cm(msg, source, comm)
29665 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29666 INTEGER, INTENT(IN) :: source
29667 CLASS(mp_comm_type), INTENT(IN) :: comm
29668
29669 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cm'
29670
29671 INTEGER :: handle
29672#if defined(__parallel)
29673 INTEGER :: ierr, msglen
29674#endif
29675
29676 CALL mp_timeset(routinen, handle)
29677
29678#if defined(__parallel)
29679 msglen = SIZE(msg)
29680 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29681 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29682 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29683#else
29684 mark_used(msg)
29685 mark_used(source)
29686 mark_used(comm)
29687#endif
29688 CALL mp_timestop(handle)
29689 END SUBROUTINE mp_bcast_cm
29690
29691! **************************************************************************************************
29692!> \brief Broadcasts rank-2 data to all processes
29693!> \param[in] msg Data to broadcast
29694!> \param source ...
29695!> \param comm ...
29696!> \note see mp_bcast_c1
29697! **************************************************************************************************
29698 SUBROUTINE mp_bcast_cm_src(msg, comm)
29699 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29700 CLASS(mp_comm_type), INTENT(IN) :: comm
29701
29702 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_cm_src'
29703
29704 INTEGER :: handle
29705#if defined(__parallel)
29706 INTEGER :: ierr, msglen
29707#endif
29708
29709 CALL mp_timeset(routinen, handle)
29710
29711#if defined(__parallel)
29712 msglen = SIZE(msg)
29713 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29714 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29715 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29716#else
29717 mark_used(msg)
29718 mark_used(comm)
29719#endif
29720 CALL mp_timestop(handle)
29721 END SUBROUTINE mp_bcast_cm_src
29722
29723! **************************************************************************************************
29724!> \brief Broadcasts rank-3 data to all processes
29725!> \param[in] msg Data to broadcast
29726!> \param source ...
29727!> \param comm ...
29728!> \note see mp_bcast_c1
29729! **************************************************************************************************
29730 SUBROUTINE mp_bcast_c3(msg, source, comm)
29731 COMPLEX(kind=real_4), CONTIGUOUS :: msg(:, :, :)
29732 INTEGER, INTENT(IN) :: source
29733 CLASS(mp_comm_type), INTENT(IN) :: comm
29734
29735 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c3'
29736
29737 INTEGER :: handle
29738#if defined(__parallel)
29739 INTEGER :: ierr, msglen
29740#endif
29741
29742 CALL mp_timeset(routinen, handle)
29743
29744#if defined(__parallel)
29745 msglen = SIZE(msg)
29746 CALL mpi_bcast(msg, msglen, mpi_complex, source, comm%handle, ierr)
29747 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29748 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29749#else
29750 mark_used(msg)
29751 mark_used(source)
29752 mark_used(comm)
29753#endif
29754 CALL mp_timestop(handle)
29755 END SUBROUTINE mp_bcast_c3
29756
29757! **************************************************************************************************
29758!> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
29759!> \param[in] msg Data to broadcast
29760!> \param source ...
29761!> \param comm ...
29762!> \note see mp_bcast_c1
29763! **************************************************************************************************
29764 SUBROUTINE mp_bcast_c3_src(msg, comm)
29765 COMPLEX(kind=real_4), CONTIGUOUS :: msg(:, :, :)
29766 CLASS(mp_comm_type), INTENT(IN) :: comm
29767
29768 CHARACTER(len=*), PARAMETER :: routinen = 'mp_bcast_c3_src'
29769
29770 INTEGER :: handle
29771#if defined(__parallel)
29772 INTEGER :: ierr, msglen
29773#endif
29774
29775 CALL mp_timeset(routinen, handle)
29776
29777#if defined(__parallel)
29778 msglen = SIZE(msg)
29779 CALL mpi_bcast(msg, msglen, mpi_complex, comm%source, comm%handle, ierr)
29780 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routinen)
29781 CALL add_perf(perf_id=2, count=1, msg_size=msglen*(2*real_4_size))
29782#else
29783 mark_used(msg)
29784 mark_used(comm)
29785#endif
29786 CALL mp_timestop(handle)
29787 END SUBROUTINE mp_bcast_c3_src
29788
29789! **************************************************************************************************
29790!> \brief Sums a datum from all processes with result left on all processes.
29791!> \param[in,out] msg Datum to sum (input) and result (output)
29792!> \param[in] comm Message passing environment identifier
29793!> \par MPI mapping
29794!> mpi_allreduce
29795! **************************************************************************************************
29796 SUBROUTINE mp_sum_c (msg, comm)
29797 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
29798 CLASS(mp_comm_type), INTENT(IN) :: comm
29799
29800 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_c'
29801
29802 INTEGER :: handle
29803#if defined(__parallel)
29804 INTEGER :: ierr, msglen
29805#endif
29806
29807 CALL mp_timeset(routinen, handle)
29808
29809#if defined(__parallel)
29810 msglen = 1
29811 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29812 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29813 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29814#else
29815 mark_used(msg)
29816 mark_used(comm)
29817#endif
29818 CALL mp_timestop(handle)
29819 END SUBROUTINE mp_sum_c
29820
29821! **************************************************************************************************
29822!> \brief Element-wise sum of a rank-1 array on all processes.
29823!> \param[in,out] msg Vector to sum and result
29824!> \param comm ...
29825!> \note see mp_sum_c
29826! **************************************************************************************************
29827 SUBROUTINE mp_sum_cv(msg, comm)
29828 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
29829 CLASS(mp_comm_type), INTENT(IN) :: comm
29830
29831 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cv'
29832
29833 INTEGER :: handle
29834#if defined(__parallel)
29835 INTEGER :: ierr, msglen
29836#endif
29837
29838 CALL mp_timeset(routinen, handle)
29839
29840#if defined(__parallel)
29841 msglen = SIZE(msg)
29842 IF (msglen > 0) THEN
29843 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29844 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29845 END IF
29846 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29847#else
29848 mark_used(msg)
29849 mark_used(comm)
29850#endif
29851 CALL mp_timestop(handle)
29852 END SUBROUTINE mp_sum_cv
29853
29854! **************************************************************************************************
29855!> \brief Element-wise sum of a rank-1 array on all processes.
29856!> \param[in,out] msg Vector to sum and result
29857!> \param comm ...
29858!> \note see mp_sum_c
29859! **************************************************************************************************
29860 SUBROUTINE mp_isum_cv(msg, comm, request)
29861 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
29862 CLASS(mp_comm_type), INTENT(IN) :: comm
29863 TYPE(mp_request_type), INTENT(OUT) :: request
29864
29865 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isum_cv'
29866
29867 INTEGER :: handle
29868#if defined(__parallel)
29869 INTEGER :: ierr, msglen
29870#endif
29871
29872 CALL mp_timeset(routinen, handle)
29873
29874#if defined(__parallel)
29875#if !defined(__GNUC__) || __GNUC__ >= 9
29876 cpassert(is_contiguous(msg))
29877#endif
29878 msglen = SIZE(msg)
29879 IF (msglen > 0) THEN
29880 CALL mpi_iallreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, request%handle, ierr)
29881 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routinen)
29882 ELSE
29883 request = mp_request_null
29884 END IF
29885 CALL add_perf(perf_id=23, count=1, msg_size=msglen*(2*real_4_size))
29886#else
29887 mark_used(msg)
29888 mark_used(comm)
29889 request = mp_request_null
29890#endif
29891 CALL mp_timestop(handle)
29892 END SUBROUTINE mp_isum_cv
29893
29894! **************************************************************************************************
29895!> \brief Element-wise sum of a rank-2 array on all processes.
29896!> \param[in] msg Matrix to sum and result
29897!> \param comm ...
29898!> \note see mp_sum_c
29899! **************************************************************************************************
29900 SUBROUTINE mp_sum_cm(msg, comm)
29901 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
29902 CLASS(mp_comm_type), INTENT(IN) :: comm
29903
29904 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm'
29905
29906 INTEGER :: handle
29907#if defined(__parallel)
29908 INTEGER, PARAMETER :: max_msg = 2**25
29909 INTEGER :: ierr, m1, msglen, step, msglensum
29910#endif
29911
29912 CALL mp_timeset(routinen, handle)
29913
29914#if defined(__parallel)
29915 ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
29916 step = max(1, SIZE(msg, 2)/max(1, SIZE(msg)/max_msg))
29917 msglensum = 0
29918 DO m1 = lbound(msg, 2), ubound(msg, 2), step
29919 msglen = SIZE(msg, 1)*(min(ubound(msg, 2), m1 + step - 1) - m1 + 1)
29920 msglensum = msglensum + msglen
29921 IF (msglen > 0) THEN
29922 CALL mpi_allreduce(mpi_in_place, msg(lbound(msg, 1), m1), msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29923 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29924 END IF
29925 END DO
29926 CALL add_perf(perf_id=3, count=1, msg_size=msglensum*(2*real_4_size))
29927#else
29928 mark_used(msg)
29929 mark_used(comm)
29930#endif
29931 CALL mp_timestop(handle)
29932 END SUBROUTINE mp_sum_cm
29933
29934! **************************************************************************************************
29935!> \brief Element-wise sum of a rank-3 array on all processes.
29936!> \param[in] msg Array to sum and result
29937!> \param comm ...
29938!> \note see mp_sum_c
29939! **************************************************************************************************
29940 SUBROUTINE mp_sum_cm3(msg, comm)
29941 COMPLEX(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
29942 CLASS(mp_comm_type), INTENT(IN) :: comm
29943
29944 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm3'
29945
29946 INTEGER :: handle
29947#if defined(__parallel)
29948 INTEGER :: ierr, msglen
29949#endif
29950
29951 CALL mp_timeset(routinen, handle)
29952
29953#if defined(__parallel)
29954 msglen = SIZE(msg)
29955 IF (msglen > 0) THEN
29956 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29957 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29958 END IF
29959 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29960#else
29961 mark_used(msg)
29962 mark_used(comm)
29963#endif
29964 CALL mp_timestop(handle)
29965 END SUBROUTINE mp_sum_cm3
29966
29967! **************************************************************************************************
29968!> \brief Element-wise sum of a rank-4 array on all processes.
29969!> \param[in] msg Array to sum and result
29970!> \param comm ...
29971!> \note see mp_sum_c
29972! **************************************************************************************************
29973 SUBROUTINE mp_sum_cm4(msg, comm)
29974 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
29975 CLASS(mp_comm_type), INTENT(IN) :: comm
29976
29977 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_cm4'
29978
29979 INTEGER :: handle
29980#if defined(__parallel)
29981 INTEGER :: ierr, msglen
29982#endif
29983
29984 CALL mp_timeset(routinen, handle)
29985
29986#if defined(__parallel)
29987 msglen = SIZE(msg)
29988 IF (msglen > 0) THEN
29989 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
29990 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
29991 END IF
29992 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
29993#else
29994 mark_used(msg)
29995 mark_used(comm)
29996#endif
29997 CALL mp_timestop(handle)
29998 END SUBROUTINE mp_sum_cm4
29999
30000! **************************************************************************************************
30001!> \brief Element-wise sum of data from all processes with result left only on
30002!> one.
30003!> \param[in,out] msg Vector to sum (input) and (only on process root)
30004!> result (output)
30005!> \param root ...
30006!> \param[in] comm Message passing environment identifier
30007!> \par MPI mapping
30008!> mpi_reduce
30009! **************************************************************************************************
30010 SUBROUTINE mp_sum_root_cv(msg, root, comm)
30011 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30012 INTEGER, INTENT(IN) :: root
30013 CLASS(mp_comm_type), INTENT(IN) :: comm
30014
30015 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_cv'
30016
30017 INTEGER :: handle
30018#if defined(__parallel)
30019 INTEGER :: ierr, m1, msglen, taskid
30020 COMPLEX(kind=real_4), ALLOCATABLE :: res(:)
30021#endif
30022
30023 CALL mp_timeset(routinen, handle)
30024
30025#if defined(__parallel)
30026 msglen = SIZE(msg)
30027 CALL mpi_comm_rank(comm%handle, taskid, ierr)
30028 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
30029 IF (msglen > 0) THEN
30030 m1 = SIZE(msg, 1)
30031 ALLOCATE (res(m1))
30032 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_sum, &
30033 root, comm%handle, ierr)
30034 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30035 IF (taskid == root) THEN
30036 msg = res
30037 END IF
30038 DEALLOCATE (res)
30039 END IF
30040 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30041#else
30042 mark_used(msg)
30043 mark_used(root)
30044 mark_used(comm)
30045#endif
30046 CALL mp_timestop(handle)
30047 END SUBROUTINE mp_sum_root_cv
30048
30049! **************************************************************************************************
30050!> \brief Element-wise sum of data from all processes with result left only on
30051!> one.
30052!> \param[in,out] msg Matrix to sum (input) and (only on process root)
30053!> result (output)
30054!> \param root ...
30055!> \param comm ...
30056!> \note see mp_sum_root_cv
30057! **************************************************************************************************
30058 SUBROUTINE mp_sum_root_cm(msg, root, comm)
30059 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30060 INTEGER, INTENT(IN) :: root
30061 CLASS(mp_comm_type), INTENT(IN) :: comm
30062
30063 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_root_rm'
30064
30065 INTEGER :: handle
30066#if defined(__parallel)
30067 INTEGER :: ierr, m1, m2, msglen, taskid
30068 COMPLEX(kind=real_4), ALLOCATABLE :: res(:, :)
30069#endif
30070
30071 CALL mp_timeset(routinen, handle)
30072
30073#if defined(__parallel)
30074 msglen = SIZE(msg)
30075 CALL mpi_comm_rank(comm%handle, taskid, ierr)
30076 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
30077 IF (msglen > 0) THEN
30078 m1 = SIZE(msg, 1)
30079 m2 = SIZE(msg, 2)
30080 ALLOCATE (res(m1, m2))
30081 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_sum, root, comm%handle, ierr)
30082 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30083 IF (taskid == root) THEN
30084 msg = res
30085 END IF
30086 DEALLOCATE (res)
30087 END IF
30088 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30089#else
30090 mark_used(root)
30091 mark_used(msg)
30092 mark_used(comm)
30093#endif
30094 CALL mp_timestop(handle)
30095 END SUBROUTINE mp_sum_root_cm
30096
30097! **************************************************************************************************
30098!> \brief Partial sum of data from all processes with result on each process.
30099!> \param[in] msg Matrix to sum (input)
30100!> \param[out] res Matrix containing result (output)
30101!> \param[in] comm Message passing environment identifier
30102! **************************************************************************************************
30103 SUBROUTINE mp_sum_partial_cm(msg, res, comm)
30104 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30105 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: res(:, :)
30106 CLASS(mp_comm_type), INTENT(IN) :: comm
30107
30108 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_partial_cm'
30109
30110 INTEGER :: handle
30111#if defined(__parallel)
30112 INTEGER :: ierr, msglen, taskid
30113#endif
30114
30115 CALL mp_timeset(routinen, handle)
30116
30117#if defined(__parallel)
30118 msglen = SIZE(msg)
30119 CALL mpi_comm_rank(comm%handle, taskid, ierr)
30120 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routinen)
30121 IF (msglen > 0) THEN
30122 CALL mpi_scan(msg, res, msglen, mpi_complex, mpi_sum, comm%handle, ierr)
30123 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routinen)
30124 END IF
30125 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30126 ! perf_id is same as for other summation routines
30127#else
30128 res = msg
30129 mark_used(comm)
30130#endif
30131 CALL mp_timestop(handle)
30132 END SUBROUTINE mp_sum_partial_cm
30133
30134! **************************************************************************************************
30135!> \brief Finds the maximum of a datum with the result left on all processes.
30136!> \param[in,out] msg Find maximum among these data (input) and
30137!> maximum (output)
30138!> \param[in] comm Message passing environment identifier
30139!> \par MPI mapping
30140!> mpi_allreduce
30141! **************************************************************************************************
30142 SUBROUTINE mp_max_c (msg, comm)
30143 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30144 CLASS(mp_comm_type), INTENT(IN) :: comm
30145
30146 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_c'
30147
30148 INTEGER :: handle
30149#if defined(__parallel)
30150 INTEGER :: ierr, msglen
30151#endif
30152
30153 CALL mp_timeset(routinen, handle)
30154
30155#if defined(__parallel)
30156 msglen = 1
30157 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_max, comm%handle, ierr)
30158 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
30164 CALL mp_timestop(handle)
30165 END SUBROUTINE mp_max_c
30166
30167! **************************************************************************************************
30168!> \brief Finds the maximum of a datum with the result left on all processes.
30169!> \param[in,out] msg Find maximum among these data (input) and
30170!> maximum (output)
30171!> \param[in] comm Message passing environment identifier
30172!> \par MPI mapping
30173!> mpi_allreduce
30174! **************************************************************************************************
30175 SUBROUTINE mp_max_root_c (msg, root, comm)
30176 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30177 INTEGER, INTENT(IN) :: root
30178 CLASS(mp_comm_type), INTENT(IN) :: comm
30179
30180 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_c'
30181
30182 INTEGER :: handle
30183#if defined(__parallel)
30184 INTEGER :: ierr, msglen
30185 COMPLEX(kind=real_4) :: res
30186#endif
30187
30188 CALL mp_timeset(routinen, handle)
30189
30190#if defined(__parallel)
30191 msglen = 1
30192 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_max, root, comm%handle, ierr)
30193 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routinen)
30194 IF (root == comm%mepos) msg = res
30195 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30196#else
30197 mark_used(msg)
30198 mark_used(comm)
30199 mark_used(root)
30200#endif
30201 CALL mp_timestop(handle)
30202 END SUBROUTINE mp_max_root_c
30203
30204! **************************************************************************************************
30205!> \brief Finds the element-wise maximum of a vector with the result left on
30206!> all processes.
30207!> \param[in,out] msg Find maximum among these data (input) and
30208!> maximum (output)
30209!> \param comm ...
30210!> \note see mp_max_c
30211! **************************************************************************************************
30212 SUBROUTINE mp_max_cv(msg, comm)
30213 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
30214 CLASS(mp_comm_type), INTENT(IN) :: comm
30215
30216 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_cv'
30217
30218 INTEGER :: handle
30219#if defined(__parallel)
30220 INTEGER :: ierr, msglen
30221#endif
30222
30223 CALL mp_timeset(routinen, handle)
30224
30225#if defined(__parallel)
30226 msglen = SIZE(msg)
30227 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_max, comm%handle, ierr)
30228 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
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#endif
30234 CALL mp_timestop(handle)
30235 END SUBROUTINE mp_max_cv
30236
30237! **************************************************************************************************
30238!> \brief Finds the element-wise maximum of a vector with the result left on
30239!> all processes.
30240!> \param[in,out] msg Find maximum among these data (input) and
30241!> maximum (output)
30242!> \param comm ...
30243!> \note see mp_max_c
30244! **************************************************************************************************
30245 SUBROUTINE mp_max_root_cm(msg, root, comm)
30246 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
30247 INTEGER :: root
30248 CLASS(mp_comm_type), INTENT(IN) :: comm
30249
30250 CHARACTER(len=*), PARAMETER :: routinen = 'mp_max_root_cm'
30251
30252 INTEGER :: handle
30253#if defined(__parallel)
30254 INTEGER :: ierr, msglen
30255 COMPLEX(kind=real_4) :: res(size(msg, 1), size(msg, 2))
30256#endif
30257
30258 CALL mp_timeset(routinen, handle)
30259
30260#if defined(__parallel)
30261 msglen = SIZE(msg)
30262 CALL mpi_reduce(msg, res, msglen, mpi_complex, mpi_max, root, comm%handle, ierr)
30263 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30264 IF (root == comm%mepos) msg = res
30265 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30266#else
30267 mark_used(msg)
30268 mark_used(comm)
30269 mark_used(root)
30270#endif
30271 CALL mp_timestop(handle)
30272 END SUBROUTINE mp_max_root_cm
30273
30274! **************************************************************************************************
30275!> \brief Finds the minimum of a datum with the result left on all processes.
30276!> \param[in,out] msg Find minimum among these data (input) and
30277!> maximum (output)
30278!> \param[in] comm Message passing environment identifier
30279!> \par MPI mapping
30280!> mpi_allreduce
30281! **************************************************************************************************
30282 SUBROUTINE mp_min_c (msg, comm)
30283 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30284 CLASS(mp_comm_type), INTENT(IN) :: comm
30285
30286 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_c'
30287
30288 INTEGER :: handle
30289#if defined(__parallel)
30290 INTEGER :: ierr, msglen
30291#endif
30292
30293 CALL mp_timeset(routinen, handle)
30294
30295#if defined(__parallel)
30296 msglen = 1
30297 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30298 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30299 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30300#else
30301 mark_used(msg)
30302 mark_used(comm)
30303#endif
30304 CALL mp_timestop(handle)
30305 END SUBROUTINE mp_min_c
30306
30307! **************************************************************************************************
30308!> \brief Finds the element-wise minimum of vector with the result left on
30309!> all processes.
30310!> \param[in,out] msg Find minimum among these data (input) and
30311!> maximum (output)
30312!> \param comm ...
30313!> \par MPI mapping
30314!> mpi_allreduce
30315!> \note see mp_min_c
30316! **************************************************************************************************
30317 SUBROUTINE mp_min_cv(msg, comm)
30318 COMPLEX(kind=real_4), INTENT(INOUT), CONTIGUOUS :: msg(:)
30319 CLASS(mp_comm_type), INTENT(IN) :: comm
30320
30321 CHARACTER(len=*), PARAMETER :: routinen = 'mp_min_cv'
30322
30323 INTEGER :: handle
30324#if defined(__parallel)
30325 INTEGER :: ierr, msglen
30326#endif
30327
30328 CALL mp_timeset(routinen, handle)
30329
30330#if defined(__parallel)
30331 msglen = SIZE(msg)
30332 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_min, comm%handle, ierr)
30333 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30334 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30335#else
30336 mark_used(msg)
30337 mark_used(comm)
30338#endif
30339 CALL mp_timestop(handle)
30340 END SUBROUTINE mp_min_cv
30341
30342! **************************************************************************************************
30343!> \brief Multiplies a set of numbers scattered across a number of processes,
30344!> then replicates the result.
30345!> \param[in,out] msg a number to multiply (input) and result (output)
30346!> \param[in] comm message passing environment identifier
30347!> \par MPI mapping
30348!> mpi_allreduce
30349! **************************************************************************************************
30350 SUBROUTINE mp_prod_c (msg, comm)
30351 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30352 CLASS(mp_comm_type), INTENT(IN) :: comm
30353
30354 CHARACTER(len=*), PARAMETER :: routinen = 'mp_prod_c'
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 = 1
30365 CALL mpi_allreduce(mpi_in_place, msg, msglen, mpi_complex, mpi_prod, comm%handle, ierr)
30366 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routinen)
30367 CALL add_perf(perf_id=3, count=1, msg_size=msglen*(2*real_4_size))
30368#else
30369 mark_used(msg)
30370 mark_used(comm)
30371#endif
30372 CALL mp_timestop(handle)
30373 END SUBROUTINE mp_prod_c
30374
30375! **************************************************************************************************
30376!> \brief Scatters data from one processes to all others
30377!> \param[in] msg_scatter Data to scatter (for root process)
30378!> \param[out] msg Received data
30379!> \param[in] root Process which scatters data
30380!> \param[in] comm Message passing environment identifier
30381!> \par MPI mapping
30382!> mpi_scatter
30383! **************************************************************************************************
30384 SUBROUTINE mp_scatter_cv(msg_scatter, msg, root, comm)
30385 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
30386 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg(:)
30387 INTEGER, INTENT(IN) :: root
30388 CLASS(mp_comm_type), INTENT(IN) :: comm
30389
30390 CHARACTER(len=*), PARAMETER :: routinen = 'mp_scatter_cv'
30391
30392 INTEGER :: handle
30393#if defined(__parallel)
30394 INTEGER :: ierr, msglen
30395#endif
30396
30397 CALL mp_timeset(routinen, handle)
30398
30399#if defined(__parallel)
30400 msglen = SIZE(msg)
30401 CALL mpi_scatter(msg_scatter, msglen, mpi_complex, msg, &
30402 msglen, mpi_complex, root, comm%handle, ierr)
30403 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routinen)
30404 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30405#else
30406 mark_used(root)
30407 mark_used(comm)
30408 msg = msg_scatter
30409#endif
30410 CALL mp_timestop(handle)
30411 END SUBROUTINE mp_scatter_cv
30412
30413! **************************************************************************************************
30414!> \brief Scatters data from one processes to all others
30415!> \param[in] msg_scatter Data to scatter (for root process)
30416!> \param[in] root Process which scatters data
30417!> \param[in] comm Message passing environment identifier
30418!> \par MPI mapping
30419!> mpi_scatter
30420! **************************************************************************************************
30421 SUBROUTINE mp_iscatter_c (msg_scatter, msg, root, comm, request)
30422 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:)
30423 COMPLEX(kind=real_4), INTENT(INOUT) :: msg
30424 INTEGER, INTENT(IN) :: root
30425 CLASS(mp_comm_type), INTENT(IN) :: comm
30426 TYPE(mp_request_type), INTENT(OUT) :: request
30427
30428 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_c'
30429
30430 INTEGER :: handle
30431#if defined(__parallel)
30432 INTEGER :: ierr, msglen
30433#endif
30434
30435 CALL mp_timeset(routinen, handle)
30436
30437#if defined(__parallel)
30438#if !defined(__GNUC__) || __GNUC__ >= 9
30439 cpassert(is_contiguous(msg_scatter))
30440#endif
30441 msglen = 1
30442 CALL mpi_iscatter(msg_scatter, msglen, mpi_complex, msg, &
30443 msglen, mpi_complex, root, comm%handle, request%handle, ierr)
30444 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
30445 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30446#else
30447 mark_used(root)
30448 mark_used(comm)
30449 msg = msg_scatter(1)
30450 request = mp_request_null
30451#endif
30452 CALL mp_timestop(handle)
30453 END SUBROUTINE mp_iscatter_c
30454
30455! **************************************************************************************************
30456!> \brief Scatters data from one processes to all others
30457!> \param[in] msg_scatter Data to scatter (for root process)
30458!> \param[in] root Process which scatters data
30459!> \param[in] comm Message passing environment identifier
30460!> \par MPI mapping
30461!> mpi_scatter
30462! **************************************************************************************************
30463 SUBROUTINE mp_iscatter_cv2(msg_scatter, msg, root, comm, request)
30464 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:, :)
30465 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
30466 INTEGER, INTENT(IN) :: root
30467 CLASS(mp_comm_type), INTENT(IN) :: comm
30468 TYPE(mp_request_type), INTENT(OUT) :: request
30469
30470 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatter_cv2'
30471
30472 INTEGER :: handle
30473#if defined(__parallel)
30474 INTEGER :: ierr, msglen
30475#endif
30476
30477 CALL mp_timeset(routinen, handle)
30478
30479#if defined(__parallel)
30480#if !defined(__GNUC__) || __GNUC__ >= 9
30481 cpassert(is_contiguous(msg_scatter))
30482#endif
30483 msglen = SIZE(msg)
30484 CALL mpi_iscatter(msg_scatter, msglen, mpi_complex, msg, &
30485 msglen, mpi_complex, root, comm%handle, request%handle, ierr)
30486 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routinen)
30487 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30488#else
30489 mark_used(root)
30490 mark_used(comm)
30491 msg(:) = msg_scatter(:, 1)
30492 request = mp_request_null
30493#endif
30494 CALL mp_timestop(handle)
30495 END SUBROUTINE mp_iscatter_cv2
30496
30497! **************************************************************************************************
30498!> \brief Scatters data from one processes to all others
30499!> \param[in] msg_scatter Data to scatter (for root process)
30500!> \param[in] root Process which scatters data
30501!> \param[in] comm Message passing environment identifier
30502!> \par MPI mapping
30503!> mpi_scatter
30504! **************************************************************************************************
30505 SUBROUTINE mp_iscatterv_cv(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
30506 COMPLEX(kind=real_4), INTENT(IN) :: msg_scatter(:)
30507 INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
30508 COMPLEX(kind=real_4), INTENT(INOUT) :: msg(:)
30509 INTEGER, INTENT(IN) :: recvcount, root
30510 CLASS(mp_comm_type), INTENT(IN) :: comm
30511 TYPE(mp_request_type), INTENT(OUT) :: request
30512
30513 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iscatterv_cv'
30514
30515 INTEGER :: handle
30516#if defined(__parallel)
30517 INTEGER :: ierr
30518#endif
30519
30520 CALL mp_timeset(routinen, handle)
30521
30522#if defined(__parallel)
30523#if !defined(__GNUC__) || __GNUC__ >= 9
30524 cpassert(is_contiguous(msg_scatter))
30525 cpassert(is_contiguous(msg))
30526 cpassert(is_contiguous(sendcounts))
30527 cpassert(is_contiguous(displs))
30528#endif
30529 CALL mpi_iscatterv(msg_scatter, sendcounts, displs, mpi_complex, msg, &
30530 recvcount, mpi_complex, root, comm%handle, request%handle, ierr)
30531 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routinen)
30532 CALL add_perf(perf_id=24, count=1, msg_size=1*(2*real_4_size))
30533#else
30534 mark_used(sendcounts)
30535 mark_used(displs)
30536 mark_used(recvcount)
30537 mark_used(root)
30538 mark_used(comm)
30539 msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
30540 request = mp_request_null
30541#endif
30542 CALL mp_timestop(handle)
30543 END SUBROUTINE mp_iscatterv_cv
30544
30545! **************************************************************************************************
30546!> \brief Gathers a datum from all processes to one
30547!> \param[in] msg Datum to send to root
30548!> \param[out] msg_gather Received data (on root)
30549!> \param[in] root Process which gathers the data
30550!> \param[in] comm Message passing environment identifier
30551!> \par MPI mapping
30552!> mpi_gather
30553! **************************************************************************************************
30554 SUBROUTINE mp_gather_c (msg, msg_gather, root, comm)
30555 COMPLEX(kind=real_4), INTENT(IN) :: msg
30556 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30557 INTEGER, INTENT(IN) :: root
30558 CLASS(mp_comm_type), INTENT(IN) :: comm
30559
30560 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_c'
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, root, 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(root)
30577 mark_used(comm)
30578 msg_gather(1) = msg
30579#endif
30580 CALL mp_timestop(handle)
30581 END SUBROUTINE mp_gather_c
30582
30583! **************************************************************************************************
30584!> \brief Gathers a datum from all processes to one, uses the source process of comm
30585!> \param[in] msg Datum to send to root
30586!> \param[out] msg_gather Received data (on root)
30587!> \param[in] comm Message passing environment identifier
30588!> \par MPI mapping
30589!> mpi_gather
30590! **************************************************************************************************
30591 SUBROUTINE mp_gather_c_src(msg, msg_gather, comm)
30592 COMPLEX(kind=real_4), INTENT(IN) :: msg
30593 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30594 CLASS(mp_comm_type), INTENT(IN) :: comm
30595
30596 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_c_src'
30597
30598 INTEGER :: handle
30599#if defined(__parallel)
30600 INTEGER :: ierr, msglen
30601#endif
30602
30603 CALL mp_timeset(routinen, handle)
30604
30605#if defined(__parallel)
30606 msglen = 1
30607 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30608 msglen, mpi_complex, comm%source, comm%handle, ierr)
30609 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30610 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30611#else
30612 mark_used(comm)
30613 msg_gather(1) = msg
30614#endif
30615 CALL mp_timestop(handle)
30616 END SUBROUTINE mp_gather_c_src
30617
30618! **************************************************************************************************
30619!> \brief Gathers data from all processes to one
30620!> \param[in] msg Datum to send to root
30621!> \param msg_gather ...
30622!> \param root ...
30623!> \param comm ...
30624!> \par Data length
30625!> All data (msg) is equal-sized
30626!> \par MPI mapping
30627!> mpi_gather
30628!> \note see mp_gather_c
30629! **************************************************************************************************
30630 SUBROUTINE mp_gather_cv(msg, msg_gather, root, comm)
30631 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
30632 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30633 INTEGER, INTENT(IN) :: root
30634 CLASS(mp_comm_type), INTENT(IN) :: comm
30635
30636 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cv'
30637
30638 INTEGER :: handle
30639#if defined(__parallel)
30640 INTEGER :: ierr, msglen
30641#endif
30642
30643 CALL mp_timeset(routinen, handle)
30644
30645#if defined(__parallel)
30646 msglen = SIZE(msg)
30647 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30648 msglen, mpi_complex, root, comm%handle, ierr)
30649 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30650 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30651#else
30652 mark_used(root)
30653 mark_used(comm)
30654 msg_gather = msg
30655#endif
30656 CALL mp_timestop(handle)
30657 END SUBROUTINE mp_gather_cv
30658
30659! **************************************************************************************************
30660!> \brief Gathers data from all processes to one. Gathers from comm%source
30661!> \param[in] msg Datum to send to root
30662!> \param msg_gather ...
30663!> \param comm ...
30664!> \par Data length
30665!> All data (msg) is equal-sized
30666!> \par MPI mapping
30667!> mpi_gather
30668!> \note see mp_gather_c
30669! **************************************************************************************************
30670 SUBROUTINE mp_gather_cv_src(msg, msg_gather, comm)
30671 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
30672 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
30673 CLASS(mp_comm_type), INTENT(IN) :: comm
30674
30675 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cv_src'
30676
30677 INTEGER :: handle
30678#if defined(__parallel)
30679 INTEGER :: ierr, msglen
30680#endif
30681
30682 CALL mp_timeset(routinen, handle)
30683
30684#if defined(__parallel)
30685 msglen = SIZE(msg)
30686 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30687 msglen, mpi_complex, comm%source, comm%handle, ierr)
30688 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30689 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30690#else
30691 mark_used(comm)
30692 msg_gather = msg
30693#endif
30694 CALL mp_timestop(handle)
30695 END SUBROUTINE mp_gather_cv_src
30696
30697! **************************************************************************************************
30698!> \brief Gathers data from all processes to one
30699!> \param[in] msg Datum to send to root
30700!> \param msg_gather ...
30701!> \param root ...
30702!> \param comm ...
30703!> \par Data length
30704!> All data (msg) is equal-sized
30705!> \par MPI mapping
30706!> mpi_gather
30707!> \note see mp_gather_c
30708! **************************************************************************************************
30709 SUBROUTINE mp_gather_cm(msg, msg_gather, root, comm)
30710 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30711 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
30712 INTEGER, INTENT(IN) :: root
30713 CLASS(mp_comm_type), INTENT(IN) :: comm
30714
30715 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cm'
30716
30717 INTEGER :: handle
30718#if defined(__parallel)
30719 INTEGER :: ierr, msglen
30720#endif
30721
30722 CALL mp_timeset(routinen, handle)
30723
30724#if defined(__parallel)
30725 msglen = SIZE(msg)
30726 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30727 msglen, mpi_complex, root, comm%handle, ierr)
30728 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30729 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30730#else
30731 mark_used(root)
30732 mark_used(comm)
30733 msg_gather = msg
30734#endif
30735 CALL mp_timestop(handle)
30736 END SUBROUTINE mp_gather_cm
30737
30738! **************************************************************************************************
30739!> \brief Gathers data from all processes to one. Gathers from comm%source
30740!> \param[in] msg Datum to send to root
30741!> \param msg_gather ...
30742!> \param comm ...
30743!> \par Data length
30744!> All data (msg) is equal-sized
30745!> \par MPI mapping
30746!> mpi_gather
30747!> \note see mp_gather_c
30748! **************************************************************************************************
30749 SUBROUTINE mp_gather_cm_src(msg, msg_gather, comm)
30750 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:, :)
30751 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
30752 CLASS(mp_comm_type), INTENT(IN) :: comm
30753
30754 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gather_cm_src'
30755
30756 INTEGER :: handle
30757#if defined(__parallel)
30758 INTEGER :: ierr, msglen
30759#endif
30760
30761 CALL mp_timeset(routinen, handle)
30762
30763#if defined(__parallel)
30764 msglen = SIZE(msg)
30765 CALL mpi_gather(msg, msglen, mpi_complex, msg_gather, &
30766 msglen, mpi_complex, comm%source, comm%handle, ierr)
30767 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routinen)
30768 CALL add_perf(perf_id=4, count=1, msg_size=msglen*(2*real_4_size))
30769#else
30770 mark_used(comm)
30771 msg_gather = msg
30772#endif
30773 CALL mp_timestop(handle)
30774 END SUBROUTINE mp_gather_cm_src
30775
30776! **************************************************************************************************
30777!> \brief Gathers data from all processes to one.
30778!> \param[in] sendbuf Data to send to root
30779!> \param[out] recvbuf Received data (on root)
30780!> \param[in] recvcounts Sizes of data received from processes
30781!> \param[in] displs Offsets of data received from processes
30782!> \param[in] root Process which gathers the data
30783!> \param[in] comm Message passing environment identifier
30784!> \par Data length
30785!> Data can have different lengths
30786!> \par Offsets
30787!> Offsets start at 0
30788!> \par MPI mapping
30789!> mpi_gather
30790! **************************************************************************************************
30791 SUBROUTINE mp_gatherv_cv(sendbuf, recvbuf, recvcounts, displs, root, comm)
30792
30793 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
30794 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
30795 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30796 INTEGER, INTENT(IN) :: root
30797 CLASS(mp_comm_type), INTENT(IN) :: comm
30798
30799 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cv'
30800
30801 INTEGER :: handle
30802#if defined(__parallel)
30803 INTEGER :: ierr, sendcount
30804#endif
30805
30806 CALL mp_timeset(routinen, handle)
30807
30808#if defined(__parallel)
30809 sendcount = SIZE(sendbuf)
30810 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30811 recvbuf, recvcounts, displs, mpi_complex, &
30812 root, comm%handle, ierr)
30813 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30814 CALL add_perf(perf_id=4, &
30815 count=1, &
30816 msg_size=sendcount*(2*real_4_size))
30817#else
30818 mark_used(recvcounts)
30819 mark_used(root)
30820 mark_used(comm)
30821 recvbuf(1 + displs(1):) = sendbuf
30822#endif
30823 CALL mp_timestop(handle)
30824 END SUBROUTINE mp_gatherv_cv
30825
30826! **************************************************************************************************
30827!> \brief Gathers data from all processes to one. Gathers from comm%source
30828!> \param[in] sendbuf Data to send to root
30829!> \param[out] recvbuf Received data (on root)
30830!> \param[in] recvcounts Sizes of data received from processes
30831!> \param[in] displs Offsets of data received from processes
30832!> \param[in] comm Message passing environment identifier
30833!> \par Data length
30834!> Data can have different lengths
30835!> \par Offsets
30836!> Offsets start at 0
30837!> \par MPI mapping
30838!> mpi_gather
30839! **************************************************************************************************
30840 SUBROUTINE mp_gatherv_cv_src(sendbuf, recvbuf, recvcounts, displs, comm)
30841
30842 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
30843 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
30844 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30845 CLASS(mp_comm_type), INTENT(IN) :: comm
30846
30847 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cv_src'
30848
30849 INTEGER :: handle
30850#if defined(__parallel)
30851 INTEGER :: ierr, sendcount
30852#endif
30853
30854 CALL mp_timeset(routinen, handle)
30855
30856#if defined(__parallel)
30857 sendcount = SIZE(sendbuf)
30858 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30859 recvbuf, recvcounts, displs, mpi_complex, &
30860 comm%source, comm%handle, ierr)
30861 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30862 CALL add_perf(perf_id=4, &
30863 count=1, &
30864 msg_size=sendcount*(2*real_4_size))
30865#else
30866 mark_used(recvcounts)
30867 mark_used(comm)
30868 recvbuf(1 + displs(1):) = sendbuf
30869#endif
30870 CALL mp_timestop(handle)
30871 END SUBROUTINE mp_gatherv_cv_src
30872
30873! **************************************************************************************************
30874!> \brief Gathers data from all processes to one.
30875!> \param[in] sendbuf Data to send to root
30876!> \param[out] recvbuf Received data (on root)
30877!> \param[in] recvcounts Sizes of data received from processes
30878!> \param[in] displs Offsets of data received from processes
30879!> \param[in] root Process which gathers the data
30880!> \param[in] comm Message passing environment identifier
30881!> \par Data length
30882!> Data can have different lengths
30883!> \par Offsets
30884!> Offsets start at 0
30885!> \par MPI mapping
30886!> mpi_gather
30887! **************************************************************************************************
30888 SUBROUTINE mp_gatherv_cm2(sendbuf, recvbuf, recvcounts, displs, root, comm)
30889
30890 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
30891 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
30892 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30893 INTEGER, INTENT(IN) :: root
30894 CLASS(mp_comm_type), INTENT(IN) :: comm
30895
30896 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cm2'
30897
30898 INTEGER :: handle
30899#if defined(__parallel)
30900 INTEGER :: ierr, sendcount
30901#endif
30902
30903 CALL mp_timeset(routinen, handle)
30904
30905#if defined(__parallel)
30906 sendcount = SIZE(sendbuf)
30907 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30908 recvbuf, recvcounts, displs, mpi_complex, &
30909 root, comm%handle, ierr)
30910 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30911 CALL add_perf(perf_id=4, &
30912 count=1, &
30913 msg_size=sendcount*(2*real_4_size))
30914#else
30915 mark_used(recvcounts)
30916 mark_used(root)
30917 mark_used(comm)
30918 recvbuf(:, 1 + displs(1):) = sendbuf
30919#endif
30920 CALL mp_timestop(handle)
30921 END SUBROUTINE mp_gatherv_cm2
30922
30923! **************************************************************************************************
30924!> \brief Gathers data from all processes to one.
30925!> \param[in] sendbuf Data to send to root
30926!> \param[out] recvbuf Received data (on root)
30927!> \param[in] recvcounts Sizes of data received from processes
30928!> \param[in] displs Offsets of data received from processes
30929!> \param[in] comm Message passing environment identifier
30930!> \par Data length
30931!> Data can have different lengths
30932!> \par Offsets
30933!> Offsets start at 0
30934!> \par MPI mapping
30935!> mpi_gather
30936! **************************************************************************************************
30937 SUBROUTINE mp_gatherv_cm2_src(sendbuf, recvbuf, recvcounts, displs, comm)
30938
30939 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
30940 COMPLEX(kind=real_4), DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
30941 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30942 CLASS(mp_comm_type), INTENT(IN) :: comm
30943
30944 CHARACTER(len=*), PARAMETER :: routinen = 'mp_gatherv_cm2_src'
30945
30946 INTEGER :: handle
30947#if defined(__parallel)
30948 INTEGER :: ierr, sendcount
30949#endif
30950
30951 CALL mp_timeset(routinen, handle)
30952
30953#if defined(__parallel)
30954 sendcount = SIZE(sendbuf)
30955 CALL mpi_gatherv(sendbuf, sendcount, mpi_complex, &
30956 recvbuf, recvcounts, displs, mpi_complex, &
30957 comm%source, comm%handle, ierr)
30958 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
30959 CALL add_perf(perf_id=4, &
30960 count=1, &
30961 msg_size=sendcount*(2*real_4_size))
30962#else
30963 mark_used(recvcounts)
30964 mark_used(comm)
30965 recvbuf(:, 1 + displs(1):) = sendbuf
30966#endif
30967 CALL mp_timestop(handle)
30968 END SUBROUTINE mp_gatherv_cm2_src
30969
30970! **************************************************************************************************
30971!> \brief Gathers data from all processes to one.
30972!> \param[in] sendbuf Data to send to root
30973!> \param[out] recvbuf Received data (on root)
30974!> \param[in] recvcounts Sizes of data received from processes
30975!> \param[in] displs Offsets of data received from processes
30976!> \param[in] root Process which gathers the data
30977!> \param[in] comm Message passing environment identifier
30978!> \par Data length
30979!> Data can have different lengths
30980!> \par Offsets
30981!> Offsets start at 0
30982!> \par MPI mapping
30983!> mpi_gather
30984! **************************************************************************************************
30985 SUBROUTINE mp_igatherv_cv(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
30986 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: sendbuf
30987 COMPLEX(kind=real_4), DIMENSION(:), INTENT(OUT) :: recvbuf
30988 INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
30989 INTEGER, INTENT(IN) :: sendcount, root
30990 CLASS(mp_comm_type), INTENT(IN) :: comm
30991 TYPE(mp_request_type), INTENT(OUT) :: request
30992
30993 CHARACTER(len=*), PARAMETER :: routinen = 'mp_igatherv_cv'
30994
30995 INTEGER :: handle
30996#if defined(__parallel)
30997 INTEGER :: ierr
30998#endif
30999
31000 CALL mp_timeset(routinen, handle)
31001
31002#if defined(__parallel)
31003#if !defined(__GNUC__) || __GNUC__ >= 9
31004 cpassert(is_contiguous(sendbuf))
31005 cpassert(is_contiguous(recvbuf))
31006 cpassert(is_contiguous(recvcounts))
31007 cpassert(is_contiguous(displs))
31008#endif
31009 CALL mpi_igatherv(sendbuf, sendcount, mpi_complex, &
31010 recvbuf, recvcounts, displs, mpi_complex, &
31011 root, comm%handle, request%handle, ierr)
31012 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routinen)
31013 CALL add_perf(perf_id=24, &
31014 count=1, &
31015 msg_size=sendcount*(2*real_4_size))
31016#else
31017 mark_used(sendcount)
31018 mark_used(recvcounts)
31019 mark_used(root)
31020 mark_used(comm)
31021 recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
31022 request = mp_request_null
31023#endif
31024 CALL mp_timestop(handle)
31025 END SUBROUTINE mp_igatherv_cv
31026
31027! **************************************************************************************************
31028!> \brief Gathers a datum from all processes and all processes receive the
31029!> same data
31030!> \param[in] msgout Datum to send
31031!> \param[out] msgin Received data
31032!> \param[in] comm Message passing environment identifier
31033!> \par Data size
31034!> All processes send equal-sized data
31035!> \par MPI mapping
31036!> mpi_allgather
31037! **************************************************************************************************
31038 SUBROUTINE mp_allgather_c (msgout, msgin, comm)
31039 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31040 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:)
31041 CLASS(mp_comm_type), INTENT(IN) :: comm
31042
31043 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c'
31044
31045 INTEGER :: handle
31046#if defined(__parallel)
31047 INTEGER :: ierr, rcount, scount
31048#endif
31049
31050 CALL mp_timeset(routinen, handle)
31051
31052#if defined(__parallel)
31053 scount = 1
31054 rcount = 1
31055 CALL mpi_allgather(msgout, scount, mpi_complex, &
31056 msgin, rcount, mpi_complex, &
31057 comm%handle, ierr)
31058 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31059#else
31060 mark_used(comm)
31061 msgin = msgout
31062#endif
31063 CALL mp_timestop(handle)
31064 END SUBROUTINE mp_allgather_c
31065
31066! **************************************************************************************************
31067!> \brief Gathers a datum from all processes and all processes receive the
31068!> same data
31069!> \param[in] msgout Datum to send
31070!> \param[out] msgin Received data
31071!> \param[in] comm Message passing environment identifier
31072!> \par Data size
31073!> All processes send equal-sized data
31074!> \par MPI mapping
31075!> mpi_allgather
31076! **************************************************************************************************
31077 SUBROUTINE mp_allgather_c2(msgout, msgin, comm)
31078 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31079 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31080 CLASS(mp_comm_type), INTENT(IN) :: comm
31081
31082 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c2'
31083
31084 INTEGER :: handle
31085#if defined(__parallel)
31086 INTEGER :: ierr, rcount, scount
31087#endif
31088
31089 CALL mp_timeset(routinen, handle)
31090
31091#if defined(__parallel)
31092 scount = 1
31093 rcount = 1
31094 CALL mpi_allgather(msgout, scount, mpi_complex, &
31095 msgin, rcount, mpi_complex, &
31096 comm%handle, ierr)
31097 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31098#else
31099 mark_used(comm)
31100 msgin = msgout
31101#endif
31102 CALL mp_timestop(handle)
31103 END SUBROUTINE mp_allgather_c2
31104
31105! **************************************************************************************************
31106!> \brief Gathers a datum from all processes and all processes receive the
31107!> same data
31108!> \param[in] msgout Datum to send
31109!> \param[out] msgin Received data
31110!> \param[in] comm Message passing environment identifier
31111!> \par Data size
31112!> All processes send equal-sized data
31113!> \par MPI mapping
31114!> mpi_allgather
31115! **************************************************************************************************
31116 SUBROUTINE mp_iallgather_c (msgout, msgin, comm, request)
31117 COMPLEX(kind=real_4), INTENT(IN) :: msgout
31118 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31119 CLASS(mp_comm_type), INTENT(IN) :: comm
31120 TYPE(mp_request_type), INTENT(OUT) :: request
31121
31122 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c'
31123
31124 INTEGER :: handle
31125#if defined(__parallel)
31126 INTEGER :: ierr, rcount, scount
31127#endif
31128
31129 CALL mp_timeset(routinen, handle)
31130
31131#if defined(__parallel)
31132#if !defined(__GNUC__) || __GNUC__ >= 9
31133 cpassert(is_contiguous(msgin))
31134#endif
31135 scount = 1
31136 rcount = 1
31137 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31138 msgin, rcount, mpi_complex, &
31139 comm%handle, request%handle, ierr)
31140 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31141#else
31142 mark_used(comm)
31143 msgin = msgout
31144 request = mp_request_null
31145#endif
31146 CALL mp_timestop(handle)
31147 END SUBROUTINE mp_iallgather_c
31148
31149! **************************************************************************************************
31150!> \brief Gathers vector data from all processes and all processes receive the
31151!> same data
31152!> \param[in] msgout Rank-1 data to send
31153!> \param[out] msgin Received data
31154!> \param[in] comm Message passing environment identifier
31155!> \par Data size
31156!> All processes send equal-sized data
31157!> \par Ranks
31158!> The last rank counts the processes
31159!> \par MPI mapping
31160!> mpi_allgather
31161! **************************************************************************************************
31162 SUBROUTINE mp_allgather_c12(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_c12'
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_c12
31189
31190! **************************************************************************************************
31191!> \brief Gathers matrix data from all processes and all processes receive the
31192!> same data
31193!> \param[in] msgout Rank-2 data to send
31194!> \param msgin ...
31195!> \param comm ...
31196!> \note see mp_allgather_c12
31197! **************************************************************************************************
31198 SUBROUTINE mp_allgather_c23(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_c23'
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_c23
31225
31226! **************************************************************************************************
31227!> \brief Gathers rank-3 data from all processes and all processes receive the
31228!> same data
31229!> \param[in] msgout Rank-3 data to send
31230!> \param msgin ...
31231!> \param comm ...
31232!> \note see mp_allgather_c12
31233! **************************************************************************************************
31234 SUBROUTINE mp_allgather_c34(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_c34'
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(:, :, :, 1) = msgout(:, :, :)
31258#endif
31259 CALL mp_timestop(handle)
31260 END SUBROUTINE mp_allgather_c34
31261
31262! **************************************************************************************************
31263!> \brief Gathers rank-2 data from all processes and all processes receive the
31264!> same data
31265!> \param[in] msgout Rank-2 data to send
31266!> \param msgin ...
31267!> \param comm ...
31268!> \note see mp_allgather_c12
31269! **************************************************************************************************
31270 SUBROUTINE mp_allgather_c22(msgout, msgin, comm)
31271 COMPLEX(kind=real_4), INTENT(IN), CONTIGUOUS :: msgout(:, :)
31272 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msgin(:, :)
31273 CLASS(mp_comm_type), INTENT(IN) :: comm
31274
31275 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgather_c22'
31276
31277 INTEGER :: handle
31278#if defined(__parallel)
31279 INTEGER :: ierr, rcount, scount
31280#endif
31281
31282 CALL mp_timeset(routinen, handle)
31283
31284#if defined(__parallel)
31285 scount = SIZE(msgout(:, :))
31286 rcount = scount
31287 CALL mpi_allgather(msgout, scount, mpi_complex, &
31288 msgin, rcount, mpi_complex, &
31289 comm%handle, ierr)
31290 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routinen)
31291#else
31292 mark_used(comm)
31293 msgin(:, :) = msgout(:, :)
31294#endif
31295 CALL mp_timestop(handle)
31296 END SUBROUTINE mp_allgather_c22
31297
31298! **************************************************************************************************
31299!> \brief Gathers rank-1 data from all processes and all processes receive the
31300!> same data
31301!> \param[in] msgout Rank-1 data to send
31302!> \param msgin ...
31303!> \param comm ...
31304!> \param request ...
31305!> \note see mp_allgather_c11
31306! **************************************************************************************************
31307 SUBROUTINE mp_iallgather_c11(msgout, msgin, comm, request)
31308 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31309 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31310 CLASS(mp_comm_type), INTENT(IN) :: comm
31311 TYPE(mp_request_type), INTENT(OUT) :: request
31312
31313 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c11'
31314
31315 INTEGER :: handle
31316#if defined(__parallel)
31317 INTEGER :: ierr, rcount, scount
31318#endif
31319
31320 CALL mp_timeset(routinen, handle)
31321
31322#if defined(__parallel)
31323#if !defined(__GNUC__) || __GNUC__ >= 9
31324 cpassert(is_contiguous(msgout))
31325 cpassert(is_contiguous(msgin))
31326#endif
31327 scount = SIZE(msgout(:))
31328 rcount = scount
31329 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31330 msgin, rcount, mpi_complex, &
31331 comm%handle, request%handle, ierr)
31332 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31333#else
31334 mark_used(comm)
31335 msgin = msgout
31336 request = mp_request_null
31337#endif
31338 CALL mp_timestop(handle)
31339 END SUBROUTINE mp_iallgather_c11
31340
31341! **************************************************************************************************
31342!> \brief Gathers rank-2 data from all processes and all processes receive the
31343!> same data
31344!> \param[in] msgout Rank-2 data to send
31345!> \param msgin ...
31346!> \param comm ...
31347!> \param request ...
31348!> \note see mp_allgather_c12
31349! **************************************************************************************************
31350 SUBROUTINE mp_iallgather_c13(msgout, msgin, comm, request)
31351 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31352 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
31353 CLASS(mp_comm_type), INTENT(IN) :: comm
31354 TYPE(mp_request_type), INTENT(OUT) :: request
31355
31356 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c13'
31357
31358 INTEGER :: handle
31359#if defined(__parallel)
31360 INTEGER :: ierr, rcount, scount
31361#endif
31362
31363 CALL mp_timeset(routinen, handle)
31364
31365#if defined(__parallel)
31366#if !defined(__GNUC__) || __GNUC__ >= 9
31367 cpassert(is_contiguous(msgout))
31368 cpassert(is_contiguous(msgin))
31369#endif
31370
31371 scount = SIZE(msgout(:))
31372 rcount = scount
31373 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31374 msgin, rcount, mpi_complex, &
31375 comm%handle, request%handle, ierr)
31376 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31377#else
31378 mark_used(comm)
31379 msgin(:, 1, 1) = msgout(:)
31380 request = mp_request_null
31381#endif
31382 CALL mp_timestop(handle)
31383 END SUBROUTINE mp_iallgather_c13
31384
31385! **************************************************************************************************
31386!> \brief Gathers rank-2 data from all processes and all processes receive the
31387!> same data
31388!> \param[in] msgout Rank-2 data to send
31389!> \param msgin ...
31390!> \param comm ...
31391!> \param request ...
31392!> \note see mp_allgather_c12
31393! **************************************************************************************************
31394 SUBROUTINE mp_iallgather_c22(msgout, msgin, comm, request)
31395 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :)
31396 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :)
31397 CLASS(mp_comm_type), INTENT(IN) :: comm
31398 TYPE(mp_request_type), INTENT(OUT) :: request
31399
31400 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c22'
31401
31402 INTEGER :: handle
31403#if defined(__parallel)
31404 INTEGER :: ierr, rcount, scount
31405#endif
31406
31407 CALL mp_timeset(routinen, handle)
31408
31409#if defined(__parallel)
31410#if !defined(__GNUC__) || __GNUC__ >= 9
31411 cpassert(is_contiguous(msgout))
31412 cpassert(is_contiguous(msgin))
31413#endif
31414
31415 scount = SIZE(msgout(:, :))
31416 rcount = scount
31417 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31418 msgin, rcount, mpi_complex, &
31419 comm%handle, request%handle, ierr)
31420 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31421#else
31422 mark_used(comm)
31423 msgin(:, :) = msgout(:, :)
31424 request = mp_request_null
31425#endif
31426 CALL mp_timestop(handle)
31427 END SUBROUTINE mp_iallgather_c22
31428
31429! **************************************************************************************************
31430!> \brief Gathers rank-2 data from all processes and all processes receive the
31431!> same data
31432!> \param[in] msgout Rank-2 data to send
31433!> \param msgin ...
31434!> \param comm ...
31435!> \param request ...
31436!> \note see mp_allgather_c12
31437! **************************************************************************************************
31438 SUBROUTINE mp_iallgather_c24(msgout, msgin, comm, request)
31439 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :)
31440 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :, :)
31441 CLASS(mp_comm_type), INTENT(IN) :: comm
31442 TYPE(mp_request_type), INTENT(OUT) :: request
31443
31444 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c24'
31445
31446 INTEGER :: handle
31447#if defined(__parallel)
31448 INTEGER :: ierr, rcount, scount
31449#endif
31450
31451 CALL mp_timeset(routinen, handle)
31452
31453#if defined(__parallel)
31454#if !defined(__GNUC__) || __GNUC__ >= 9
31455 cpassert(is_contiguous(msgout))
31456 cpassert(is_contiguous(msgin))
31457#endif
31458
31459 scount = SIZE(msgout(:, :))
31460 rcount = scount
31461 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31462 msgin, rcount, mpi_complex, &
31463 comm%handle, request%handle, ierr)
31464 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31465#else
31466 mark_used(comm)
31467 msgin(:, :, 1, 1) = msgout(:, :)
31468 request = mp_request_null
31469#endif
31470 CALL mp_timestop(handle)
31471 END SUBROUTINE mp_iallgather_c24
31472
31473! **************************************************************************************************
31474!> \brief Gathers rank-3 data from all processes and all processes receive the
31475!> same data
31476!> \param[in] msgout Rank-3 data to send
31477!> \param msgin ...
31478!> \param comm ...
31479!> \param request ...
31480!> \note see mp_allgather_c12
31481! **************************************************************************************************
31482 SUBROUTINE mp_iallgather_c33(msgout, msgin, comm, request)
31483 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:, :, :)
31484 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:, :, :)
31485 CLASS(mp_comm_type), INTENT(IN) :: comm
31486 TYPE(mp_request_type), INTENT(OUT) :: request
31487
31488 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgather_c33'
31489
31490 INTEGER :: handle
31491#if defined(__parallel)
31492 INTEGER :: ierr, rcount, scount
31493#endif
31494
31495 CALL mp_timeset(routinen, handle)
31496
31497#if defined(__parallel)
31498#if !defined(__GNUC__) || __GNUC__ >= 9
31499 cpassert(is_contiguous(msgout))
31500 cpassert(is_contiguous(msgin))
31501#endif
31502
31503 scount = SIZE(msgout(:, :, :))
31504 rcount = scount
31505 CALL mpi_iallgather(msgout, scount, mpi_complex, &
31506 msgin, rcount, mpi_complex, &
31507 comm%handle, request%handle, ierr)
31508 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routinen)
31509#else
31510 mark_used(comm)
31511 msgin(:, :, :) = msgout(:, :, :)
31512 request = mp_request_null
31513#endif
31514 CALL mp_timestop(handle)
31515 END SUBROUTINE mp_iallgather_c33
31516
31517! **************************************************************************************************
31518!> \brief Gathers vector data from all processes and all processes receive the
31519!> same data
31520!> \param[in] msgout Rank-1 data to send
31521!> \param[out] msgin Received data
31522!> \param[in] rcount Size of sent data for every process
31523!> \param[in] rdispl Offset of sent data for every process
31524!> \param[in] comm Message passing environment identifier
31525!> \par Data size
31526!> Processes can send different-sized data
31527!> \par Ranks
31528!> The last rank counts the processes
31529!> \par Offsets
31530!> Offsets are from 0
31531!> \par MPI mapping
31532!> mpi_allgather
31533! **************************************************************************************************
31534 SUBROUTINE mp_allgatherv_cv(msgout, msgin, rcount, rdispl, comm)
31535 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
31536 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31537 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31538 CLASS(mp_comm_type), INTENT(IN) :: comm
31539
31540 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_cv'
31541
31542 INTEGER :: handle
31543#if defined(__parallel)
31544 INTEGER :: ierr, scount
31545#endif
31546
31547 CALL mp_timeset(routinen, handle)
31548
31549#if defined(__parallel)
31550 scount = SIZE(msgout)
31551 CALL mpi_allgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31552 rdispl, mpi_complex, comm%handle, ierr)
31553 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
31554#else
31555 mark_used(rcount)
31556 mark_used(rdispl)
31557 mark_used(comm)
31558 msgin = msgout
31559#endif
31560 CALL mp_timestop(handle)
31561 END SUBROUTINE mp_allgatherv_cv
31562
31563! **************************************************************************************************
31564!> \brief Gathers vector data from all processes and all processes receive the
31565!> same data
31566!> \param[in] msgout Rank-1 data to send
31567!> \param[out] msgin Received data
31568!> \param[in] rcount Size of sent data for every process
31569!> \param[in] rdispl Offset of sent data for every process
31570!> \param[in] comm Message passing environment identifier
31571!> \par Data size
31572!> Processes can send different-sized data
31573!> \par Ranks
31574!> The last rank counts the processes
31575!> \par Offsets
31576!> Offsets are from 0
31577!> \par MPI mapping
31578!> mpi_allgather
31579! **************************************************************************************************
31580 SUBROUTINE mp_allgatherv_cm2(msgout, msgin, rcount, rdispl, comm)
31581 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
31582 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
31583 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31584 CLASS(mp_comm_type), INTENT(IN) :: comm
31585
31586 CHARACTER(len=*), PARAMETER :: routinen = 'mp_allgatherv_cv'
31587
31588 INTEGER :: handle
31589#if defined(__parallel)
31590 INTEGER :: ierr, scount
31591#endif
31592
31593 CALL mp_timeset(routinen, handle)
31594
31595#if defined(__parallel)
31596 scount = SIZE(msgout)
31597 CALL mpi_allgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31598 rdispl, mpi_complex, comm%handle, ierr)
31599 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routinen)
31600#else
31601 mark_used(rcount)
31602 mark_used(rdispl)
31603 mark_used(comm)
31604 msgin = msgout
31605#endif
31606 CALL mp_timestop(handle)
31607 END SUBROUTINE mp_allgatherv_cm2
31608
31609! **************************************************************************************************
31610!> \brief Gathers vector data from all processes and all processes receive the
31611!> same data
31612!> \param[in] msgout Rank-1 data to send
31613!> \param[out] msgin Received data
31614!> \param[in] rcount Size of sent data for every process
31615!> \param[in] rdispl Offset of sent data for every process
31616!> \param[in] comm Message passing environment identifier
31617!> \par Data size
31618!> Processes can send different-sized data
31619!> \par Ranks
31620!> The last rank counts the processes
31621!> \par Offsets
31622!> Offsets are from 0
31623!> \par MPI mapping
31624!> mpi_allgather
31625! **************************************************************************************************
31626 SUBROUTINE mp_iallgatherv_cv(msgout, msgin, rcount, rdispl, comm, request)
31627 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31628 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31629 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
31630 CLASS(mp_comm_type), INTENT(IN) :: comm
31631 TYPE(mp_request_type), INTENT(OUT) :: request
31632
31633 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_cv'
31634
31635 INTEGER :: handle
31636#if defined(__parallel)
31637 INTEGER :: ierr, scount, rsize
31638#endif
31639
31640 CALL mp_timeset(routinen, handle)
31641
31642#if defined(__parallel)
31643#if !defined(__GNUC__) || __GNUC__ >= 9
31644 cpassert(is_contiguous(msgout))
31645 cpassert(is_contiguous(msgin))
31646 cpassert(is_contiguous(rcount))
31647 cpassert(is_contiguous(rdispl))
31648#endif
31649
31650 scount = SIZE(msgout)
31651 rsize = SIZE(rcount)
31652 CALL mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, &
31653 rdispl, comm, request, ierr)
31654 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
31655#else
31656 mark_used(rcount)
31657 mark_used(rdispl)
31658 mark_used(comm)
31659 msgin = msgout
31660 request = mp_request_null
31661#endif
31662 CALL mp_timestop(handle)
31663 END SUBROUTINE mp_iallgatherv_cv
31664
31665! **************************************************************************************************
31666!> \brief Gathers vector data from all processes and all processes receive the
31667!> same data
31668!> \param[in] msgout Rank-1 data to send
31669!> \param[out] msgin Received data
31670!> \param[in] rcount Size of sent data for every process
31671!> \param[in] rdispl Offset of sent data for every process
31672!> \param[in] comm Message passing environment identifier
31673!> \par Data size
31674!> Processes can send different-sized data
31675!> \par Ranks
31676!> The last rank counts the processes
31677!> \par Offsets
31678!> Offsets are from 0
31679!> \par MPI mapping
31680!> mpi_allgather
31681! **************************************************************************************************
31682 SUBROUTINE mp_iallgatherv_cv2(msgout, msgin, rcount, rdispl, comm, request)
31683 COMPLEX(kind=real_4), INTENT(IN) :: msgout(:)
31684 COMPLEX(kind=real_4), INTENT(OUT) :: msgin(:)
31685 INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
31686 CLASS(mp_comm_type), INTENT(IN) :: comm
31687 TYPE(mp_request_type), INTENT(OUT) :: request
31688
31689 CHARACTER(len=*), PARAMETER :: routinen = 'mp_iallgatherv_cv2'
31690
31691 INTEGER :: handle
31692#if defined(__parallel)
31693 INTEGER :: ierr, scount, rsize
31694#endif
31695
31696 CALL mp_timeset(routinen, handle)
31697
31698#if defined(__parallel)
31699#if !defined(__GNUC__) || __GNUC__ >= 9
31700 cpassert(is_contiguous(msgout))
31701 cpassert(is_contiguous(msgin))
31702 cpassert(is_contiguous(rcount))
31703 cpassert(is_contiguous(rdispl))
31704#endif
31705
31706 scount = SIZE(msgout)
31707 rsize = SIZE(rcount)
31708 CALL mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, &
31709 rdispl, comm, request, ierr)
31710 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routinen)
31711#else
31712 mark_used(rcount)
31713 mark_used(rdispl)
31714 mark_used(comm)
31715 msgin = msgout
31716 request = mp_request_null
31717#endif
31718 CALL mp_timestop(handle)
31719 END SUBROUTINE mp_iallgatherv_cv2
31720
31721! **************************************************************************************************
31722!> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
31723!> the issue is with the rank of rcount and rdispl
31724!> \param count ...
31725!> \param array_of_requests ...
31726!> \param array_of_statuses ...
31727!> \param ierr ...
31728!> \author Alfio Lazzaro
31729! **************************************************************************************************
31730#if defined(__parallel)
31731 SUBROUTINE mp_iallgatherv_cv_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
31732 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:)
31733 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31734 INTEGER, INTENT(IN) :: rsize
31735 INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
31736 CLASS(mp_comm_type), INTENT(IN) :: comm
31737 TYPE(mp_request_type), INTENT(OUT) :: request
31738 INTEGER, INTENT(INOUT) :: ierr
31739
31740 CALL mpi_iallgatherv(msgout, scount, mpi_complex, msgin, rcount, &
31741 rdispl, mpi_complex, comm%handle, request%handle, ierr)
31742
31743 END SUBROUTINE mp_iallgatherv_cv_internal
31744#endif
31745
31746! **************************************************************************************************
31747!> \brief Sums a vector and partitions the result among processes
31748!> \param[in] msgout Data to sum
31749!> \param[out] msgin Received portion of summed data
31750!> \param[in] rcount Partition sizes of the summed data for
31751!> every process
31752!> \param[in] comm Message passing environment identifier
31753! **************************************************************************************************
31754 SUBROUTINE mp_sum_scatter_cv(msgout, msgin, rcount, comm)
31755 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgout(:, :)
31756 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgin(:)
31757 INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
31758 CLASS(mp_comm_type), INTENT(IN) :: comm
31759
31760 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sum_scatter_cv'
31761
31762 INTEGER :: handle
31763#if defined(__parallel)
31764 INTEGER :: ierr
31765#endif
31766
31767 CALL mp_timeset(routinen, handle)
31768
31769#if defined(__parallel)
31770 CALL mpi_reduce_scatter(msgout, msgin, rcount, mpi_complex, mpi_sum, &
31771 comm%handle, ierr)
31772 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routinen)
31773
31774 CALL add_perf(perf_id=3, count=1, &
31775 msg_size=rcount(1)*2*(2*real_4_size))
31776#else
31777 mark_used(rcount)
31778 mark_used(comm)
31779 msgin = msgout(:, 1)
31780#endif
31781 CALL mp_timestop(handle)
31782 END SUBROUTINE mp_sum_scatter_cv
31783
31784! **************************************************************************************************
31785!> \brief Sends and receives vector data
31786!> \param[in] msgin Data to send
31787!> \param[in] dest Process to send data to
31788!> \param[out] msgout Received data
31789!> \param[in] source Process from which to receive
31790!> \param[in] comm Message passing environment identifier
31791!> \param[in] tag Send and recv tag (default: 0)
31792! **************************************************************************************************
31793 SUBROUTINE mp_sendrecv_c (msgin, dest, msgout, source, comm, tag)
31794 COMPLEX(kind=real_4), INTENT(IN) :: msgin
31795 INTEGER, INTENT(IN) :: dest
31796 COMPLEX(kind=real_4), INTENT(OUT) :: msgout
31797 INTEGER, INTENT(IN) :: source
31798 CLASS(mp_comm_type), INTENT(IN) :: comm
31799 INTEGER, INTENT(IN), OPTIONAL :: tag
31800
31801 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_c'
31802
31803 INTEGER :: handle
31804#if defined(__parallel)
31805 INTEGER :: ierr, msglen_in, msglen_out, &
31806 recv_tag, send_tag
31807#endif
31808
31809 CALL mp_timeset(routinen, handle)
31810
31811#if defined(__parallel)
31812 msglen_in = 1
31813 msglen_out = 1
31814 send_tag = 0 ! cannot think of something better here, this might be dangerous
31815 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31816 IF (PRESENT(tag)) THEN
31817 send_tag = tag
31818 recv_tag = tag
31819 END IF
31820 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31821 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31822 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31823 CALL add_perf(perf_id=7, count=1, &
31824 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31825#else
31826 mark_used(dest)
31827 mark_used(source)
31828 mark_used(comm)
31829 mark_used(tag)
31830 msgout = msgin
31831#endif
31832 CALL mp_timestop(handle)
31833 END SUBROUTINE mp_sendrecv_c
31834
31835! **************************************************************************************************
31836!> \brief Sends and receives vector data
31837!> \param[in] msgin Data to send
31838!> \param[in] dest Process to send data to
31839!> \param[out] msgout Received data
31840!> \param[in] source Process from which to receive
31841!> \param[in] comm Message passing environment identifier
31842!> \param[in] tag Send and recv tag (default: 0)
31843! **************************************************************************************************
31844 SUBROUTINE mp_sendrecv_cv(msgin, dest, msgout, source, comm, tag)
31845 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:)
31846 INTEGER, INTENT(IN) :: dest
31847 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:)
31848 INTEGER, INTENT(IN) :: source
31849 CLASS(mp_comm_type), INTENT(IN) :: comm
31850 INTEGER, INTENT(IN), OPTIONAL :: tag
31851
31852 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cv'
31853
31854 INTEGER :: handle
31855#if defined(__parallel)
31856 INTEGER :: ierr, msglen_in, msglen_out, &
31857 recv_tag, send_tag
31858#endif
31859
31860 CALL mp_timeset(routinen, handle)
31861
31862#if defined(__parallel)
31863 msglen_in = SIZE(msgin)
31864 msglen_out = SIZE(msgout)
31865 send_tag = 0 ! cannot think of something better here, this might be dangerous
31866 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31867 IF (PRESENT(tag)) THEN
31868 send_tag = tag
31869 recv_tag = tag
31870 END IF
31871 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31872 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31873 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31874 CALL add_perf(perf_id=7, count=1, &
31875 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31876#else
31877 mark_used(dest)
31878 mark_used(source)
31879 mark_used(comm)
31880 mark_used(tag)
31881 msgout = msgin
31882#endif
31883 CALL mp_timestop(handle)
31884 END SUBROUTINE mp_sendrecv_cv
31885
31886! **************************************************************************************************
31887!> \brief Sends and receives matrix data
31888!> \param msgin ...
31889!> \param dest ...
31890!> \param msgout ...
31891!> \param source ...
31892!> \param comm ...
31893!> \param tag ...
31894!> \note see mp_sendrecv_cv
31895! **************************************************************************************************
31896 SUBROUTINE mp_sendrecv_cm2(msgin, dest, msgout, source, comm, tag)
31897 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :)
31898 INTEGER, INTENT(IN) :: dest
31899 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
31900 INTEGER, INTENT(IN) :: source
31901 CLASS(mp_comm_type), INTENT(IN) :: comm
31902 INTEGER, INTENT(IN), OPTIONAL :: tag
31903
31904 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm2'
31905
31906 INTEGER :: handle
31907#if defined(__parallel)
31908 INTEGER :: ierr, msglen_in, msglen_out, &
31909 recv_tag, send_tag
31910#endif
31911
31912 CALL mp_timeset(routinen, handle)
31913
31914#if defined(__parallel)
31915 msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
31916 msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
31917 send_tag = 0 ! cannot think of something better here, this might be dangerous
31918 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31919 IF (PRESENT(tag)) THEN
31920 send_tag = tag
31921 recv_tag = tag
31922 END IF
31923 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31924 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31925 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31926 CALL add_perf(perf_id=7, count=1, &
31927 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31928#else
31929 mark_used(dest)
31930 mark_used(source)
31931 mark_used(comm)
31932 mark_used(tag)
31933 msgout = msgin
31934#endif
31935 CALL mp_timestop(handle)
31936 END SUBROUTINE mp_sendrecv_cm2
31937
31938! **************************************************************************************************
31939!> \brief Sends and receives rank-3 data
31940!> \param msgin ...
31941!> \param dest ...
31942!> \param msgout ...
31943!> \param source ...
31944!> \param comm ...
31945!> \note see mp_sendrecv_cv
31946! **************************************************************************************************
31947 SUBROUTINE mp_sendrecv_cm3(msgin, dest, msgout, source, comm, tag)
31948 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
31949 INTEGER, INTENT(IN) :: dest
31950 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
31951 INTEGER, INTENT(IN) :: source
31952 CLASS(mp_comm_type), INTENT(IN) :: comm
31953 INTEGER, INTENT(IN), OPTIONAL :: tag
31954
31955 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm3'
31956
31957 INTEGER :: handle
31958#if defined(__parallel)
31959 INTEGER :: ierr, msglen_in, msglen_out, &
31960 recv_tag, send_tag
31961#endif
31962
31963 CALL mp_timeset(routinen, handle)
31964
31965#if defined(__parallel)
31966 msglen_in = SIZE(msgin)
31967 msglen_out = SIZE(msgout)
31968 send_tag = 0 ! cannot think of something better here, this might be dangerous
31969 recv_tag = 0 ! cannot think of something better here, this might be dangerous
31970 IF (PRESENT(tag)) THEN
31971 send_tag = tag
31972 recv_tag = tag
31973 END IF
31974 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
31975 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
31976 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
31977 CALL add_perf(perf_id=7, count=1, &
31978 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
31979#else
31980 mark_used(dest)
31981 mark_used(source)
31982 mark_used(comm)
31983 mark_used(tag)
31984 msgout = msgin
31985#endif
31986 CALL mp_timestop(handle)
31987 END SUBROUTINE mp_sendrecv_cm3
31988
31989! **************************************************************************************************
31990!> \brief Sends and receives rank-4 data
31991!> \param msgin ...
31992!> \param dest ...
31993!> \param msgout ...
31994!> \param source ...
31995!> \param comm ...
31996!> \note see mp_sendrecv_cv
31997! **************************************************************************************************
31998 SUBROUTINE mp_sendrecv_cm4(msgin, dest, msgout, source, comm, tag)
31999 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
32000 INTEGER, INTENT(IN) :: dest
32001 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
32002 INTEGER, INTENT(IN) :: source
32003 CLASS(mp_comm_type), INTENT(IN) :: comm
32004 INTEGER, INTENT(IN), OPTIONAL :: tag
32005
32006 CHARACTER(len=*), PARAMETER :: routinen = 'mp_sendrecv_cm4'
32007
32008 INTEGER :: handle
32009#if defined(__parallel)
32010 INTEGER :: ierr, msglen_in, msglen_out, &
32011 recv_tag, send_tag
32012#endif
32013
32014 CALL mp_timeset(routinen, handle)
32015
32016#if defined(__parallel)
32017 msglen_in = SIZE(msgin)
32018 msglen_out = SIZE(msgout)
32019 send_tag = 0 ! cannot think of something better here, this might be dangerous
32020 recv_tag = 0 ! cannot think of something better here, this might be dangerous
32021 IF (PRESENT(tag)) THEN
32022 send_tag = tag
32023 recv_tag = tag
32024 END IF
32025 CALL mpi_sendrecv(msgin, msglen_in, mpi_complex, dest, send_tag, msgout, &
32026 msglen_out, mpi_complex, source, recv_tag, comm%handle, mpi_status_ignore, ierr)
32027 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routinen)
32028 CALL add_perf(perf_id=7, count=1, &
32029 msg_size=(msglen_in + msglen_out)*(2*real_4_size)/2)
32030#else
32031 mark_used(dest)
32032 mark_used(source)
32033 mark_used(comm)
32034 mark_used(tag)
32035 msgout = msgin
32036#endif
32037 CALL mp_timestop(handle)
32038 END SUBROUTINE mp_sendrecv_cm4
32039
32040! **************************************************************************************************
32041!> \brief Non-blocking send and receive of a scalar
32042!> \param[in] msgin Scalar data to send
32043!> \param[in] dest Which process to send to
32044!> \param[out] msgout Receive data into this pointer
32045!> \param[in] source Process to receive from
32046!> \param[in] comm Message passing environment identifier
32047!> \param[out] send_request Request handle for the send
32048!> \param[out] recv_request Request handle for the receive
32049!> \param[in] tag (optional) tag to differentiate requests
32050!> \par Implementation
32051!> Calls mpi_isend and mpi_irecv.
32052!> \par History
32053!> 02.2005 created [Alfio Lazzaro]
32054! **************************************************************************************************
32055 SUBROUTINE mp_isendrecv_c (msgin, dest, msgout, source, comm, send_request, &
32056 recv_request, tag)
32057 COMPLEX(kind=real_4), INTENT(IN) :: msgin
32058 INTEGER, INTENT(IN) :: dest
32059 COMPLEX(kind=real_4), INTENT(INOUT) :: msgout
32060 INTEGER, INTENT(IN) :: source
32061 CLASS(mp_comm_type), INTENT(IN) :: comm
32062 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
32063 INTEGER, INTENT(in), OPTIONAL :: tag
32064
32065 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_c'
32066
32067 INTEGER :: handle
32068#if defined(__parallel)
32069 INTEGER :: ierr, my_tag
32070#endif
32071
32072 CALL mp_timeset(routinen, handle)
32073
32074#if defined(__parallel)
32075 my_tag = 0
32076 IF (PRESENT(tag)) my_tag = tag
32077
32078 CALL mpi_irecv(msgout, 1, mpi_complex, source, my_tag, &
32079 comm%handle, recv_request%handle, ierr)
32080 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32081
32082 CALL mpi_isend(msgin, 1, mpi_complex, dest, my_tag, &
32083 comm%handle, send_request%handle, ierr)
32084 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32085
32086 CALL add_perf(perf_id=8, count=1, msg_size=2*(2*real_4_size))
32087#else
32088 mark_used(dest)
32089 mark_used(source)
32090 mark_used(comm)
32091 mark_used(tag)
32092 send_request = mp_request_null
32093 recv_request = mp_request_null
32094 msgout = msgin
32095#endif
32096 CALL mp_timestop(handle)
32097 END SUBROUTINE mp_isendrecv_c
32098
32099! **************************************************************************************************
32100!> \brief Non-blocking send and receive of a vector
32101!> \param[in] msgin Vector data to send
32102!> \param[in] dest Which process to send to
32103!> \param[out] msgout Receive data into this pointer
32104!> \param[in] source Process to receive from
32105!> \param[in] comm Message passing environment identifier
32106!> \param[out] send_request Request handle for the send
32107!> \param[out] recv_request Request handle for the receive
32108!> \param[in] tag (optional) tag to differentiate requests
32109!> \par Implementation
32110!> Calls mpi_isend and mpi_irecv.
32111!> \par History
32112!> 11.2004 created [Joost VandeVondele]
32113!> \note
32114!> arrays can be pointers or assumed shape, but they must be contiguous!
32115! **************************************************************************************************
32116 SUBROUTINE mp_isendrecv_cv(msgin, dest, msgout, source, comm, send_request, &
32117 recv_request, tag)
32118 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
32119 INTEGER, INTENT(IN) :: dest
32120 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
32121 INTEGER, INTENT(IN) :: source
32122 CLASS(mp_comm_type), INTENT(IN) :: comm
32123 TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
32124 INTEGER, INTENT(in), OPTIONAL :: tag
32125
32126 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isendrecv_cv'
32127
32128 INTEGER :: handle
32129#if defined(__parallel)
32130 INTEGER :: ierr, msglen, my_tag
32131 COMPLEX(kind=real_4) :: foo
32132#endif
32133
32134 CALL mp_timeset(routinen, handle)
32135
32136#if defined(__parallel)
32137#if !defined(__GNUC__) || __GNUC__ >= 9
32138 cpassert(is_contiguous(msgout))
32139 cpassert(is_contiguous(msgin))
32140#endif
32141
32142 my_tag = 0
32143 IF (PRESENT(tag)) my_tag = tag
32144
32145 msglen = SIZE(msgout, 1)
32146 IF (msglen > 0) THEN
32147 CALL mpi_irecv(msgout(1), msglen, mpi_complex, source, my_tag, &
32148 comm%handle, recv_request%handle, ierr)
32149 ELSE
32150 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32151 comm%handle, recv_request%handle, ierr)
32152 END IF
32153 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32154
32155 msglen = SIZE(msgin, 1)
32156 IF (msglen > 0) THEN
32157 CALL mpi_isend(msgin(1), msglen, mpi_complex, dest, my_tag, &
32158 comm%handle, send_request%handle, ierr)
32159 ELSE
32160 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32161 comm%handle, send_request%handle, ierr)
32162 END IF
32163 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32164
32165 msglen = (msglen + SIZE(msgout, 1) + 1)/2
32166 CALL add_perf(perf_id=8, count=1, msg_size=msglen*(2*real_4_size))
32167#else
32168 mark_used(dest)
32169 mark_used(source)
32170 mark_used(comm)
32171 mark_used(tag)
32172 send_request = mp_request_null
32173 recv_request = mp_request_null
32174 msgout = msgin
32175#endif
32176 CALL mp_timestop(handle)
32177 END SUBROUTINE mp_isendrecv_cv
32178
32179! **************************************************************************************************
32180!> \brief Non-blocking send of vector data
32181!> \param msgin ...
32182!> \param dest ...
32183!> \param comm ...
32184!> \param request ...
32185!> \param tag ...
32186!> \par History
32187!> 08.2003 created [f&j]
32188!> \note see mp_isendrecv_cv
32189!> \note
32190!> arrays can be pointers or assumed shape, but they must be contiguous!
32191! **************************************************************************************************
32192 SUBROUTINE mp_isend_cv(msgin, dest, comm, request, tag)
32193 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: msgin
32194 INTEGER, INTENT(IN) :: dest
32195 CLASS(mp_comm_type), INTENT(IN) :: comm
32196 TYPE(mp_request_type), INTENT(out) :: request
32197 INTEGER, INTENT(in), OPTIONAL :: tag
32198
32199 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cv'
32200
32201 INTEGER :: handle, ierr
32202#if defined(__parallel)
32203 INTEGER :: msglen, my_tag
32204 COMPLEX(kind=real_4) :: foo(1)
32205#endif
32206
32207 CALL mp_timeset(routinen, handle)
32208
32209#if defined(__parallel)
32210#if !defined(__GNUC__) || __GNUC__ >= 9
32211 cpassert(is_contiguous(msgin))
32212#endif
32213 my_tag = 0
32214 IF (PRESENT(tag)) my_tag = tag
32215
32216 msglen = SIZE(msgin)
32217 IF (msglen > 0) THEN
32218 CALL mpi_isend(msgin(1), msglen, mpi_complex, dest, my_tag, &
32219 comm%handle, request%handle, ierr)
32220 ELSE
32221 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32222 comm%handle, request%handle, ierr)
32223 END IF
32224 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32225
32226 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32227#else
32228 mark_used(msgin)
32229 mark_used(dest)
32230 mark_used(comm)
32231 mark_used(request)
32232 mark_used(tag)
32233 ierr = 1
32234 request = mp_request_null
32235 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32236#endif
32237 CALL mp_timestop(handle)
32238 END SUBROUTINE mp_isend_cv
32239
32240! **************************************************************************************************
32241!> \brief Non-blocking send of matrix data
32242!> \param msgin ...
32243!> \param dest ...
32244!> \param comm ...
32245!> \param request ...
32246!> \param tag ...
32247!> \par History
32248!> 2009-11-25 [UB] Made type-generic for templates
32249!> \author fawzi
32250!> \note see mp_isendrecv_cv
32251!> \note see mp_isend_cv
32252!> \note
32253!> arrays can be pointers or assumed shape, but they must be contiguous!
32254! **************************************************************************************************
32255 SUBROUTINE mp_isend_cm2(msgin, dest, comm, request, tag)
32256 COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(IN) :: msgin
32257 INTEGER, INTENT(IN) :: dest
32258 CLASS(mp_comm_type), INTENT(IN) :: comm
32259 TYPE(mp_request_type), INTENT(out) :: request
32260 INTEGER, INTENT(in), OPTIONAL :: tag
32261
32262 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm2'
32263
32264 INTEGER :: handle, ierr
32265#if defined(__parallel)
32266 INTEGER :: msglen, my_tag
32267 COMPLEX(kind=real_4) :: foo(1)
32268#endif
32269
32270 CALL mp_timeset(routinen, handle)
32271
32272#if defined(__parallel)
32273#if !defined(__GNUC__) || __GNUC__ >= 9
32274 cpassert(is_contiguous(msgin))
32275#endif
32276
32277 my_tag = 0
32278 IF (PRESENT(tag)) my_tag = tag
32279
32280 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
32281 IF (msglen > 0) THEN
32282 CALL mpi_isend(msgin(1, 1), msglen, mpi_complex, dest, my_tag, &
32283 comm%handle, request%handle, ierr)
32284 ELSE
32285 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32286 comm%handle, request%handle, ierr)
32287 END IF
32288 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32289
32290 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32291#else
32292 mark_used(msgin)
32293 mark_used(dest)
32294 mark_used(comm)
32295 mark_used(request)
32296 mark_used(tag)
32297 ierr = 1
32298 request = mp_request_null
32299 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32300#endif
32301 CALL mp_timestop(handle)
32302 END SUBROUTINE mp_isend_cm2
32303
32304! **************************************************************************************************
32305!> \brief Non-blocking send of rank-3 data
32306!> \param msgin ...
32307!> \param dest ...
32308!> \param comm ...
32309!> \param request ...
32310!> \param tag ...
32311!> \par History
32312!> 9.2008 added _rm3 subroutine [Iain Bethune]
32313!> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
32314!> 2009-11-25 [UB] Made type-generic for templates
32315!> \author fawzi
32316!> \note see mp_isendrecv_cv
32317!> \note see mp_isend_cv
32318!> \note
32319!> arrays can be pointers or assumed shape, but they must be contiguous!
32320! **************************************************************************************************
32321 SUBROUTINE mp_isend_cm3(msgin, dest, comm, request, tag)
32322 COMPLEX(kind=real_4), DIMENSION(:, :, :), INTENT(IN) :: msgin
32323 INTEGER, INTENT(IN) :: dest
32324 CLASS(mp_comm_type), INTENT(IN) :: comm
32325 TYPE(mp_request_type), INTENT(out) :: request
32326 INTEGER, INTENT(in), OPTIONAL :: tag
32327
32328 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm3'
32329
32330 INTEGER :: handle, ierr
32331#if defined(__parallel)
32332 INTEGER :: msglen, my_tag
32333 COMPLEX(kind=real_4) :: foo(1)
32334#endif
32335
32336 CALL mp_timeset(routinen, handle)
32337
32338#if defined(__parallel)
32339#if !defined(__GNUC__) || __GNUC__ >= 9
32340 cpassert(is_contiguous(msgin))
32341#endif
32342
32343 my_tag = 0
32344 IF (PRESENT(tag)) my_tag = tag
32345
32346 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
32347 IF (msglen > 0) THEN
32348 CALL mpi_isend(msgin(1, 1, 1), msglen, mpi_complex, dest, my_tag, &
32349 comm%handle, request%handle, ierr)
32350 ELSE
32351 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32352 comm%handle, request%handle, ierr)
32353 END IF
32354 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32355
32356 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32357#else
32358 mark_used(msgin)
32359 mark_used(dest)
32360 mark_used(comm)
32361 mark_used(request)
32362 mark_used(tag)
32363 ierr = 1
32364 request = mp_request_null
32365 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32366#endif
32367 CALL mp_timestop(handle)
32368 END SUBROUTINE mp_isend_cm3
32369
32370! **************************************************************************************************
32371!> \brief Non-blocking send of rank-4 data
32372!> \param msgin the input message
32373!> \param dest the destination processor
32374!> \param comm the communicator object
32375!> \param request the communication request id
32376!> \param tag the message tag
32377!> \par History
32378!> 2.2016 added _cm4 subroutine [Nico Holmberg]
32379!> \author fawzi
32380!> \note see mp_isend_cv
32381!> \note
32382!> arrays can be pointers or assumed shape, but they must be contiguous!
32383! **************************************************************************************************
32384 SUBROUTINE mp_isend_cm4(msgin, dest, comm, request, tag)
32385 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), INTENT(IN) :: msgin
32386 INTEGER, INTENT(IN) :: dest
32387 CLASS(mp_comm_type), INTENT(IN) :: comm
32388 TYPE(mp_request_type), INTENT(out) :: request
32389 INTEGER, INTENT(in), OPTIONAL :: tag
32390
32391 CHARACTER(len=*), PARAMETER :: routinen = 'mp_isend_cm4'
32392
32393 INTEGER :: handle, ierr
32394#if defined(__parallel)
32395 INTEGER :: msglen, my_tag
32396 COMPLEX(kind=real_4) :: foo(1)
32397#endif
32398
32399 CALL mp_timeset(routinen, handle)
32400
32401#if defined(__parallel)
32402#if !defined(__GNUC__) || __GNUC__ >= 9
32403 cpassert(is_contiguous(msgin))
32404#endif
32405
32406 my_tag = 0
32407 IF (PRESENT(tag)) my_tag = tag
32408
32409 msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
32410 IF (msglen > 0) THEN
32411 CALL mpi_isend(msgin(1, 1, 1, 1), msglen, mpi_complex, dest, my_tag, &
32412 comm%handle, request%handle, ierr)
32413 ELSE
32414 CALL mpi_isend(foo, msglen, mpi_complex, dest, my_tag, &
32415 comm%handle, request%handle, ierr)
32416 END IF
32417 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routinen)
32418
32419 CALL add_perf(perf_id=11, count=1, msg_size=msglen*(2*real_4_size))
32420#else
32421 mark_used(msgin)
32422 mark_used(dest)
32423 mark_used(comm)
32424 mark_used(request)
32425 mark_used(tag)
32426 ierr = 1
32427 request = mp_request_null
32428 CALL mp_stop(ierr, "mp_isend called in non parallel case")
32429#endif
32430 CALL mp_timestop(handle)
32431 END SUBROUTINE mp_isend_cm4
32432
32433! **************************************************************************************************
32434!> \brief Non-blocking receive of vector data
32435!> \param msgout ...
32436!> \param source ...
32437!> \param comm ...
32438!> \param request ...
32439!> \param tag ...
32440!> \par History
32441!> 08.2003 created [f&j]
32442!> 2009-11-25 [UB] Made type-generic for templates
32443!> \note see mp_isendrecv_cv
32444!> \note
32445!> arrays can be pointers or assumed shape, but they must be contiguous!
32446! **************************************************************************************************
32447 SUBROUTINE mp_irecv_cv(msgout, source, comm, request, tag)
32448 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT) :: msgout
32449 INTEGER, INTENT(IN) :: source
32450 CLASS(mp_comm_type), INTENT(IN) :: comm
32451 TYPE(mp_request_type), INTENT(out) :: request
32452 INTEGER, INTENT(in), OPTIONAL :: tag
32453
32454 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cv'
32455
32456 INTEGER :: handle
32457#if defined(__parallel)
32458 INTEGER :: ierr, msglen, my_tag
32459 COMPLEX(kind=real_4) :: foo(1)
32460#endif
32461
32462 CALL mp_timeset(routinen, handle)
32463
32464#if defined(__parallel)
32465#if !defined(__GNUC__) || __GNUC__ >= 9
32466 cpassert(is_contiguous(msgout))
32467#endif
32468
32469 my_tag = 0
32470 IF (PRESENT(tag)) my_tag = tag
32471
32472 msglen = SIZE(msgout)
32473 IF (msglen > 0) THEN
32474 CALL mpi_irecv(msgout(1), msglen, mpi_complex, source, my_tag, &
32475 comm%handle, request%handle, ierr)
32476 ELSE
32477 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32478 comm%handle, request%handle, ierr)
32479 END IF
32480 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32481
32482 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32483#else
32484 cpabort("mp_irecv called in non parallel case")
32485 mark_used(msgout)
32486 mark_used(source)
32487 mark_used(comm)
32488 mark_used(tag)
32489 request = mp_request_null
32490#endif
32491 CALL mp_timestop(handle)
32492 END SUBROUTINE mp_irecv_cv
32493
32494! **************************************************************************************************
32495!> \brief Non-blocking receive of matrix data
32496!> \param msgout ...
32497!> \param source ...
32498!> \param comm ...
32499!> \param request ...
32500!> \param tag ...
32501!> \par History
32502!> 2009-11-25 [UB] Made type-generic for templates
32503!> \author fawzi
32504!> \note see mp_isendrecv_cv
32505!> \note see mp_irecv_cv
32506!> \note
32507!> arrays can be pointers or assumed shape, but they must be contiguous!
32508! **************************************************************************************************
32509 SUBROUTINE mp_irecv_cm2(msgout, source, comm, request, tag)
32510 COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(INOUT) :: msgout
32511 INTEGER, INTENT(IN) :: source
32512 CLASS(mp_comm_type), INTENT(IN) :: comm
32513 TYPE(mp_request_type), INTENT(out) :: request
32514 INTEGER, INTENT(in), OPTIONAL :: tag
32515
32516 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm2'
32517
32518 INTEGER :: handle
32519#if defined(__parallel)
32520 INTEGER :: ierr, msglen, my_tag
32521 COMPLEX(kind=real_4) :: foo(1)
32522#endif
32523
32524 CALL mp_timeset(routinen, handle)
32525
32526#if defined(__parallel)
32527#if !defined(__GNUC__) || __GNUC__ >= 9
32528 cpassert(is_contiguous(msgout))
32529#endif
32530
32531 my_tag = 0
32532 IF (PRESENT(tag)) my_tag = tag
32533
32534 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
32535 IF (msglen > 0) THEN
32536 CALL mpi_irecv(msgout(1, 1), msglen, mpi_complex, source, my_tag, &
32537 comm%handle, request%handle, ierr)
32538 ELSE
32539 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32540 comm%handle, request%handle, ierr)
32541 END IF
32542 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routinen)
32543
32544 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32545#else
32546 mark_used(msgout)
32547 mark_used(source)
32548 mark_used(comm)
32549 mark_used(tag)
32550 request = mp_request_null
32551 cpabort("mp_irecv called in non parallel case")
32552#endif
32553 CALL mp_timestop(handle)
32554 END SUBROUTINE mp_irecv_cm2
32555
32556! **************************************************************************************************
32557!> \brief Non-blocking send of rank-3 data
32558!> \param msgout ...
32559!> \param source ...
32560!> \param comm ...
32561!> \param request ...
32562!> \param tag ...
32563!> \par History
32564!> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
32565!> 2009-11-25 [UB] Made type-generic for templates
32566!> \author fawzi
32567!> \note see mp_isendrecv_cv
32568!> \note see mp_irecv_cv
32569!> \note
32570!> arrays can be pointers or assumed shape, but they must be contiguous!
32571! **************************************************************************************************
32572 SUBROUTINE mp_irecv_cm3(msgout, source, comm, request, tag)
32573 COMPLEX(kind=real_4), DIMENSION(:, :, :), INTENT(INOUT) :: msgout
32574 INTEGER, INTENT(IN) :: source
32575 CLASS(mp_comm_type), INTENT(IN) :: comm
32576 TYPE(mp_request_type), INTENT(out) :: request
32577 INTEGER, INTENT(in), OPTIONAL :: tag
32578
32579 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm3'
32580
32581 INTEGER :: handle
32582#if defined(__parallel)
32583 INTEGER :: ierr, msglen, my_tag
32584 COMPLEX(kind=real_4) :: foo(1)
32585#endif
32586
32587 CALL mp_timeset(routinen, handle)
32588
32589#if defined(__parallel)
32590#if !defined(__GNUC__) || __GNUC__ >= 9
32591 cpassert(is_contiguous(msgout))
32592#endif
32593
32594 my_tag = 0
32595 IF (PRESENT(tag)) my_tag = tag
32596
32597 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
32598 IF (msglen > 0) THEN
32599 CALL mpi_irecv(msgout(1, 1, 1), msglen, mpi_complex, source, my_tag, &
32600 comm%handle, request%handle, ierr)
32601 ELSE
32602 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32603 comm%handle, request%handle, ierr)
32604 END IF
32605 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
32606
32607 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32608#else
32609 mark_used(msgout)
32610 mark_used(source)
32611 mark_used(comm)
32612 mark_used(tag)
32613 request = mp_request_null
32614 cpabort("mp_irecv called in non parallel case")
32615#endif
32616 CALL mp_timestop(handle)
32617 END SUBROUTINE mp_irecv_cm3
32618
32619! **************************************************************************************************
32620!> \brief Non-blocking receive of rank-4 data
32621!> \param msgout the output message
32622!> \param source the source processor
32623!> \param comm the communicator object
32624!> \param request the communication request id
32625!> \param tag the message tag
32626!> \par History
32627!> 2.2016 added _cm4 subroutine [Nico Holmberg]
32628!> \author fawzi
32629!> \note see mp_irecv_cv
32630!> \note
32631!> arrays can be pointers or assumed shape, but they must be contiguous!
32632! **************************************************************************************************
32633 SUBROUTINE mp_irecv_cm4(msgout, source, comm, request, tag)
32634 COMPLEX(kind=real_4), DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
32635 INTEGER, INTENT(IN) :: source
32636 CLASS(mp_comm_type), INTENT(IN) :: comm
32637 TYPE(mp_request_type), INTENT(out) :: request
32638 INTEGER, INTENT(in), OPTIONAL :: tag
32639
32640 CHARACTER(len=*), PARAMETER :: routinen = 'mp_irecv_cm4'
32641
32642 INTEGER :: handle
32643#if defined(__parallel)
32644 INTEGER :: ierr, msglen, my_tag
32645 COMPLEX(kind=real_4) :: foo(1)
32646#endif
32647
32648 CALL mp_timeset(routinen, handle)
32649
32650#if defined(__parallel)
32651#if !defined(__GNUC__) || __GNUC__ >= 9
32652 cpassert(is_contiguous(msgout))
32653#endif
32654
32655 my_tag = 0
32656 IF (PRESENT(tag)) my_tag = tag
32657
32658 msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
32659 IF (msglen > 0) THEN
32660 CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, mpi_complex, source, my_tag, &
32661 comm%handle, request%handle, ierr)
32662 ELSE
32663 CALL mpi_irecv(foo, msglen, mpi_complex, source, my_tag, &
32664 comm%handle, request%handle, ierr)
32665 END IF
32666 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routinen)
32667
32668 CALL add_perf(perf_id=12, count=1, msg_size=msglen*(2*real_4_size))
32669#else
32670 mark_used(msgout)
32671 mark_used(source)
32672 mark_used(comm)
32673 mark_used(tag)
32674 request = mp_request_null
32675 cpabort("mp_irecv called in non parallel case")
32676#endif
32677 CALL mp_timestop(handle)
32678 END SUBROUTINE mp_irecv_cm4
32679
32680! **************************************************************************************************
32681!> \brief Window initialization function for vector data
32682!> \param base ...
32683!> \param comm ...
32684!> \param win ...
32685!> \par History
32686!> 02.2015 created [Alfio Lazzaro]
32687!> \note
32688!> arrays can be pointers or assumed shape, but they must be contiguous!
32689! **************************************************************************************************
32690 SUBROUTINE mp_win_create_cv(base, comm, win)
32691 COMPLEX(kind=real_4), DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
32692 TYPE(mp_comm_type), INTENT(IN) :: comm
32693 CLASS(mp_win_type), INTENT(INOUT) :: win
32694
32695 CHARACTER(len=*), PARAMETER :: routinen = 'mp_win_create_cv'
32696
32697 INTEGER :: handle
32698#if defined(__parallel)
32699 INTEGER :: ierr
32700 INTEGER(kind=mpi_address_kind) :: len
32701 COMPLEX(kind=real_4) :: foo(1)
32702#endif
32703
32704 CALL mp_timeset(routinen, handle)
32705
32706#if defined(__parallel)
32707
32708 len = SIZE(base)*(2*real_4_size)
32709 IF (len > 0) THEN
32710 CALL mpi_win_create(base(1), len, (2*real_4_size), mpi_info_null, comm%handle, win%handle, ierr)
32711 ELSE
32712 CALL mpi_win_create(foo, len, (2*real_4_size), mpi_info_null, comm%handle, win%handle, ierr)
32713 END IF
32714 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routinen)
32715
32716 CALL add_perf(perf_id=20, count=1)
32717#else
32718 mark_used(base)
32719 mark_used(comm)
32720 win%handle = mp_win_null_handle
32721#endif
32722 CALL mp_timestop(handle)
32723 END SUBROUTINE mp_win_create_cv
32724
32725! **************************************************************************************************
32726!> \brief Single-sided get function for vector data
32727!> \param base ...
32728!> \param comm ...
32729!> \param win ...
32730!> \par History
32731!> 02.2015 created [Alfio Lazzaro]
32732!> \note
32733!> arrays can be pointers or assumed shape, but they must be contiguous!
32734! **************************************************************************************************
32735 SUBROUTINE mp_rget_cv(base, source, win, win_data, myproc, disp, request, &
32736 origin_datatype, target_datatype)
32737 COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
32738 INTEGER, INTENT(IN) :: source
32739 CLASS(mp_win_type), INTENT(IN) :: win
32740 COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN) :: win_data
32741 INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
32742 TYPE(mp_request_type), INTENT(OUT) :: request
32743 TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
32744
32745 CHARACTER(len=*), PARAMETER :: routinen = 'mp_rget_cv'
32746
32747 INTEGER :: handle
32748#if defined(__parallel)
32749 INTEGER :: ierr, len, &
32750 origin_len, target_len
32751 LOGICAL :: do_local_copy
32752 INTEGER(kind=mpi_address_kind) :: disp_aint
32753 mpi_data_type :: handle_origin_datatype, handle_target_datatype
32754#endif
32755
32756 CALL mp_timeset(routinen, handle)
32757
32758#if defined(__parallel)
32759 len = SIZE(base)
32760 disp_aint = 0
32761 IF (PRESENT(disp)) THEN
32762 disp_aint = int(disp, kind=mpi_address_kind)
32763 END IF
32764 handle_origin_datatype = mpi_complex
32765 origin_len = len
32766 IF (PRESENT(origin_datatype)) THEN
32767 handle_origin_datatype = origin_datatype%type_handle
32768 origin_len = 1
32769 END IF
32770 handle_target_datatype = mpi_complex
32771 target_len = len
32772 IF (PRESENT(target_datatype)) THEN
32773 handle_target_datatype = target_datatype%type_handle
32774 target_len = 1
32775 END IF
32776 IF (len > 0) THEN
32777 do_local_copy = .false.
32778 IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
32779 IF (myproc .EQ. source) do_local_copy = .true.
32780 END IF
32781 IF (do_local_copy) THEN
32782 !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
32783 base(:) = win_data(disp_aint + 1:disp_aint + len)
32784 !$OMP END PARALLEL WORKSHARE
32785 request = mp_request_null
32786 ierr = 0
32787 ELSE
32788 CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
32789 target_len, handle_target_datatype, win%handle, request%handle, ierr)
32790 END IF
32791 ELSE
32792 request = mp_request_null
32793 ierr = 0
32794 END IF
32795 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routinen)
32796
32797 CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*(2*real_4_size))
32798#else
32799 mark_used(source)
32800 mark_used(win)
32801 mark_used(myproc)
32802 mark_used(origin_datatype)
32803 mark_used(target_datatype)
32804
32805 request = mp_request_null
32806 !
32807 IF (PRESENT(disp)) THEN
32808 base(:) = win_data(disp + 1:disp + SIZE(base))
32809 ELSE
32810 base(:) = win_data(:SIZE(base))
32811 END IF
32812
32813#endif
32814 CALL mp_timestop(handle)
32815 END SUBROUTINE mp_rget_cv
32816
32817! **************************************************************************************************
32818!> \brief ...
32819!> \param count ...
32820!> \param lengths ...
32821!> \param displs ...
32822!> \return ...
32823! ***************************************************************************
32824 FUNCTION mp_type_indexed_make_c (count, lengths, displs) &
32825 result(type_descriptor)
32826 INTEGER, INTENT(IN) :: count
32827 INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
32828 TYPE(mp_type_descriptor_type) :: type_descriptor
32829
32830 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_indexed_make_c'
32831
32832 INTEGER :: handle
32833#if defined(__parallel)
32834 INTEGER :: ierr
32835#endif
32836
32837 CALL mp_timeset(routinen, handle)
32838
32839#if defined(__parallel)
32840 CALL mpi_type_indexed(count, lengths, displs, mpi_complex, &
32841 type_descriptor%type_handle, ierr)
32842 IF (ierr /= 0) &
32843 cpabort("MPI_Type_Indexed @ "//routinen)
32844 CALL mpi_type_commit(type_descriptor%type_handle, ierr)
32845 IF (ierr /= 0) &
32846 cpabort("MPI_Type_commit @ "//routinen)
32847#else
32848 type_descriptor%type_handle = 5
32849#endif
32850 type_descriptor%length = count
32851 NULLIFY (type_descriptor%subtype)
32852 type_descriptor%vector_descriptor(1:2) = 1
32853 type_descriptor%has_indexing = .true.
32854 type_descriptor%index_descriptor%index => lengths
32855 type_descriptor%index_descriptor%chunks => displs
32856
32857 CALL mp_timestop(handle)
32858
32859 END FUNCTION mp_type_indexed_make_c
32860
32861! **************************************************************************************************
32862!> \brief Allocates special parallel memory
32863!> \param[in] DATA pointer to integer array to allocate
32864!> \param[in] len number of integers to allocate
32865!> \param[out] stat (optional) allocation status result
32866!> \author UB
32867! **************************************************************************************************
32868 SUBROUTINE mp_allocate_c (DATA, len, stat)
32869 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
32870 INTEGER, INTENT(IN) :: len
32871 INTEGER, INTENT(OUT), OPTIONAL :: stat
32872
32873 CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_c'
32874
32875 INTEGER :: handle, ierr
32876
32877 CALL mp_timeset(routinen, handle)
32878
32879#if defined(__parallel)
32880 NULLIFY (data)
32881 CALL mp_alloc_mem(DATA, len, stat=ierr)
32882 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
32883 CALL mp_stop(ierr, "mpi_alloc_mem @ "//routinen)
32884 CALL add_perf(perf_id=15, count=1)
32885#else
32886 ALLOCATE (DATA(len), stat=ierr)
32887 IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
32888 CALL mp_stop(ierr, "ALLOCATE @ "//routinen)
32889#endif
32890 IF (PRESENT(stat)) stat = ierr
32891 CALL mp_timestop(handle)
32892 END SUBROUTINE mp_allocate_c
32893
32894! **************************************************************************************************
32895!> \brief Deallocates special parallel memory
32896!> \param[in] DATA pointer to special memory to deallocate
32897!> \param stat ...
32898!> \author UB
32899! **************************************************************************************************
32900 SUBROUTINE mp_deallocate_c (DATA, stat)
32901 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: DATA
32902 INTEGER, INTENT(OUT), OPTIONAL :: stat
32903
32904 CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_c'
32905
32906 INTEGER :: handle
32907#if defined(__parallel)
32908 INTEGER :: ierr
32909#endif
32910
32911 CALL mp_timeset(routinen, handle)
32912
32913#if defined(__parallel)
32914 CALL mp_free_mem(DATA, ierr)
32915 IF (PRESENT(stat)) THEN
32916 stat = ierr
32917 ELSE
32918 IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routinen)
32919 END IF
32920 NULLIFY (data)
32921 CALL add_perf(perf_id=15, count=1)
32922#else
32923 DEALLOCATE (data)
32924 IF (PRESENT(stat)) stat = 0
32925#endif
32926 CALL mp_timestop(handle)
32927 END SUBROUTINE mp_deallocate_c
32928
32929! **************************************************************************************************
32930!> \brief (parallel) Blocking individual file write using explicit offsets
32931!> (serial) Unformatted stream write
32932!> \param[in] fh file handle (file storage unit)
32933!> \param[in] offset file offset (position)
32934!> \param[in] msg data to be written to the file
32935!> \param msglen ...
32936!> \par MPI-I/O mapping mpi_file_write_at
32937!> \par STREAM-I/O mapping WRITE
32938!> \param[in](optional) msglen number of the elements of data
32939! **************************************************************************************************
32940 SUBROUTINE mp_file_write_at_cv(fh, offset, msg, msglen)
32941 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
32942 CLASS(mp_file_type), INTENT(IN) :: fh
32943 INTEGER, INTENT(IN), OPTIONAL :: msglen
32944 INTEGER(kind=file_offset), INTENT(IN) :: offset
32945
32946 INTEGER :: msg_len
32947#if defined(__parallel)
32948 INTEGER :: ierr
32949#endif
32950
32951 msg_len = SIZE(msg)
32952 IF (PRESENT(msglen)) msg_len = msglen
32953#if defined(__parallel)
32954 CALL mpi_file_write_at(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
32955 IF (ierr .NE. 0) &
32956 cpabort("mpi_file_write_at_cv @ mp_file_write_at_cv")
32957#else
32958 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
32959#endif
32960 END SUBROUTINE mp_file_write_at_cv
32961
32962! **************************************************************************************************
32963!> \brief ...
32964!> \param fh ...
32965!> \param offset ...
32966!> \param msg ...
32967! **************************************************************************************************
32968 SUBROUTINE mp_file_write_at_c (fh, offset, msg)
32969 COMPLEX(kind=real_4), INTENT(IN) :: msg
32970 CLASS(mp_file_type), INTENT(IN) :: fh
32971 INTEGER(kind=file_offset), INTENT(IN) :: offset
32972
32973#if defined(__parallel)
32974 INTEGER :: ierr
32975
32976 ierr = 0
32977 CALL mpi_file_write_at(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
32978 IF (ierr .NE. 0) &
32979 cpabort("mpi_file_write_at_c @ mp_file_write_at_c")
32980#else
32981 WRITE (unit=fh%handle, pos=offset + 1) msg
32982#endif
32983 END SUBROUTINE mp_file_write_at_c
32984
32985! **************************************************************************************************
32986!> \brief (parallel) Blocking collective file write using explicit offsets
32987!> (serial) Unformatted stream write
32988!> \param fh ...
32989!> \param offset ...
32990!> \param msg ...
32991!> \param msglen ...
32992!> \par MPI-I/O mapping mpi_file_write_at_all
32993!> \par STREAM-I/O mapping WRITE
32994! **************************************************************************************************
32995 SUBROUTINE mp_file_write_at_all_cv(fh, offset, msg, msglen)
32996 COMPLEX(kind=real_4), CONTIGUOUS, INTENT(IN) :: msg(:)
32997 CLASS(mp_file_type), INTENT(IN) :: fh
32998 INTEGER, INTENT(IN), OPTIONAL :: msglen
32999 INTEGER(kind=file_offset), INTENT(IN) :: offset
33000
33001 INTEGER :: msg_len
33002#if defined(__parallel)
33003 INTEGER :: ierr
33004#endif
33005
33006 msg_len = SIZE(msg)
33007 IF (PRESENT(msglen)) msg_len = msglen
33008#if defined(__parallel)
33009 CALL mpi_file_write_at_all(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33010 IF (ierr .NE. 0) &
33011 cpabort("mpi_file_write_at_all_cv @ mp_file_write_at_all_cv")
33012#else
33013 WRITE (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33014#endif
33015 END SUBROUTINE mp_file_write_at_all_cv
33016
33017! **************************************************************************************************
33018!> \brief ...
33019!> \param fh ...
33020!> \param offset ...
33021!> \param msg ...
33022! **************************************************************************************************
33023 SUBROUTINE mp_file_write_at_all_c (fh, offset, msg)
33024 COMPLEX(kind=real_4), INTENT(IN) :: msg
33025 CLASS(mp_file_type), INTENT(IN) :: fh
33026 INTEGER(kind=file_offset), INTENT(IN) :: offset
33027
33028#if defined(__parallel)
33029 INTEGER :: ierr
33030
33031 ierr = 0
33032 CALL mpi_file_write_at_all(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33033 IF (ierr .NE. 0) &
33034 cpabort("mpi_file_write_at_all_c @ mp_file_write_at_all_c")
33035#else
33036 WRITE (unit=fh%handle, pos=offset + 1) msg
33037#endif
33038 END SUBROUTINE mp_file_write_at_all_c
33039
33040! **************************************************************************************************
33041!> \brief (parallel) Blocking individual file read using explicit offsets
33042!> (serial) Unformatted stream read
33043!> \param[in] fh file handle (file storage unit)
33044!> \param[in] offset file offset (position)
33045!> \param[out] msg data to be read from the file
33046!> \param msglen ...
33047!> \par MPI-I/O mapping mpi_file_read_at
33048!> \par STREAM-I/O mapping READ
33049!> \param[in](optional) msglen number of elements of data
33050! **************************************************************************************************
33051 SUBROUTINE mp_file_read_at_cv(fh, offset, msg, msglen)
33052 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
33053 CLASS(mp_file_type), INTENT(IN) :: fh
33054 INTEGER, INTENT(IN), OPTIONAL :: msglen
33055 INTEGER(kind=file_offset), INTENT(IN) :: offset
33056
33057 INTEGER :: msg_len
33058#if defined(__parallel)
33059 INTEGER :: ierr
33060#endif
33061
33062 msg_len = SIZE(msg)
33063 IF (PRESENT(msglen)) msg_len = msglen
33064#if defined(__parallel)
33065 CALL mpi_file_read_at(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33066 IF (ierr .NE. 0) &
33067 cpabort("mpi_file_read_at_cv @ mp_file_read_at_cv")
33068#else
33069 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33070#endif
33071 END SUBROUTINE mp_file_read_at_cv
33072
33073! **************************************************************************************************
33074!> \brief ...
33075!> \param fh ...
33076!> \param offset ...
33077!> \param msg ...
33078! **************************************************************************************************
33079 SUBROUTINE mp_file_read_at_c (fh, offset, msg)
33080 COMPLEX(kind=real_4), INTENT(OUT) :: msg
33081 CLASS(mp_file_type), INTENT(IN) :: fh
33082 INTEGER(kind=file_offset), INTENT(IN) :: offset
33083
33084#if defined(__parallel)
33085 INTEGER :: ierr
33086
33087 ierr = 0
33088 CALL mpi_file_read_at(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33089 IF (ierr .NE. 0) &
33090 cpabort("mpi_file_read_at_c @ mp_file_read_at_c")
33091#else
33092 READ (unit=fh%handle, pos=offset + 1) msg
33093#endif
33094 END SUBROUTINE mp_file_read_at_c
33095
33096! **************************************************************************************************
33097!> \brief (parallel) Blocking collective file read using explicit offsets
33098!> (serial) Unformatted stream read
33099!> \param fh ...
33100!> \param offset ...
33101!> \param msg ...
33102!> \param msglen ...
33103!> \par MPI-I/O mapping mpi_file_read_at_all
33104!> \par STREAM-I/O mapping READ
33105! **************************************************************************************************
33106 SUBROUTINE mp_file_read_at_all_cv(fh, offset, msg, msglen)
33107 COMPLEX(kind=real_4), INTENT(OUT), CONTIGUOUS :: msg(:)
33108 CLASS(mp_file_type), INTENT(IN) :: fh
33109 INTEGER, INTENT(IN), OPTIONAL :: msglen
33110 INTEGER(kind=file_offset), INTENT(IN) :: offset
33111
33112 INTEGER :: msg_len
33113#if defined(__parallel)
33114 INTEGER :: ierr
33115#endif
33116
33117 msg_len = SIZE(msg)
33118 IF (PRESENT(msglen)) msg_len = msglen
33119#if defined(__parallel)
33120 CALL mpi_file_read_at_all(fh%handle, offset, msg, msg_len, mpi_complex, mpi_status_ignore, ierr)
33121 IF (ierr .NE. 0) &
33122 cpabort("mpi_file_read_at_all_cv @ mp_file_read_at_all_cv")
33123#else
33124 READ (unit=fh%handle, pos=offset + 1) msg(1:msg_len)
33125#endif
33126 END SUBROUTINE mp_file_read_at_all_cv
33127
33128! **************************************************************************************************
33129!> \brief ...
33130!> \param fh ...
33131!> \param offset ...
33132!> \param msg ...
33133! **************************************************************************************************
33134 SUBROUTINE mp_file_read_at_all_c (fh, offset, msg)
33135 COMPLEX(kind=real_4), INTENT(OUT) :: msg
33136 CLASS(mp_file_type), INTENT(IN) :: fh
33137 INTEGER(kind=file_offset), INTENT(IN) :: offset
33138
33139#if defined(__parallel)
33140 INTEGER :: ierr
33141
33142 ierr = 0
33143 CALL mpi_file_read_at_all(fh%handle, offset, msg, 1, mpi_complex, mpi_status_ignore, ierr)
33144 IF (ierr .NE. 0) &
33145 cpabort("mpi_file_read_at_all_c @ mp_file_read_at_all_c")
33146#else
33147 READ (unit=fh%handle, pos=offset + 1) msg
33148#endif
33149 END SUBROUTINE mp_file_read_at_all_c
33150
33151! **************************************************************************************************
33152!> \brief ...
33153!> \param ptr ...
33154!> \param vector_descriptor ...
33155!> \param index_descriptor ...
33156!> \return ...
33157! **************************************************************************************************
33158 FUNCTION mp_type_make_c (ptr, &
33159 vector_descriptor, index_descriptor) &
33160 result(type_descriptor)
33161 COMPLEX(kind=real_4), DIMENSION(:), TARGET, asynchronous :: ptr
33162 INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
33163 TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
33164 TYPE(mp_type_descriptor_type) :: type_descriptor
33165
33166 CHARACTER(len=*), PARAMETER :: routinen = 'mp_type_make_c'
33167
33168#if defined(__parallel)
33169 INTEGER :: ierr
33170#endif
33171
33172 NULLIFY (type_descriptor%subtype)
33173 type_descriptor%length = SIZE(ptr)
33174#if defined(__parallel)
33175 type_descriptor%type_handle = mpi_complex
33176 CALL mpi_get_address(ptr, type_descriptor%base, ierr)
33177 IF (ierr /= 0) &
33178 cpabort("MPI_Get_address @ "//routinen)
33179#else
33180 type_descriptor%type_handle = 5
33181#endif
33182 type_descriptor%vector_descriptor(1:2) = 1
33183 type_descriptor%has_indexing = .false.
33184 type_descriptor%data_c => ptr
33185 IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
33186 cpabort(routinen//": Vectors and indices NYI")
33187 END IF
33188 END FUNCTION mp_type_make_c
33189
33190! **************************************************************************************************
33191!> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
33192!> as the Fortran version returns an integer, which we take to be a C_PTR
33193!> \param DATA data array to allocate
33194!> \param[in] len length (in data elements) of data array allocation
33195!> \param[out] stat (optional) allocation status result
33196! **************************************************************************************************
33197 SUBROUTINE mp_alloc_mem_c (DATA, len, stat)
33198 COMPLEX(kind=real_4), CONTIGUOUS, DIMENSION(:), POINTER :: data
33199 INTEGER, INTENT(IN) :: len
33200 INTEGER, INTENT(OUT), OPTIONAL :: stat
33201
33202#if defined(__parallel)
33203 INTEGER :: size, ierr, length, &
33204 mp_res
33205 INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
33206 TYPE(c_ptr) :: mp_baseptr
33207 mpi_info_type :: mp_info
33208
33209 length = max(len, 1)
33210 CALL mpi_type_size(mpi_complex, size, ierr)
33211 mp_size = int(length, kind=mpi_address_kind)*size
33212 IF (mp_size .GT. mp_max_memory_size) THEN
33213 cpabort("MPI cannot allocate more than 2 GiByte")
33214 END IF
33215 mp_info = mpi_info_null
33216 CALL mpi_alloc_mem(mp_size, mp_info, mp_baseptr, mp_res)
33217 CALL c_f_pointer(mp_baseptr, DATA, (/length/))
33218 IF (PRESENT(stat)) stat = mp_res
33219#else
33220 INTEGER :: length, mystat
33221 length = max(len, 1)
33222 IF (PRESENT(stat)) THEN
33223 ALLOCATE (DATA(length), stat=mystat)
33224 stat = mystat ! show to convention checker that stat is used
33225 ELSE
33226 ALLOCATE (DATA(length))
33227 END IF
33228#endif
33229 END SUBROUTINE mp_alloc_mem_c
33230
33231! **************************************************************************************************
33232!> \brief Deallocates am array, ... this is hackish
33233!> as the Fortran version takes an integer, which we hope to get by reference
33234!> \param DATA data array to allocate
33235!> \param[out] stat (optional) allocation status result
33236! **************************************************************************************************
33237 SUBROUTINE mp_free_mem_c (DATA, stat)
33238 COMPLEX(kind=real_4), DIMENSION(:), &
33239 POINTER, asynchronous :: data
33240 INTEGER, INTENT(OUT), OPTIONAL :: stat
33241
33242#if defined(__parallel)
33243 INTEGER :: mp_res
33244 CALL mpi_free_mem(DATA, mp_res)
33245 IF (PRESENT(stat)) stat = mp_res
33246#else
33247 DEALLOCATE (data)
33248 IF (PRESENT(stat)) stat = 0
33249#endif
33250 END SUBROUTINE mp_free_mem_c
33251
33252 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:43
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:117
message_passing::mp_allocate
Definition message_passing.F:891
message_passing::mp_deallocate
Definition message_passing.F:900
message_passing::mp_testall
Definition message_passing.F:875
message_passing::mp_testany
Definition message_passing.F:879
message_passing::mp_type_make
Definition message_passing.F:909
message_passing::mp_waitall
Definition message_passing.F:871
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:284
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:970
message_passing::mp_dims_create
subroutine, public mp_dims_create(nodes, dims)
wrapper to MPI_Dims_create
Definition message_passing.F:2132
message_passing::mp_para_env_create
subroutine, public mp_para_env_create(para_env, group)
creates a new para environment
Definition message_passing.F:2005
message_passing::intlen
integer, parameter intlen
Definition message_passing.F:965
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:4443
message_passing::mp_world_init
subroutine, public mp_world_init(mp_comm)
initializes the system default communicator
Definition message_passing.F:1274
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:2043
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:4632
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:28119
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:1419
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:23412
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:2027
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:2060
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:18705
message_passing::mp_comm_compare_default
integer, parameter, public mp_comm_compare_default
Definition message_passing.F:830
message_passing::mp_get_node_global_rank
integer function, public mp_get_node_global_rank()
Get the local rank on the node according to the global communicator.
Definition message_passing.F:2727
message_passing::mp_world_finalize
subroutine, public mp_world_finalize()
finalizes the system default communicator
Definition message_passing.F:1386
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:3947
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:32826
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:3856
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:4678
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:2356
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:4486
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:4293
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:957
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:933
message_passing::mp_win_type
Definition message_passing.F:639