(git:34ef472)
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 ! **************************************************************************************************
23 MODULE message_passing
24  USE iso_c_binding, ONLY: c_f_pointer, &
25  c_ptr
26  USE kinds, ONLY: &
27  dp, int_4, int_4_size, int_8, int_8_size, real_4, real_4_size, real_8, &
28  real_8_size, default_string_length
29  USE machine, ONLY: m_abort
30  USE mp_perf_env, ONLY: add_perf, &
31  add_mp_perf_env, rm_mp_perf_env
32 
33 #include "../base/base_uses.f90"
34 
35 ! To simplify the transition between the old MPI module and the F08-style module, we introduce these constants to switch between the required handle types
36 ! Unfortunately, Fortran does not offer something like typedef in C++
37 #if defined(__parallel) && defined(__MPI_F08)
38 #define MPI_DATA_TYPE TYPE(MPI_Datatype)
39 #define MPI_COMM_TYPE TYPE(MPI_Comm)
40 #define MPI_REQUEST_TYPE TYPE(MPI_Request)
41 #define MPI_WIN_TYPE TYPE(MPI_Win)
42 #define MPI_FILE_TYPE TYPE(MPI_File)
43 #define MPI_INFO_TYPE TYPE(MPI_Info)
44 #define MPI_STATUS_TYPE TYPE(MPI_Status)
45 #define MPI_GROUP_TYPE TYPE(MPI_Group)
46 #define MPI_STATUS_EXTRACT(X) %X
47 #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 
972 CONTAINS
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
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::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