Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Interface to the message passing library MPI
10 : !> \par History
11 : !> JGH (02-Jan-2001): New error handling
12 : !> Performance tools
13 : !> JGH (14-Jan-2001): New routines mp_comm_compare, mp_cart_coords,
14 : !> mp_rank_compare, mp_alltoall
15 : !> JGH (06-Feb-2001): New routines mp_comm_free
16 : !> JGH (22-Mar-2001): New routines mp_comm_dup
17 : !> fawzi (04-NOV-2004): storable performance info (for f77 interface)
18 : !> Wrapper routine for mpi_gatherv added (22.12.2005,MK)
19 : !> JGH (13-Feb-2006): Flexible precision
20 : !> JGH (15-Feb-2006): single precision mp_alltoall
21 : !> \author JGH
22 : ! **************************************************************************************************
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 : #:mute
975 : #:set types = ["comm", "request", "win", "file", "info"]
976 : #:endmute
977 : #:for type in types
978 2700112 : LOGICAL FUNCTION mp_${type}$_op_eq(${type}$1, ${type}$2)
979 : CLASS(mp_${type}$_type), INTENT(IN) :: ${type}$1, ${type}$2
980 : #if defined(__parallel) && defined(__MPI_F08)
981 : mp_${type}$_op_eq = (${type}$1%handle%mpi_val .EQ. ${type}$2%handle%mpi_val)
982 : #else
983 2700112 : mp_${type}$_op_eq = (${type}$1%handle .EQ. ${type}$2%handle)
984 : #endif
985 2700112 : END FUNCTION mp_${type}$_op_eq
986 :
987 2901288 : LOGICAL FUNCTION mp_${type}$_op_neq(${type}$1, ${type}$2)
988 : CLASS(mp_${type}$_type), INTENT(IN) :: ${type}$1, ${type}$2
989 : #if defined(__parallel) && defined(__MPI_F08)
990 : mp_${type}$_op_neq = (${type}$1%handle%mpi_val .NE. ${type}$2%handle%mpi_val)
991 : #else
992 2901288 : mp_${type}$_op_neq = (${type}$1%handle .NE. ${type}$2%handle)
993 : #endif
994 2901288 : END FUNCTION mp_${type}$_op_neq
995 :
996 9066099 : ELEMENTAL #{if type=="comm"}#IMPURE #{endif}#SUBROUTINE mp_${type}$_type_set_handle(this, handle #{if type=="comm"}#, ndims#{endif}#)
997 : CLASS(mp_${type}$_type), INTENT(INOUT) :: this
998 : INTEGER, INTENT(IN) :: handle
999 : #:if type=="comm"
1000 : INTEGER, INTENT(IN), OPTIONAL :: ndims
1001 : #:endif
1002 :
1003 : #if defined(__parallel) && defined(__MPI_F08)
1004 : this%handle%mpi_val = handle
1005 : #else
1006 9066099 : this%handle = handle
1007 : #endif
1008 :
1009 : #:if type=="comm"
1010 : SELECT TYPE (this)
1011 : CLASS IS (mp_cart_type)
1012 0 : IF (.NOT. PRESENT(ndims)) &
1013 : CALL cp_abort(__LOCATION__, &
1014 0 : "Setup of a cartesian communicator requires information on the number of dimensions!")
1015 : END SELECT
1016 9062399 : IF (PRESENT(ndims)) this%ndims = ndims
1017 9062399 : CALL this%init()
1018 : #:endif
1019 :
1020 9066099 : END SUBROUTINE mp_${type}$_type_set_handle
1021 :
1022 2131998 : ELEMENTAL FUNCTION mp_${type}$_type_get_handle(this) RESULT(handle)
1023 : CLASS(mp_${type}$_type), INTENT(IN) :: this
1024 : INTEGER :: handle
1025 :
1026 : #if defined(__parallel) && defined(__MPI_F08)
1027 : handle = this%handle%mpi_val
1028 : #else
1029 2131998 : handle = this%handle
1030 : #endif
1031 2131998 : END FUNCTION mp_${type}$_type_get_handle
1032 : #:endfor
1033 :
1034 19510 : FUNCTION mp_comm_get_tag_ub(comm) RESULT(tag_ub)
1035 : CLASS(mp_comm_type), INTENT(IN) :: comm
1036 : INTEGER :: tag_ub
1037 :
1038 : #if defined(__parallel)
1039 : INTEGER :: ierr
1040 : LOGICAL :: flag
1041 : INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1042 :
1043 19510 : CALL MPI_COMM_GET_ATTR(comm%handle, MPI_TAG_UB, attrval, flag, ierr)
1044 19510 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_tag_ub")
1045 19510 : IF (.NOT. flag) CPABORT("Upper bound of tags not available!")
1046 19510 : tag_ub = INT(attrval, KIND=KIND(tag_ub))
1047 : #else
1048 : MARK_USED(comm)
1049 : tag_ub = HUGE(1)
1050 : #endif
1051 19510 : END FUNCTION mp_comm_get_tag_ub
1052 :
1053 0 : FUNCTION mp_comm_get_host_rank(comm) RESULT(host_rank)
1054 : CLASS(mp_comm_type), INTENT(IN) :: comm
1055 : INTEGER :: host_rank
1056 :
1057 : #if defined(__parallel)
1058 : INTEGER :: ierr
1059 : LOGICAL :: flag
1060 : INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1061 :
1062 0 : CALL MPI_COMM_GET_ATTR(comm%handle, MPI_HOST, attrval, flag, ierr)
1063 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_host_rank")
1064 0 : IF (.NOT. flag) CPABORT("Host process rank not available!")
1065 0 : host_rank = INT(attrval, KIND=KIND(host_rank))
1066 : #else
1067 : MARK_USED(comm)
1068 : host_rank = 0
1069 : #endif
1070 0 : END FUNCTION mp_comm_get_host_rank
1071 :
1072 0 : FUNCTION mp_comm_get_io_rank(comm) RESULT(io_rank)
1073 : CLASS(mp_comm_type), INTENT(IN) :: comm
1074 : INTEGER :: io_rank
1075 :
1076 : #if defined(__parallel)
1077 : INTEGER :: ierr
1078 : LOGICAL :: flag
1079 : INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1080 :
1081 0 : CALL MPI_COMM_GET_ATTR(comm%handle, MPI_IO, attrval, flag, ierr)
1082 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_io_rank")
1083 0 : IF (.NOT. flag) CPABORT("IO rank not available!")
1084 0 : io_rank = INT(attrval, KIND=KIND(io_rank))
1085 : #else
1086 : MARK_USED(comm)
1087 : io_rank = 0
1088 : #endif
1089 0 : END FUNCTION mp_comm_get_io_rank
1090 :
1091 0 : FUNCTION mp_comm_get_wtime_is_global(comm) RESULT(wtime_is_global)
1092 : CLASS(mp_comm_type), INTENT(IN) :: comm
1093 : LOGICAL :: wtime_is_global
1094 :
1095 : #if defined(__parallel)
1096 : INTEGER :: ierr
1097 : LOGICAL :: flag
1098 : INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1099 :
1100 0 : CALL MPI_COMM_GET_ATTR(comm%handle, MPI_TAG_UB, attrval, flag, ierr)
1101 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_wtime_is_global")
1102 0 : IF (.NOT. flag) CPABORT("Synchronization state of WTIME not available!")
1103 0 : wtime_is_global = (attrval == 1_MPI_ADDRESS_KIND)
1104 : #else
1105 : MARK_USED(comm)
1106 : wtime_is_global = .TRUE.
1107 : #endif
1108 0 : END FUNCTION mp_comm_get_wtime_is_global
1109 :
1110 : ! **************************************************************************************************
1111 : !> \brief initializes the system default communicator
1112 : !> \param mp_comm [output] : handle of the default communicator
1113 : !> \par History
1114 : !> 2.2004 created [Joost VandeVondele ]
1115 : !> \note
1116 : !> should only be called once
1117 : ! **************************************************************************************************
1118 9164 : SUBROUTINE mp_world_init(mp_comm)
1119 : CLASS(mp_comm_type), INTENT(OUT) :: mp_comm
1120 : #if defined(__parallel)
1121 : INTEGER :: ierr
1122 : !$ INTEGER :: provided_tsl
1123 : !$ LOGICAL :: no_threading_support
1124 :
1125 : #if defined(__NO_MPI_THREAD_SUPPORT_CHECK)
1126 : ! Hack that does not request or check MPI thread support level.
1127 : ! User asserts that the MPI library will work correctly with
1128 : ! threads.
1129 : !
1130 : !$ no_threading_support = .TRUE.
1131 : #else
1132 : ! Does the right thing when using OpenMP: requests that the MPI
1133 : ! library supports serialized mode and verifies that the MPI library
1134 : ! provides that support.
1135 : !
1136 : ! Developers: Only the master thread will ever make calls to the
1137 : ! MPI library.
1138 : !
1139 9164 : !$ no_threading_support = .FALSE.
1140 : #endif
1141 : !$ IF (no_threading_support) THEN
1142 : CALL mpi_init(ierr)
1143 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init @ mp_world_init")
1144 : !$ ELSE
1145 9164 : !$OMP MASTER
1146 : #if defined(__DLAF)
1147 : ! DLA-Future requires that the MPI library supports
1148 : ! THREAD_MULTIPLE mode
1149 : !$ CALL mpi_init_thread(MPI_THREAD_MULTIPLE, provided_tsl, ierr)
1150 : #else
1151 9164 : !$ CALL mpi_init_thread(MPI_THREAD_SERIALIZED, provided_tsl, ierr)
1152 : #endif
1153 9164 : !$ IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
1154 : #if defined(__DLAF)
1155 : !$ IF (provided_tsl .LT. MPI_THREAD_MULTIPLE) THEN
1156 : !$ 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.")
1157 : !$ END IF
1158 : #else
1159 9164 : !$ IF (provided_tsl .LT. MPI_THREAD_SERIALIZED) THEN
1160 0 : !$ CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_SERIALIZED).")
1161 : !$ END IF
1162 : #endif
1163 : !$OMP END MASTER
1164 : !$ END IF
1165 9164 : CALL mpi_comm_set_errhandler(MPI_COMM_WORLD, MPI_ERRORS_RETURN, ierr)
1166 9164 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_set_errhandler @ mp_world_init")
1167 : #endif
1168 9164 : debug_comm_count = 1
1169 9164 : mp_comm = mp_comm_world
1170 9164 : CALL mp_comm%init()
1171 9164 : CALL add_mp_perf_env()
1172 9164 : END SUBROUTINE mp_world_init
1173 :
1174 : ! **************************************************************************************************
1175 : !> \brief re-create the system default communicator with a different MPI
1176 : !> rank order
1177 : !> \param mp_comm [output] : handle of the default communicator
1178 : !> \param mp_new_comm ...
1179 : !> \param ranks_order ...
1180 : !> \par History
1181 : !> 1.2012 created [ Christiane Pousa ]
1182 : !> \note
1183 : !> should only be called once, at very beginning of CP2K run
1184 : ! **************************************************************************************************
1185 744 : SUBROUTINE mp_reordering(mp_comm, mp_new_comm, ranks_order)
1186 : CLASS(mp_comm_type), INTENT(IN) :: mp_comm
1187 : CLASS(mp_comm_type), INTENT(out) :: mp_new_comm
1188 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: ranks_order
1189 :
1190 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_reordering'
1191 :
1192 : INTEGER :: handle, ierr
1193 : #if defined(__parallel)
1194 : MPI_GROUP_TYPE :: newgroup, oldgroup
1195 : #endif
1196 :
1197 744 : CALL mp_timeset(routineN, handle)
1198 744 : ierr = 0
1199 : #if defined(__parallel)
1200 :
1201 744 : CALL mpi_comm_group(mp_comm%handle, oldgroup, ierr)
1202 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_reordering")
1203 744 : CALL mpi_group_incl(oldgroup, SIZE(ranks_order), ranks_order, newgroup, ierr)
1204 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_incl @ mp_reordering")
1205 :
1206 744 : CALL mpi_comm_create(mp_comm%handle, newgroup, mp_new_comm%handle, ierr)
1207 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_create @ mp_reordering")
1208 :
1209 744 : CALL mpi_group_free(oldgroup, ierr)
1210 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1211 744 : CALL mpi_group_free(newgroup, ierr)
1212 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1213 :
1214 744 : CALL add_perf(perf_id=1, count=1)
1215 : #else
1216 : MARK_USED(mp_comm)
1217 : MARK_USED(ranks_order)
1218 : mp_new_comm%handle = mp_comm_default_handle
1219 : #endif
1220 744 : debug_comm_count = debug_comm_count + 1
1221 744 : CALL mp_new_comm%init()
1222 744 : CALL mp_timestop(handle)
1223 744 : END SUBROUTINE mp_reordering
1224 :
1225 : ! **************************************************************************************************
1226 : !> \brief finalizes the system default communicator
1227 : !> \par History
1228 : !> 2.2004 created [Joost VandeVondele]
1229 : ! **************************************************************************************************
1230 9164 : SUBROUTINE mp_world_finalize()
1231 :
1232 : CHARACTER(LEN=default_string_length) :: debug_comm_count_char
1233 : #if defined(__parallel)
1234 : INTEGER :: ierr
1235 9164 : CALL mpi_barrier(MPI_COMM_WORLD, ierr) ! call mpi directly to avoid 0 stack pointer
1236 : #endif
1237 9164 : CALL rm_mp_perf_env()
1238 :
1239 9164 : debug_comm_count = debug_comm_count - 1
1240 : #if defined(__parallel)
1241 9164 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_world_finalize")
1242 : #endif
1243 9164 : IF (debug_comm_count .NE. 0) THEN
1244 : ! A bug, we're leaking or double-freeing communicators. Needs to be fixed where the leak happens.
1245 : ! Memory leak checking might be helpful to locate the culprit
1246 0 : WRITE (unit=debug_comm_count_char, FMT='(I0)')
1247 : CALL cp_abort(__LOCATION__, "mp_world_finalize: assert failed:"// &
1248 0 : " leaking communicators "//TRIM(debug_comm_count_char))
1249 : END IF
1250 : #if defined(__parallel)
1251 9164 : CALL mpi_finalize(ierr)
1252 9164 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_finalize @ mp_world_finalize")
1253 : #endif
1254 :
1255 9164 : END SUBROUTINE mp_world_finalize
1256 :
1257 : ! all the following routines should work for a given communicator, not MPI_WORLD
1258 :
1259 : ! **************************************************************************************************
1260 : !> \brief globally stops all tasks
1261 : !> this is intended to be low level, most of CP2K should call cp_abort()
1262 : ! **************************************************************************************************
1263 0 : SUBROUTINE mp_abort()
1264 : INTEGER :: ierr
1265 :
1266 0 : ierr = 0
1267 :
1268 : #if !defined(__NO_ABORT)
1269 : #if defined(__parallel)
1270 : CALL mpi_abort(MPI_COMM_WORLD, 1, ierr)
1271 : #else
1272 : CALL m_abort()
1273 : #endif
1274 : #endif
1275 : ! this routine never returns and levels with non-zero exit code
1276 0 : STOP 1
1277 : END SUBROUTINE mp_abort
1278 :
1279 : ! **************************************************************************************************
1280 : !> \brief stops *after an mpi error* translating the error code
1281 : !> \param ierr an error code * returned by an mpi call *
1282 : !> \param prg_code ...
1283 : !> \note
1284 : !> this function is private to message_passing.F
1285 : ! **************************************************************************************************
1286 0 : SUBROUTINE mp_stop(ierr, prg_code)
1287 : INTEGER, INTENT(IN) :: ierr
1288 : CHARACTER(LEN=*), INTENT(IN) :: prg_code
1289 :
1290 : #if defined(__parallel)
1291 : INTEGER :: istat, len
1292 : CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: error_string
1293 : CHARACTER(LEN=MPI_MAX_ERROR_STRING + 512) :: full_error
1294 : #else
1295 : CHARACTER(LEN=512) :: full_error
1296 : #endif
1297 :
1298 : #if defined(__parallel)
1299 0 : CALL mpi_error_string(ierr, error_string, len, istat)
1300 0 : WRITE (full_error, '(A,I0,A)') ' MPI error ', ierr, ' in '//TRIM(prg_code)//' : '//error_string(1:len)
1301 : #else
1302 : WRITE (full_error, '(A,I0,A)') ' MPI error (!?) ', ierr, ' in '//TRIM(prg_code)
1303 : #endif
1304 :
1305 0 : CPABORT(full_error)
1306 :
1307 0 : END SUBROUTINE mp_stop
1308 :
1309 : ! **************************************************************************************************
1310 : !> \brief synchronizes with a barrier a given group of mpi tasks
1311 : !> \param group mpi communicator
1312 : ! **************************************************************************************************
1313 3051166 : SUBROUTINE mp_sync(comm)
1314 : CLASS(mp_comm_type), INTENT(IN) :: comm
1315 :
1316 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sync'
1317 :
1318 : INTEGER :: handle, ierr
1319 :
1320 3051166 : ierr = 0
1321 3051166 : CALL mp_timeset(routineN, handle)
1322 :
1323 : #if defined(__parallel)
1324 3051166 : CALL mpi_barrier(comm%handle, ierr)
1325 3051166 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_sync")
1326 3051166 : CALL add_perf(perf_id=5, count=1)
1327 : #else
1328 : MARK_USED(comm)
1329 : #endif
1330 3051166 : CALL mp_timestop(handle)
1331 :
1332 3051166 : END SUBROUTINE mp_sync
1333 :
1334 : ! **************************************************************************************************
1335 : !> \brief synchronizes with a barrier a given group of mpi tasks
1336 : !> \param comm mpi communicator
1337 : !> \param request ...
1338 : ! **************************************************************************************************
1339 0 : SUBROUTINE mp_isync(comm, request)
1340 : CLASS(mp_comm_type), INTENT(IN) :: comm
1341 : TYPE(mp_request_type), INTENT(OUT) :: request
1342 :
1343 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isync'
1344 :
1345 : INTEGER :: handle, ierr
1346 :
1347 0 : ierr = 0
1348 0 : CALL mp_timeset(routineN, handle)
1349 :
1350 : #if defined(__parallel)
1351 0 : CALL mpi_ibarrier(comm%handle, request%handle, ierr)
1352 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibarrier @ mp_isync")
1353 0 : CALL add_perf(perf_id=26, count=1)
1354 : #else
1355 : MARK_USED(comm)
1356 : request = mp_request_null
1357 : #endif
1358 0 : CALL mp_timestop(handle)
1359 :
1360 0 : END SUBROUTINE mp_isync
1361 :
1362 : ! **************************************************************************************************
1363 : !> \brief returns task id for a given mpi communicator
1364 : !> \param taskid The ID of the communicator
1365 : !> \param comm mpi communicator
1366 : ! **************************************************************************************************
1367 20346581 : SUBROUTINE mp_comm_rank(taskid, comm)
1368 :
1369 : INTEGER, INTENT(OUT) :: taskid
1370 : CLASS(mp_comm_type), INTENT(IN) :: comm
1371 :
1372 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_rank'
1373 :
1374 : INTEGER :: handle
1375 : #if defined(__parallel)
1376 : INTEGER :: ierr
1377 : #endif
1378 :
1379 20346581 : CALL mp_timeset(routineN, handle)
1380 :
1381 : #if defined(__parallel)
1382 20346581 : CALL mpi_comm_rank(comm%handle, taskid, ierr)
1383 20346581 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_rank")
1384 : #else
1385 : MARK_USED(comm)
1386 : taskid = 0
1387 : #endif
1388 20346581 : CALL mp_timestop(handle)
1389 :
1390 20346581 : END SUBROUTINE mp_comm_rank
1391 :
1392 : ! **************************************************************************************************
1393 : !> \brief returns number of tasks for a given mpi communicator
1394 : !> \param numtask ...
1395 : !> \param comm mpi communicator
1396 : ! **************************************************************************************************
1397 20346581 : SUBROUTINE mp_comm_size(numtask, comm)
1398 :
1399 : INTEGER, INTENT(OUT) :: numtask
1400 : CLASS(mp_comm_type), INTENT(IN) :: comm
1401 :
1402 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_size'
1403 :
1404 : INTEGER :: handle
1405 : #if defined(__parallel)
1406 : INTEGER :: ierr
1407 : #endif
1408 :
1409 20346581 : CALL mp_timeset(routineN, handle)
1410 :
1411 : #if defined(__parallel)
1412 20346581 : CALL mpi_comm_size(comm%handle, numtask, ierr)
1413 20346581 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_size")
1414 : #else
1415 : MARK_USED(comm)
1416 : numtask = 1
1417 : #endif
1418 20346581 : CALL mp_timestop(handle)
1419 :
1420 20346581 : END SUBROUTINE mp_comm_size
1421 :
1422 : ! **************************************************************************************************
1423 : !> \brief returns info for a given Cartesian MPI communicator
1424 : !> \param comm ...
1425 : !> \param ndims ...
1426 : !> \param dims ...
1427 : !> \param task_coor ...
1428 : !> \param periods ...
1429 : ! **************************************************************************************************
1430 8250296 : SUBROUTINE mp_cart_get(comm, dims, task_coor, periods)
1431 :
1432 : CLASS(mp_cart_type), INTENT(IN) :: comm
1433 : INTEGER, INTENT(OUT), OPTIONAL :: dims(comm%ndims), task_coor(comm%ndims)
1434 : LOGICAL, INTENT(out), OPTIONAL :: periods(comm%ndims)
1435 :
1436 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_get'
1437 :
1438 : INTEGER :: handle
1439 : #if defined(__parallel)
1440 : INTEGER :: ierr
1441 16500592 : INTEGER :: my_dims(comm%ndims), my_task_coor(comm%ndims)
1442 16500592 : LOGICAL :: my_periods(comm%ndims)
1443 : #endif
1444 :
1445 8250296 : CALL mp_timeset(routineN, handle)
1446 :
1447 : #if defined(__parallel)
1448 8250296 : CALL mpi_cart_get(comm%handle, comm%ndims, my_dims, my_periods, my_task_coor, ierr)
1449 8250296 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_cart_get")
1450 33001968 : IF (PRESENT(dims)) dims = my_dims
1451 33001968 : IF (PRESENT(task_coor)) task_coor = my_task_coor
1452 33001968 : IF (PRESENT(periods)) periods = my_periods
1453 : #else
1454 : MARK_USED(comm)
1455 : IF (PRESENT(task_coor)) task_coor = 0
1456 : IF (PRESENT(dims)) dims = 1
1457 : IF (PRESENT(periods)) periods = .FALSE.
1458 : #endif
1459 8250296 : CALL mp_timestop(handle)
1460 :
1461 8250296 : END SUBROUTINE mp_cart_get
1462 :
1463 0 : INTEGER ELEMENTAL FUNCTION mp_comm_get_ndims(comm)
1464 : CLASS(mp_comm_type), INTENT(IN) :: comm
1465 :
1466 0 : mp_comm_get_ndims = comm%ndims
1467 :
1468 0 : END FUNCTION
1469 :
1470 : ! **************************************************************************************************
1471 : !> \brief creates a cartesian communicator from any communicator
1472 : !> \param comm_old ...
1473 : !> \param ndims ...
1474 : !> \param dims ...
1475 : !> \param pos ...
1476 : !> \param comm_cart ...
1477 : ! **************************************************************************************************
1478 1540370 : SUBROUTINE mp_cart_create(comm_old, ndims, dims, comm_cart)
1479 :
1480 : CLASS(mp_comm_type), INTENT(IN) :: comm_old
1481 : INTEGER, INTENT(IN) :: ndims
1482 : INTEGER, INTENT(INOUT) :: dims(ndims)
1483 : CLASS(mp_cart_type), INTENT(OUT) :: comm_cart
1484 :
1485 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_create'
1486 :
1487 : INTEGER :: handle, ierr
1488 : #if defined(__parallel)
1489 1540370 : LOGICAL, DIMENSION(1:ndims) :: period
1490 : LOGICAL :: reorder
1491 : #endif
1492 :
1493 1540370 : ierr = 0
1494 1540370 : CALL mp_timeset(routineN, handle)
1495 :
1496 1540370 : comm_cart%handle = comm_old%handle
1497 : #if defined(__parallel)
1498 :
1499 4226854 : IF (ANY(dims == 0)) CALL mpi_dims_create(comm_old%num_pe, ndims, dims, ierr)
1500 1540370 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_cart_create")
1501 :
1502 : ! FIX ME. Quick hack to avoid problems with realspace grids for compilers
1503 : ! like IBM that actually reorder the processors when creating the new
1504 : ! communicator
1505 1540370 : reorder = .FALSE.
1506 4621894 : period = .TRUE.
1507 : CALL mpi_cart_create(comm_old%handle, ndims, dims, period, reorder, comm_cart%handle, &
1508 1540370 : ierr)
1509 1540370 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_create @ mp_cart_create")
1510 1540370 : CALL add_perf(perf_id=1, count=1)
1511 : #else
1512 : dims = 1
1513 : comm_cart%handle = mp_comm_default_handle
1514 : #endif
1515 1540370 : comm_cart%ndims = ndims
1516 1540370 : debug_comm_count = debug_comm_count + 1
1517 1540370 : CALL comm_cart%init()
1518 1540370 : CALL mp_timestop(handle)
1519 :
1520 1540370 : END SUBROUTINE mp_cart_create
1521 :
1522 : ! **************************************************************************************************
1523 : !> \brief wrapper to MPI_Cart_coords
1524 : !> \param comm ...
1525 : !> \param rank ...
1526 : !> \param coords ...
1527 : ! **************************************************************************************************
1528 57372 : SUBROUTINE mp_cart_coords(comm, rank, coords)
1529 :
1530 : CLASS(mp_cart_type), INTENT(IN) :: comm
1531 : INTEGER, INTENT(IN) :: rank
1532 : INTEGER, DIMENSION(:), INTENT(OUT) :: coords
1533 :
1534 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_coords'
1535 :
1536 : INTEGER :: handle, ierr, m
1537 :
1538 57372 : ierr = 0
1539 57372 : CALL mp_timeset(routineN, handle)
1540 :
1541 57372 : m = SIZE(coords)
1542 : #if defined(__parallel)
1543 57372 : CALL mpi_cart_coords(comm%handle, rank, m, coords, ierr)
1544 57372 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_coords @ mp_cart_coords")
1545 : #else
1546 : coords = 0
1547 : MARK_USED(rank)
1548 : MARK_USED(comm)
1549 : #endif
1550 57372 : CALL mp_timestop(handle)
1551 :
1552 57372 : END SUBROUTINE mp_cart_coords
1553 :
1554 : ! **************************************************************************************************
1555 : !> \brief wrapper to MPI_Comm_compare
1556 : !> \param comm1 ...
1557 : !> \param comm2 ...
1558 : !> \param res ...
1559 : ! **************************************************************************************************
1560 2260 : FUNCTION mp_comm_compare(comm1, comm2) RESULT(res)
1561 :
1562 : CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
1563 : INTEGER :: res
1564 :
1565 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_compare'
1566 :
1567 : INTEGER :: handle
1568 : #if defined(__parallel)
1569 : INTEGER :: ierr, iout
1570 : #endif
1571 :
1572 2260 : CALL mp_timeset(routineN, handle)
1573 :
1574 2260 : res = 0
1575 : #if defined(__parallel)
1576 2260 : CALL mpi_comm_compare(comm1%handle, comm2%handle, iout, ierr)
1577 2260 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_compare @ mp_comm_compare")
1578 : SELECT CASE (iout)
1579 : CASE (MPI_IDENT)
1580 2260 : res = mp_comm_ident
1581 : CASE (MPI_CONGRUENT)
1582 2260 : res = mp_comm_congruent
1583 : CASE (MPI_SIMILAR)
1584 0 : res = mp_comm_similar
1585 : CASE (MPI_UNEQUAL)
1586 0 : res = mp_comm_unequal
1587 : CASE default
1588 2260 : CPABORT("Unknown comparison state of the communicators!")
1589 : END SELECT
1590 : #else
1591 : MARK_USED(comm1)
1592 : MARK_USED(comm2)
1593 : #endif
1594 2260 : CALL mp_timestop(handle)
1595 :
1596 2260 : END FUNCTION mp_comm_compare
1597 :
1598 : ! **************************************************************************************************
1599 : !> \brief wrapper to MPI_Cart_sub
1600 : !> \param comm ...
1601 : !> \param rdim ...
1602 : !> \param sub_comm ...
1603 : ! **************************************************************************************************
1604 1568 : SUBROUTINE mp_cart_sub(comm, rdim, sub_comm)
1605 :
1606 : CLASS(mp_cart_type), INTENT(IN) :: comm
1607 : LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: rdim
1608 : CLASS(mp_cart_type), INTENT(OUT) :: sub_comm
1609 :
1610 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_sub'
1611 :
1612 : INTEGER :: handle
1613 : #if defined(__parallel)
1614 : INTEGER :: ierr
1615 : #endif
1616 :
1617 1568 : CALL mp_timeset(routineN, handle)
1618 :
1619 : #if defined(__parallel)
1620 1568 : CALL mpi_cart_sub(comm%handle, rdim, sub_comm%handle, ierr)
1621 1568 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_sub @ mp_cart_sub")
1622 : #else
1623 : MARK_USED(comm)
1624 : MARK_USED(rdim)
1625 : sub_comm%handle = mp_comm_default_handle
1626 : #endif
1627 6272 : sub_comm%ndims = COUNT(rdim)
1628 1568 : debug_comm_count = debug_comm_count + 1
1629 1568 : CALL sub_comm%init()
1630 1568 : CALL mp_timestop(handle)
1631 :
1632 1568 : END SUBROUTINE mp_cart_sub
1633 :
1634 : ! **************************************************************************************************
1635 : !> \brief wrapper to MPI_Comm_free
1636 : !> \param comm ...
1637 : ! **************************************************************************************************
1638 3640444 : SUBROUTINE mp_comm_free(comm)
1639 :
1640 : CLASS(mp_comm_type), INTENT(INOUT) :: comm
1641 :
1642 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_free'
1643 :
1644 : INTEGER :: handle
1645 : LOGICAL :: free_comm
1646 : #if defined(__parallel)
1647 : INTEGER :: ierr
1648 : #endif
1649 :
1650 3640444 : free_comm = .TRUE.
1651 : SELECT TYPE (comm)
1652 : CLASS IS (mp_para_env_type)
1653 906098 : free_comm = .FALSE.
1654 906098 : IF (comm%ref_count <= 0) &
1655 0 : CPABORT("para_env%ref_count <= 0")
1656 906098 : comm%ref_count = comm%ref_count - 1
1657 906098 : IF (comm%ref_count <= 0) THEN
1658 184328 : free_comm = comm%owns_group
1659 : END IF
1660 : CLASS IS (mp_para_cart_type)
1661 144 : free_comm = .FALSE.
1662 144 : IF (comm%ref_count <= 0) &
1663 0 : CPABORT("para_cart%ref_count <= 0")
1664 144 : comm%ref_count = comm%ref_count - 1
1665 144 : IF (comm%ref_count <= 0) THEN
1666 144 : free_comm = comm%owns_group
1667 : END IF
1668 : END SELECT
1669 :
1670 3640444 : CALL mp_timeset(routineN, handle)
1671 :
1672 3640444 : IF (free_comm) THEN
1673 : #if defined(__parallel)
1674 2889027 : CALL mpi_comm_free(comm%handle, ierr)
1675 2889027 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_free @ mp_comm_free")
1676 : #else
1677 : comm%handle = mp_comm_null_handle
1678 : #endif
1679 2889027 : debug_comm_count = debug_comm_count - 1
1680 : END IF
1681 :
1682 : SELECT TYPE (comm)
1683 : CLASS IS (mp_cart_type)
1684 2049631 : DEALLOCATE (comm%periodic, comm%mepos_cart, comm%num_pe_cart)
1685 : END SELECT
1686 :
1687 3640444 : CALL mp_timestop(handle)
1688 :
1689 3640444 : END SUBROUTINE mp_comm_free
1690 :
1691 : ! **************************************************************************************************
1692 : !> \brief check whether the environment exists
1693 : !> \param para_env ...
1694 : !> \return ...
1695 : ! **************************************************************************************************
1696 775412 : ELEMENTAL LOGICAL FUNCTION mp_para_env_is_valid(para_env)
1697 : CLASS(mp_para_env_type), INTENT(IN) :: para_env
1698 :
1699 775412 : mp_para_env_is_valid = para_env%ref_count > 0
1700 :
1701 775412 : END FUNCTION mp_para_env_is_valid
1702 :
1703 : ! **************************************************************************************************
1704 : !> \brief increase the reference counter but ensure that you free it later
1705 : !> \param para_env ...
1706 : ! **************************************************************************************************
1707 721770 : ELEMENTAL SUBROUTINE mp_para_env_retain(para_env)
1708 : CLASS(mp_para_env_type), INTENT(INOUT) :: para_env
1709 :
1710 721770 : para_env%ref_count = para_env%ref_count + 1
1711 :
1712 721770 : END SUBROUTINE mp_para_env_retain
1713 :
1714 : ! **************************************************************************************************
1715 : !> \brief check whether the given environment is valid, i.e. existent
1716 : !> \param cart ...
1717 : !> \return ...
1718 : ! **************************************************************************************************
1719 144 : ELEMENTAL LOGICAL FUNCTION mp_para_cart_is_valid(cart)
1720 : CLASS(mp_para_cart_type), INTENT(IN) :: cart
1721 :
1722 144 : mp_para_cart_is_valid = cart%ref_count > 0
1723 :
1724 144 : END FUNCTION mp_para_cart_is_valid
1725 :
1726 : ! **************************************************************************************************
1727 : !> \brief increase the reference counter, don't forget to free it later
1728 : !> \param cart ...
1729 : ! **************************************************************************************************
1730 0 : ELEMENTAL SUBROUTINE mp_para_cart_retain(cart)
1731 : CLASS(mp_para_cart_type), INTENT(INOUT) :: cart
1732 :
1733 0 : cart%ref_count = cart%ref_count + 1
1734 :
1735 0 : END SUBROUTINE mp_para_cart_retain
1736 :
1737 : ! **************************************************************************************************
1738 : !> \brief wrapper to MPI_Comm_dup
1739 : !> \param comm1 ...
1740 : !> \param comm2 ...
1741 : ! **************************************************************************************************
1742 537575 : SUBROUTINE mp_comm_dup(comm1, comm2)
1743 :
1744 : CLASS(mp_comm_type), INTENT(IN) :: comm1
1745 : CLASS(mp_comm_type), INTENT(OUT) :: comm2
1746 :
1747 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_dup'
1748 :
1749 : INTEGER :: handle
1750 : #if defined(__parallel)
1751 : INTEGER :: ierr
1752 : #endif
1753 :
1754 537575 : CALL mp_timeset(routineN, handle)
1755 :
1756 : #if defined(__parallel)
1757 537575 : CALL mpi_comm_dup(comm1%handle, comm2%handle, ierr)
1758 537575 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_dup @ mp_comm_dup")
1759 : #else
1760 : MARK_USED(comm1)
1761 : comm2%handle = mp_comm_default_handle
1762 : #endif
1763 537575 : comm2%ndims = comm1%ndims
1764 537575 : debug_comm_count = debug_comm_count + 1
1765 537575 : CALL comm2%init()
1766 537575 : CALL mp_timestop(handle)
1767 :
1768 537575 : END SUBROUTINE mp_comm_dup
1769 :
1770 : ! **************************************************************************************************
1771 : !> \brief Implements a simple assignment function to overload the assignment operator
1772 : !> \param comm_new communicator on the r.h.s. of the assignment operator
1773 : !> \param comm_old communicator on the l.h.s. of the assignment operator
1774 : ! **************************************************************************************************
1775 8411793 : ELEMENTAL IMPURE SUBROUTINE mp_comm_assign(comm_new, comm_old)
1776 : CLASS(mp_comm_type), INTENT(IN) :: comm_old
1777 : CLASS(mp_comm_type), INTENT(OUT) :: comm_new
1778 :
1779 8411793 : comm_new%handle = comm_old%handle
1780 8411793 : comm_new%ndims = comm_old%ndims
1781 8411793 : CALL comm_new%init(.FALSE.)
1782 8411793 : END SUBROUTINE
1783 :
1784 : ! **************************************************************************************************
1785 : !> \brief check whether the local process is the source process
1786 : !> \param para_env ...
1787 : !> \return ...
1788 : ! **************************************************************************************************
1789 13894935 : ELEMENTAL LOGICAL FUNCTION mp_comm_is_source(comm)
1790 : CLASS(mp_comm_type), INTENT(IN) :: comm
1791 :
1792 13894935 : mp_comm_is_source = comm%source == comm%mepos
1793 :
1794 13894935 : END FUNCTION mp_comm_is_source
1795 :
1796 : ! **************************************************************************************************
1797 : !> \brief Initializes the communicator (mostly relevant for its derived classes)
1798 : !> \param comm ...
1799 : ! **************************************************************************************************
1800 20372383 : ELEMENTAL IMPURE SUBROUTINE mp_comm_init(comm, owns_group)
1801 : CLASS(mp_comm_type), INTENT(INOUT) :: comm
1802 : LOGICAL, INTENT(IN), OPTIONAL :: owns_group
1803 :
1804 20372383 : IF (comm%handle MPI_GET_COMP .NE. mp_comm_null_handle MPI_GET_COMP) THEN
1805 20195035 : comm%source = 0
1806 20195035 : CALL comm%get_size(comm%num_pe)
1807 20195035 : CALL comm%get_rank(comm%mepos)
1808 : END IF
1809 :
1810 : SELECT TYPE (comm)
1811 : CLASS IS (mp_cart_type)
1812 8250296 : IF (ALLOCATED(comm%periodic)) DEALLOCATE (comm%periodic)
1813 8250296 : IF (ALLOCATED(comm%mepos_cart)) DEALLOCATE (comm%mepos_cart)
1814 8250296 : IF (ALLOCATED(comm%num_pe_cart)) DEALLOCATE (comm%num_pe_cart)
1815 :
1816 : ASSOCIATE (ndims => comm%ndims)
1817 :
1818 0 : ALLOCATE (comm%periodic(ndims), comm%mepos_cart(ndims), &
1819 57752072 : comm%num_pe_cart(ndims))
1820 : END ASSOCIATE
1821 :
1822 24751672 : comm%mepos_cart = 0
1823 24751672 : comm%periodic = .FALSE.
1824 8250296 : IF (comm%handle MPI_GET_COMP .NE. mp_comm_null_handle MPI_GET_COMP) THEN
1825 : CALL comm%get_info_cart(comm%num_pe_cart, comm%mepos_cart, &
1826 8250296 : comm%periodic)
1827 : END IF
1828 : END SELECT
1829 :
1830 : SELECT TYPE (comm)
1831 : CLASS IS (mp_para_env_type)
1832 193486 : IF (PRESENT(owns_group)) comm%owns_group = owns_group
1833 193486 : comm%ref_count = 1
1834 : CLASS IS (mp_para_cart_type)
1835 144 : IF (PRESENT(owns_group)) comm%owns_group = owns_group
1836 144 : comm%ref_count = 1
1837 : END SELECT
1838 :
1839 20372383 : END SUBROUTINE
1840 :
1841 : ! **************************************************************************************************
1842 : !> \brief creates a new para environment
1843 : !> \param para_env the new parallel environment
1844 : !> \param group the id of the actual mpi_group
1845 : !> \par History
1846 : !> 08.2002 created [fawzi]
1847 : !> \author Fawzi Mohamed
1848 : ! **************************************************************************************************
1849 0 : SUBROUTINE mp_para_env_create(para_env, group)
1850 : TYPE(mp_para_env_type), POINTER :: para_env
1851 : CLASS(mp_comm_type), INTENT(in) :: group
1852 :
1853 0 : IF (ASSOCIATED(para_env)) &
1854 0 : CPABORT("The passed para_env must not be associated!")
1855 0 : ALLOCATE (para_env)
1856 0 : para_env%mp_comm_type = group
1857 0 : CALL para_env%init()
1858 0 : END SUBROUTINE mp_para_env_create
1859 :
1860 : ! **************************************************************************************************
1861 : !> \brief releases the para object (to be called when you don't want anymore
1862 : !> the shared copy of this object)
1863 : !> \param para_env the new group
1864 : !> \par History
1865 : !> 08.2002 created [fawzi]
1866 : !> \author Fawzi Mohamed
1867 : !> \note
1868 : !> to avoid circular dependencies cp_log_handling has a private copy
1869 : !> of this method (see cp_log_handling:my_mp_para_env_release)!
1870 : ! **************************************************************************************************
1871 783903 : SUBROUTINE mp_para_env_release(para_env)
1872 : TYPE(mp_para_env_type), POINTER :: para_env
1873 :
1874 783903 : IF (ASSOCIATED(para_env)) THEN
1875 754413 : CALL para_env%free()
1876 754413 : IF (.NOT. para_env%is_valid()) DEALLOCATE (para_env)
1877 : END IF
1878 783903 : NULLIFY (para_env)
1879 783903 : END SUBROUTINE mp_para_env_release
1880 :
1881 : ! **************************************************************************************************
1882 : !> \brief creates a cart (multidimensional parallel environment)
1883 : !> \param cart the cart environment to create
1884 : !> \param group the mpi communicator
1885 : !> \author fawzi
1886 : ! **************************************************************************************************
1887 0 : SUBROUTINE mp_para_cart_create(cart, group)
1888 : TYPE(mp_para_cart_type), POINTER, INTENT(OUT) :: cart
1889 : CLASS(mp_comm_type), INTENT(in) :: group
1890 :
1891 0 : IF (ASSOCIATED(cart)) &
1892 0 : CPABORT("The passed para_cart must not be associated!")
1893 0 : ALLOCATE (cart)
1894 0 : cart%mp_cart_type = group
1895 0 : CALL cart%init()
1896 :
1897 0 : END SUBROUTINE mp_para_cart_create
1898 :
1899 : ! **************************************************************************************************
1900 : !> \brief releases the given cart
1901 : !> \param cart the cart to release
1902 : !> \author fawzi
1903 : ! **************************************************************************************************
1904 144 : SUBROUTINE mp_para_cart_release(cart)
1905 : TYPE(mp_para_cart_type), POINTER :: cart
1906 :
1907 144 : IF (ASSOCIATED(cart)) THEN
1908 144 : CALL cart%free()
1909 144 : IF (.NOT. cart%is_valid()) DEALLOCATE (cart)
1910 : END IF
1911 144 : NULLIFY (cart)
1912 144 : END SUBROUTINE mp_para_cart_release
1913 :
1914 : ! **************************************************************************************************
1915 : !> \brief wrapper to MPI_Group_translate_ranks
1916 : !> \param comm1 ...
1917 : !> \param comm2 ...
1918 : !> \param rank ...
1919 : ! **************************************************************************************************
1920 2726430 : SUBROUTINE mp_rank_compare(comm1, comm2, rank)
1921 :
1922 : CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
1923 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rank
1924 :
1925 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_rank_compare'
1926 :
1927 : INTEGER :: handle
1928 : #if defined(__parallel)
1929 : INTEGER :: i, ierr, n, n1, n2
1930 2726430 : INTEGER, ALLOCATABLE, DIMENSION(:) :: rin
1931 : MPI_GROUP_TYPE :: g1, g2
1932 : #endif
1933 :
1934 2726430 : CALL mp_timeset(routineN, handle)
1935 :
1936 8179290 : rank = 0
1937 : #if defined(__parallel)
1938 2726430 : CALL mpi_comm_size(comm1%handle, n1, ierr)
1939 2726430 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
1940 2726430 : CALL mpi_comm_size(comm2%handle, n2, ierr)
1941 2726430 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
1942 2726430 : n = MAX(n1, n2)
1943 2726430 : CALL mpi_comm_group(comm1%handle, g1, ierr)
1944 2726430 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
1945 2726430 : CALL mpi_comm_group(comm2%handle, g2, ierr)
1946 2726430 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
1947 8179290 : ALLOCATE (rin(0:n - 1), STAT=ierr)
1948 2726430 : IF (ierr /= 0) &
1949 0 : CPABORT("allocate @ mp_rank_compare")
1950 8179290 : DO i = 0, n - 1
1951 8179290 : rin(i) = i
1952 : END DO
1953 2726430 : CALL mpi_group_translate_ranks(g1, n, rin, g2, rank, ierr)
1954 2726430 : IF (ierr /= 0) CALL mp_stop(ierr, &
1955 0 : "mpi_group_translate_rank @ mp_rank_compare")
1956 2726430 : CALL mpi_group_free(g1, ierr)
1957 2726430 : IF (ierr /= 0) &
1958 0 : CPABORT("group_free @ mp_rank_compare")
1959 2726430 : CALL mpi_group_free(g2, ierr)
1960 2726430 : IF (ierr /= 0) &
1961 0 : CPABORT("group_free @ mp_rank_compare")
1962 2726430 : DEALLOCATE (rin)
1963 : #else
1964 : MARK_USED(comm1)
1965 : MARK_USED(comm2)
1966 : #endif
1967 2726430 : CALL mp_timestop(handle)
1968 :
1969 2726430 : END SUBROUTINE mp_rank_compare
1970 :
1971 : ! **************************************************************************************************
1972 : !> \brief wrapper to MPI_Dims_create
1973 : !> \param nodes ...
1974 : !> \param dims ...
1975 : ! **************************************************************************************************
1976 727027 : SUBROUTINE mp_dims_create(nodes, dims)
1977 :
1978 : INTEGER, INTENT(IN) :: nodes
1979 : INTEGER, DIMENSION(:), INTENT(INOUT) :: dims
1980 :
1981 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_dims_create'
1982 :
1983 : INTEGER :: handle, ndim
1984 : #if defined(__parallel)
1985 : INTEGER :: ierr
1986 : #endif
1987 :
1988 727027 : CALL mp_timeset(routineN, handle)
1989 :
1990 727027 : ndim = SIZE(dims)
1991 : #if defined(__parallel)
1992 727027 : IF (ANY(dims == 0)) CALL mpi_dims_create(nodes, ndim, dims, ierr)
1993 727027 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_dims_create")
1994 : #else
1995 : dims = 1
1996 : MARK_USED(nodes)
1997 : #endif
1998 727027 : CALL mp_timestop(handle)
1999 :
2000 727027 : END SUBROUTINE mp_dims_create
2001 :
2002 : ! **************************************************************************************************
2003 : !> \brief wrapper to MPI_Cart_rank
2004 : !> \param comm ...
2005 : !> \param pos ...
2006 : !> \param rank ...
2007 : ! **************************************************************************************************
2008 4303134 : SUBROUTINE mp_cart_rank(comm, pos, rank)
2009 : CLASS(mp_cart_type), INTENT(IN) :: comm
2010 : INTEGER, DIMENSION(:), INTENT(IN) :: pos
2011 : INTEGER, INTENT(OUT) :: rank
2012 :
2013 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_rank'
2014 :
2015 : INTEGER :: handle
2016 : #if defined(__parallel)
2017 : INTEGER :: ierr
2018 : #endif
2019 :
2020 4303134 : CALL mp_timeset(routineN, handle)
2021 :
2022 : #if defined(__parallel)
2023 4303134 : CALL mpi_cart_rank(comm%handle, pos, rank, ierr)
2024 4303134 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_rank @ mp_cart_rank")
2025 : #else
2026 : rank = 0
2027 : MARK_USED(comm)
2028 : MARK_USED(pos)
2029 : #endif
2030 4303134 : CALL mp_timestop(handle)
2031 :
2032 4303134 : END SUBROUTINE mp_cart_rank
2033 :
2034 : ! **************************************************************************************************
2035 : !> \brief waits for completion of the given request
2036 : !> \param request ...
2037 : !> \par History
2038 : !> 08.2003 created [f&j]
2039 : !> \author joost & fawzi
2040 : !> \note
2041 : !> see isendrecv
2042 : ! **************************************************************************************************
2043 8050 : SUBROUTINE mp_wait(request)
2044 : CLASS(mp_request_type), INTENT(inout) :: request
2045 :
2046 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_wait'
2047 :
2048 : INTEGER :: handle
2049 : #if defined(__parallel)
2050 : INTEGER :: ierr
2051 : #endif
2052 :
2053 8050 : CALL mp_timeset(routineN, handle)
2054 :
2055 : #if defined(__parallel)
2056 :
2057 8050 : CALL mpi_wait(request%handle, MPI_STATUS_IGNORE, ierr)
2058 8050 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_wait @ mp_wait")
2059 :
2060 8050 : CALL add_perf(perf_id=9, count=1)
2061 : #else
2062 : request%handle = mp_request_null_handle
2063 : #endif
2064 8050 : CALL mp_timestop(handle)
2065 8050 : END SUBROUTINE mp_wait
2066 :
2067 : ! **************************************************************************************************
2068 : !> \brief waits for completion of the given requests
2069 : !> \param requests ...
2070 : !> \par History
2071 : !> 08.2003 created [f&j]
2072 : !> \author joost & fawzi
2073 : !> \note
2074 : !> see isendrecv
2075 : ! **************************************************************************************************
2076 1602727 : SUBROUTINE mp_waitall_1(requests)
2077 : TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2078 :
2079 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_1'
2080 :
2081 : INTEGER :: handle
2082 : #if defined(__parallel)
2083 : INTEGER :: count, ierr
2084 : #if !defined(__MPI_F08)
2085 1602727 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: status
2086 : #else
2087 : TYPE(MPI_Status), ALLOCATABLE, DIMENSION(:) :: status
2088 : #endif
2089 : #endif
2090 :
2091 1602727 : CALL mp_timeset(routineN, handle)
2092 :
2093 : #if defined(__parallel)
2094 1602727 : count = SIZE(requests)
2095 : #if !defined(__MPI_F08)
2096 4772732 : ALLOCATE (status(MPI_STATUS_SIZE, count))
2097 : #else
2098 : ALLOCATE (status(count))
2099 : #endif
2100 1602727 : CALL mpi_waitall_internal(count, requests, status, ierr) ! MPI_STATUSES_IGNORE openmpi workaround
2101 1602727 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_1")
2102 1602727 : DEALLOCATE (status)
2103 1602727 : CALL add_perf(perf_id=9, count=1)
2104 : #else
2105 : requests = mp_request_null
2106 : #endif
2107 1602727 : CALL mp_timestop(handle)
2108 1602727 : END SUBROUTINE mp_waitall_1
2109 :
2110 : ! **************************************************************************************************
2111 : !> \brief waits for completion of the given requests
2112 : !> \param requests ...
2113 : !> \par History
2114 : !> 08.2003 created [f&j]
2115 : !> \author joost & fawzi
2116 : ! **************************************************************************************************
2117 704946 : SUBROUTINE mp_waitall_2(requests)
2118 : TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2119 :
2120 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_2'
2121 :
2122 : INTEGER :: handle
2123 : #if defined(__parallel)
2124 : INTEGER :: count, ierr
2125 : #if !defined(__MPI_F08)
2126 704946 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: status
2127 : #else
2128 : TYPE(MPI_Status), ALLOCATABLE, DIMENSION(:) :: status
2129 : #endif
2130 : #endif
2131 :
2132 704946 : CALL mp_timeset(routineN, handle)
2133 :
2134 : #if defined(__parallel)
2135 2114838 : count = SIZE(requests)
2136 : #if !defined(__MPI_F08)
2137 2113294 : ALLOCATE (status(MPI_STATUS_SIZE, count))
2138 : #else
2139 : ALLOCATE (status(count))
2140 : #endif
2141 :
2142 3877498 : CALL mpi_waitall_internal(count, requests, status, ierr) ! MPI_STATUSES_IGNORE openmpi workaround
2143 704946 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_2")
2144 704946 : DEALLOCATE (status)
2145 :
2146 704946 : CALL add_perf(perf_id=9, count=1)
2147 : #else
2148 : requests = mp_request_null
2149 : #endif
2150 704946 : CALL mp_timestop(handle)
2151 704946 : END SUBROUTINE mp_waitall_2
2152 :
2153 : ! **************************************************************************************************
2154 : !> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2155 : !> the issue is with the rank or requests
2156 : !> \param count ...
2157 : !> \param array_of_requests ...
2158 : !> \param array_of_statuses ...
2159 : !> \param ierr ...
2160 : !> \author Joost VandeVondele
2161 : ! **************************************************************************************************
2162 : #if defined(__parallel)
2163 2307673 : SUBROUTINE mpi_waitall_internal(count, array_of_requests, array_of_statuses, ierr)
2164 : INTEGER, INTENT(in) :: count
2165 : TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2166 : #if !defined(__MPI_F08)
2167 : INTEGER, DIMENSION(MPI_STATUS_SIZE, count), &
2168 : INTENT(out) :: array_of_statuses
2169 : #else
2170 : TYPE(MPI_Status), DIMENSION(count), &
2171 : INTENT(out) :: array_of_statuses
2172 : #endif
2173 : INTEGER, INTENT(out) :: ierr
2174 :
2175 : INTEGER :: i
2176 2307673 : MPI_REQUEST_TYPE, ALLOCATABLE, DIMENSION(:) :: request_handles
2177 :
2178 6886026 : ALLOCATE (request_handles(count))
2179 8331903 : DO i = 1, count
2180 8331903 : request_handles(i) = array_of_requests(i)%handle
2181 : END DO
2182 :
2183 2307673 : CALL mpi_waitall(count, request_handles, array_of_statuses, ierr)
2184 :
2185 8331903 : DO i = 1, count
2186 8331903 : array_of_requests(i)%handle = request_handles(i)
2187 : END DO
2188 :
2189 2307673 : END SUBROUTINE mpi_waitall_internal
2190 : #endif
2191 :
2192 : ! **************************************************************************************************
2193 : !> \brief waits for completion of any of the given requests
2194 : !> \param requests ...
2195 : !> \param completed ...
2196 : !> \par History
2197 : !> 09.2008 created
2198 : !> \author Iain Bethune (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
2199 : ! **************************************************************************************************
2200 12536 : SUBROUTINE mp_waitany(requests, completed)
2201 : TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2202 : INTEGER, INTENT(out) :: completed
2203 :
2204 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitany'
2205 :
2206 : INTEGER :: handle
2207 : #if defined(__parallel)
2208 : INTEGER :: count, i, ierr
2209 12536 : MPI_REQUEST_TYPE, ALLOCATABLE, DIMENSION(:) :: request_handles
2210 : #endif
2211 :
2212 12536 : CALL mp_timeset(routineN, handle)
2213 :
2214 : #if defined(__parallel)
2215 12536 : count = SIZE(requests)
2216 : ! Convert CP2K's request_handles to the plane handle for the library
2217 : ! (Maybe, the compiler optimizes it away)
2218 37608 : ALLOCATE (request_handles(count))
2219 37608 : DO i = 1, count
2220 37608 : request_handles(i) = requests(i)%handle
2221 : END DO
2222 12536 : CALL mpi_waitany(count, request_handles, completed, MPI_STATUS_IGNORE, ierr)
2223 12536 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitany @ mp_waitany")
2224 : ! Convert the plane handles to CP2K handles
2225 37608 : DO i = 1, count
2226 37608 : requests(i)%handle = request_handles(i)
2227 : END DO
2228 12536 : CALL add_perf(perf_id=9, count=1)
2229 : #else
2230 : requests = mp_request_null
2231 : completed = 1
2232 : #endif
2233 12536 : CALL mp_timestop(handle)
2234 25072 : END SUBROUTINE mp_waitany
2235 :
2236 : ! **************************************************************************************************
2237 : !> \brief Tests for completion of the given requests.
2238 : !> \brief We use mpi_test so that we can use a single status.
2239 : !> \param requests the list of requests to test
2240 : !> \return logical which determines if requests are complete
2241 : !> \par History
2242 : !> 3.2016 adapted to any shape [Nico Holmberg]
2243 : !> \author Alfio Lazzaro
2244 : ! **************************************************************************************************
2245 6400 : FUNCTION mp_testall_tv(requests) RESULT(flag)
2246 : TYPE(mp_request_type), DIMENSION(:), INTENT(INOUT) :: requests
2247 : LOGICAL :: flag
2248 :
2249 : #if defined(__parallel)
2250 : INTEGER :: i, ierr
2251 : LOGICAL, DIMENSION(:), POINTER :: flags
2252 : #endif
2253 :
2254 6400 : flag = .TRUE.
2255 :
2256 : #if defined(__parallel)
2257 19200 : ALLOCATE (flags(SIZE(requests)))
2258 25600 : DO i = 1, SIZE(requests)
2259 19200 : CALL mpi_test(requests(i)%handle, flags(i), MPI_STATUS_IGNORE, ierr)
2260 19200 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testall @ mp_testall_tv")
2261 26310 : flag = flag .AND. flags(i)
2262 : END DO
2263 6400 : DEALLOCATE (flags)
2264 : #else
2265 : requests = mp_request_null
2266 : #endif
2267 6400 : END FUNCTION mp_testall_tv
2268 :
2269 : ! **************************************************************************************************
2270 : !> \brief Tests for completion of the given request.
2271 : !> \param request the request
2272 : !> \param flag logical which determines if the request is completed
2273 : !> \par History
2274 : !> 3.2016 created
2275 : !> \author Nico Holmberg
2276 : ! **************************************************************************************************
2277 54 : FUNCTION mp_test_1(request) RESULT(flag)
2278 : CLASS(mp_request_type), INTENT(inout) :: request
2279 : LOGICAL :: flag
2280 :
2281 : #if defined(__parallel)
2282 : INTEGER :: ierr
2283 :
2284 54 : CALL mpi_test(request%handle, flag, MPI_STATUS_IGNORE, ierr)
2285 54 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_test @ mp_test_1")
2286 : #else
2287 : MARK_USED(request)
2288 : flag = .TRUE.
2289 : #endif
2290 54 : END FUNCTION mp_test_1
2291 :
2292 : ! **************************************************************************************************
2293 : !> \brief tests for completion of the given requests
2294 : !> \param requests ...
2295 : !> \param completed ...
2296 : !> \param flag ...
2297 : !> \par History
2298 : !> 08.2011 created
2299 : !> \author Iain Bethune
2300 : ! **************************************************************************************************
2301 0 : SUBROUTINE mp_testany_1(requests, completed, flag)
2302 : TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2303 : INTEGER, INTENT(out), OPTIONAL :: completed
2304 : LOGICAL, INTENT(out), OPTIONAL :: flag
2305 :
2306 : #if defined(__parallel)
2307 : INTEGER :: completed_l, count, ierr
2308 : LOGICAL :: flag_l
2309 :
2310 0 : count = SIZE(requests)
2311 :
2312 0 : CALL mpi_testany_internal(count, requests, completed_l, flag_l, MPI_STATUS_IGNORE, ierr)
2313 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_1 @ mp_testany")
2314 :
2315 0 : IF (PRESENT(completed)) completed = completed_l
2316 0 : IF (PRESENT(flag)) flag = flag_l
2317 : #else
2318 : MARK_USED(requests)
2319 : IF (PRESENT(completed)) completed = 1
2320 : IF (PRESENT(flag)) flag = .TRUE.
2321 : #endif
2322 0 : END SUBROUTINE mp_testany_1
2323 :
2324 : ! **************************************************************************************************
2325 : !> \brief tests for completion of the given requests
2326 : !> \param requests ...
2327 : !> \param completed ...
2328 : !> \param flag ...
2329 : !> \par History
2330 : !> 08.2011 created
2331 : !> \author Iain Bethune
2332 : ! **************************************************************************************************
2333 0 : SUBROUTINE mp_testany_2(requests, completed, flag)
2334 : TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2335 : INTEGER, INTENT(out), OPTIONAL :: completed
2336 : LOGICAL, INTENT(out), OPTIONAL :: flag
2337 :
2338 : #if defined(__parallel)
2339 : INTEGER :: completed_l, count, ierr
2340 : LOGICAL :: flag_l
2341 :
2342 0 : count = SIZE(requests)
2343 :
2344 0 : CALL mpi_testany_internal(count, requests, completed_l, flag_l, MPI_STATUS_IGNORE, ierr)
2345 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_2 @ mp_testany")
2346 :
2347 0 : IF (PRESENT(completed)) completed = completed_l
2348 0 : IF (PRESENT(flag)) flag = flag_l
2349 : #else
2350 : MARK_USED(requests)
2351 : IF (PRESENT(completed)) completed = 1
2352 : IF (PRESENT(flag)) flag = .TRUE.
2353 : #endif
2354 0 : END SUBROUTINE mp_testany_2
2355 :
2356 : ! **************************************************************************************************
2357 : !> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2358 : !> the issue is with the rank or requests
2359 : !> \param count ...
2360 : !> \param array_of_requests ...
2361 : !> \param index ...
2362 : !> \param flag ...
2363 : !> \param status ...
2364 : !> \param ierr ...
2365 : !> \author Joost VandeVondele
2366 : ! **************************************************************************************************
2367 : #if defined(__parallel)
2368 0 : SUBROUTINE mpi_testany_internal(count, array_of_requests, index, flag, status, ierr)
2369 : INTEGER, INTENT(in) :: count
2370 : TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2371 : INTEGER, INTENT(out) :: index
2372 : LOGICAL, INTENT(out) :: flag
2373 : MPI_STATUS_TYPE, INTENT(out) :: status
2374 : INTEGER, INTENT(out) :: ierr
2375 :
2376 : INTEGER :: i
2377 0 : MPI_REQUEST_TYPE, ALLOCATABLE, DIMENSION(:) :: request_handles
2378 :
2379 0 : ALLOCATE (request_handles(count))
2380 0 : DO i = 1, count
2381 0 : request_handles(i) = array_of_requests(i)%handle
2382 : END DO
2383 :
2384 0 : CALL mpi_testany(count, request_handles, index, flag, status, ierr)
2385 :
2386 0 : DO i = 1, count
2387 0 : array_of_requests(i)%handle = request_handles(i)
2388 : END DO
2389 :
2390 0 : END SUBROUTINE mpi_testany_internal
2391 : #endif
2392 :
2393 : ! **************************************************************************************************
2394 : !> \brief the direct way to split a communicator each color is a sub_comm,
2395 : !> the rank order is according to the order in the orig comm
2396 : !> \param comm ...
2397 : !> \param sub_comm ...
2398 : !> \param color ...
2399 : !> \param key ...
2400 : !> \author Joost VandeVondele
2401 : ! **************************************************************************************************
2402 657224 : SUBROUTINE mp_comm_split_direct(comm, sub_comm, color, key)
2403 : CLASS(mp_comm_type), INTENT(in) :: comm
2404 : CLASS(mp_comm_type), INTENT(OUT) :: sub_comm
2405 : INTEGER, INTENT(in) :: color
2406 : INTEGER, INTENT(in), OPTIONAL :: key
2407 :
2408 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_split_direct'
2409 :
2410 : INTEGER :: handle
2411 : #if defined(__parallel)
2412 : INTEGER :: ierr, my_key
2413 : #endif
2414 :
2415 657224 : CALL mp_timeset(routineN, handle)
2416 :
2417 : #if defined(__parallel)
2418 657224 : my_key = 0
2419 657224 : IF (PRESENT(key)) my_key = key
2420 657224 : CALL mpi_comm_split(comm%handle, color, my_key, sub_comm%handle, ierr)
2421 657224 : IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
2422 657224 : CALL add_perf(perf_id=10, count=1)
2423 : #else
2424 : sub_comm%handle = mp_comm_default_handle
2425 : MARK_USED(comm)
2426 : MARK_USED(color)
2427 : MARK_USED(key)
2428 : #endif
2429 657224 : debug_comm_count = debug_comm_count + 1
2430 657224 : CALL sub_comm%init()
2431 657224 : CALL mp_timestop(handle)
2432 :
2433 657224 : END SUBROUTINE mp_comm_split_direct
2434 : ! **************************************************************************************************
2435 : !> \brief splits the given communicator in group in subgroups trying to organize
2436 : !> them in a way that the communication within each subgroup is
2437 : !> efficient (but not necessarily the communication between subgroups)
2438 : !> \param comm the mpi communicator that you want to split
2439 : !> \param sub_comm the communicator for the subgroup (created, needs to be freed later)
2440 : !> \param ngroups actual number of groups
2441 : !> \param group_distribution input : allocated with array with the nprocs entries (0 .. nprocs-1)
2442 : !> \param subgroup_min_size the minimum size of the subgroup
2443 : !> \param n_subgroups the number of subgroups wanted
2444 : !> \param group_partition n_subgroups sized array containing the number of cpus wanted per group.
2445 : !> should match the total number of cpus (only used if present and associated) (0..ngroups-1)
2446 : !> \param stride create groups using a stride (default=1) through the ranks of the comm to be split.
2447 : !> \par History
2448 : !> 10.2003 created [fawzi]
2449 : !> 02.2004 modified [Joost VandeVondele]
2450 : !> \author Fawzi Mohamed
2451 : !> \note
2452 : !> at least one of subgroup_min_size and n_subgroups is needed,
2453 : !> the other default to the value needed to use most processors.
2454 : !> if less cpus are present than needed for subgroup min size, n_subgroups,
2455 : !> just one comm is created that contains all cpus
2456 : ! **************************************************************************************************
2457 151546 : SUBROUTINE mp_comm_split(comm, sub_comm, ngroups, group_distribution, &
2458 151546 : subgroup_min_size, n_subgroups, group_partition, stride)
2459 : CLASS(mp_comm_type), INTENT(in) :: comm
2460 : CLASS(mp_comm_type), INTENT(out) :: sub_comm
2461 : INTEGER, INTENT(out) :: ngroups
2462 : INTEGER, DIMENSION(0:), INTENT(INOUT) :: group_distribution
2463 : INTEGER, INTENT(in), OPTIONAL :: subgroup_min_size, n_subgroups
2464 : INTEGER, DIMENSION(0:), INTENT(IN), OPTIONAL :: group_partition
2465 : INTEGER, OPTIONAL, INTENT(IN) :: stride
2466 :
2467 : CHARACTER(LEN=*), PARAMETER :: routineN = 'mp_comm_split', &
2468 : routineP = moduleN//':'//routineN
2469 :
2470 : INTEGER :: handle, mepos, nnodes
2471 : #if defined(__parallel)
2472 : INTEGER :: color, i, ierr, j, k, &
2473 : my_subgroup_min_size, &
2474 : istride, local_stride, irank
2475 151546 : INTEGER, DIMENSION(:), ALLOCATABLE :: rank_permutation
2476 : #endif
2477 :
2478 151546 : CALL mp_timeset(routineN, handle)
2479 :
2480 : ! actual number of groups
2481 :
2482 151546 : IF (.NOT. PRESENT(subgroup_min_size) .AND. .NOT. PRESENT(n_subgroups)) THEN
2483 0 : CPABORT(routineP//" missing arguments")
2484 : END IF
2485 151546 : IF (PRESENT(subgroup_min_size) .AND. PRESENT(n_subgroups)) THEN
2486 0 : CPABORT(routineP//" too many arguments")
2487 : END IF
2488 :
2489 151546 : CALL comm%get_size(nnodes)
2490 151546 : CALL comm%get_rank(mepos)
2491 :
2492 151546 : IF (UBOUND(group_distribution, 1) .NE. nnodes - 1) THEN
2493 0 : CPABORT(routineP//" group_distribution wrong bounds")
2494 : END IF
2495 :
2496 : #if defined(__parallel)
2497 151546 : IF (PRESENT(subgroup_min_size)) THEN
2498 144 : IF (subgroup_min_size < 0 .OR. subgroup_min_size > nnodes) THEN
2499 0 : CPABORT(routineP//" subgroup_min_size too small or too large")
2500 : END IF
2501 144 : ngroups = nnodes/subgroup_min_size
2502 144 : my_subgroup_min_size = subgroup_min_size
2503 : ELSE ! n_subgroups
2504 151402 : IF (n_subgroups <= 0) THEN
2505 0 : CPABORT(routineP//" n_subgroups too small")
2506 : END IF
2507 151402 : IF (nnodes/n_subgroups > 0) THEN ! we have a least one cpu per group
2508 147479 : ngroups = n_subgroups
2509 : ELSE ! well, only one group then
2510 3923 : ngroups = 1
2511 : END IF
2512 151402 : my_subgroup_min_size = nnodes/ngroups
2513 : END IF
2514 :
2515 : ! rank_permutation: is a permutation of ranks, so that groups are not necessarily continuous in rank of the master group
2516 : ! 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
2517 : ! (by setting stride equal to the number of mpi ranks per node), or by sharing a node between two groups (stride 2).
2518 454638 : ALLOCATE (rank_permutation(0:nnodes - 1))
2519 151546 : local_stride = 1
2520 151546 : IF (PRESENT(stride)) local_stride = stride
2521 151546 : k = 0
2522 303092 : DO istride = 1, local_stride
2523 303092 : DO irank = istride - 1, nnodes - 1, local_stride
2524 299168 : rank_permutation(k) = irank
2525 299168 : k = k + 1
2526 : END DO
2527 : END DO
2528 :
2529 450714 : DO i = 0, nnodes - 1
2530 450714 : group_distribution(rank_permutation(i)) = MIN(i/my_subgroup_min_size, ngroups - 1)
2531 : END DO
2532 : ! even the user gave a partition, see if we can use it to overwrite this choice
2533 151546 : IF (PRESENT(group_partition)) THEN
2534 647172 : IF (ALL(group_partition > 0) .AND. (SUM(group_partition) .EQ. nnodes) .AND. (ngroups == SIZE(group_partition))) THEN
2535 90 : k = 0
2536 90 : DO i = 0, SIZE(group_partition) - 1
2537 150 : DO j = 1, group_partition(i)
2538 60 : group_distribution(rank_permutation(k)) = i
2539 120 : k = k + 1
2540 : END DO
2541 : END DO
2542 : ELSE
2543 : ! just ignore silently as we have reasonable defaults. Probably a warning would not be to bad
2544 : END IF
2545 : END IF
2546 151546 : color = group_distribution(mepos)
2547 151546 : CALL mpi_comm_split(comm%handle, color, 0, sub_comm%handle, ierr)
2548 151546 : IF (ierr /= mpi_success) CALL mp_stop(ierr, "in "//routineP//" split")
2549 :
2550 151546 : CALL add_perf(perf_id=10, count=1)
2551 : #else
2552 : sub_comm%handle = mp_comm_default_handle
2553 : group_distribution(0) = 0
2554 : ngroups = 1
2555 : MARK_USED(comm)
2556 : MARK_USED(stride)
2557 : MARK_USED(group_partition)
2558 : #endif
2559 151546 : debug_comm_count = debug_comm_count + 1
2560 151546 : CALL sub_comm%init()
2561 151546 : CALL mp_timestop(handle)
2562 :
2563 454638 : END SUBROUTINE mp_comm_split
2564 :
2565 : ! **************************************************************************************************
2566 : !> \brief Get the local rank on the node according to the global communicator
2567 : !> \return Node Rank id
2568 : !> \author Alfio Lazzaro
2569 : ! **************************************************************************************************
2570 0 : FUNCTION mp_get_node_global_rank() &
2571 : RESULT(node_rank)
2572 :
2573 : INTEGER :: node_rank
2574 :
2575 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_get_node_global_rank'
2576 : INTEGER :: handle
2577 : #if defined(__parallel)
2578 : INTEGER :: ierr, rank
2579 : TYPE(mp_comm_type) :: comm
2580 : #endif
2581 :
2582 0 : CALL mp_timeset(routineN, handle)
2583 :
2584 : #if defined(__parallel)
2585 0 : CALL mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)
2586 0 : IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
2587 0 : CALL mpi_comm_split_type(MPI_COMM_WORLD, MPI_COMM_TYPE_SHARED, rank, MPI_INFO_NULL, comm%handle, ierr)
2588 0 : IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
2589 0 : CALL mpi_comm_rank(comm%handle, node_rank, ierr)
2590 0 : IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
2591 0 : CALL mpi_comm_free(comm%handle, ierr)
2592 0 : IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
2593 : #else
2594 : node_rank = 0
2595 : #endif
2596 0 : CALL mp_timestop(handle)
2597 :
2598 0 : END FUNCTION mp_get_node_global_rank
2599 :
2600 : ! **************************************************************************************************
2601 : !> \brief probes for an incoming message with any tag
2602 : !> \param[inout] source the source of the possible incoming message,
2603 : !> if MP_ANY_SOURCE it is a blocking one and return value is the source
2604 : !> of the next incoming message
2605 : !> if source is a different value it is a non-blocking probe returning
2606 : !> MP_ANY_SOURCE if there is no incoming message
2607 : !> \param[in] comm the communicator
2608 : !> \param[out] tag the tag of the incoming message
2609 : !> \author Mandes
2610 : ! **************************************************************************************************
2611 1559291 : SUBROUTINE mp_probe(source, comm, tag)
2612 : INTEGER, INTENT(INOUT) :: source
2613 : CLASS(mp_comm_type), INTENT(IN) :: comm
2614 : INTEGER, INTENT(OUT) :: tag
2615 :
2616 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_probe'
2617 :
2618 : INTEGER :: handle
2619 : #if defined(__parallel)
2620 : INTEGER :: ierr
2621 : MPI_STATUS_TYPE :: status_single
2622 : LOGICAL :: flag
2623 : #endif
2624 :
2625 : ! ---------------------------------------------------------------------------
2626 :
2627 1559291 : CALL mp_timeset(routineN, handle)
2628 :
2629 : #if defined(__parallel)
2630 1559291 : IF (source .EQ. mp_any_source) THEN
2631 14 : CALL mpi_probe(mp_any_source, mp_any_tag, comm%handle, status_single, ierr)
2632 14 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_probe @ mp_probe")
2633 14 : source = status_single MPI_STATUS_EXTRACT(MPI_SOURCE)
2634 14 : tag = status_single MPI_STATUS_EXTRACT(MPI_TAG)
2635 : ELSE
2636 1559277 : flag = .FALSE.
2637 1559277 : CALL mpi_iprobe(source, mp_any_tag, comm%handle, flag, status_single, ierr)
2638 1559277 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iprobe @ mp_probe")
2639 1559277 : IF (flag .EQV. .FALSE.) THEN
2640 1549879 : source = mp_any_source
2641 1549879 : tag = -1 !status_single(MPI_TAG) ! in case of flag==false status is undefined
2642 : ELSE
2643 9398 : tag = status_single MPI_STATUS_EXTRACT(MPI_TAG)
2644 : END IF
2645 : END IF
2646 : #else
2647 : tag = -1
2648 : MARK_USED(comm)
2649 : MARK_USED(source)
2650 : #endif
2651 1559291 : CALL mp_timestop(handle)
2652 1559291 : END SUBROUTINE mp_probe
2653 :
2654 : ! **************************************************************************************************
2655 : ! Here come the data routines with none of the standard data types.
2656 : ! **************************************************************************************************
2657 :
2658 : ! **************************************************************************************************
2659 : !> \brief ...
2660 : !> \param msg ...
2661 : !> \param source ...
2662 : !> \param comm ...
2663 : ! **************************************************************************************************
2664 705864 : SUBROUTINE mp_bcast_b(msg, source, comm)
2665 : LOGICAL, INTENT(INOUT) :: msg
2666 : INTEGER, INTENT(IN) :: source
2667 : CLASS(mp_comm_type), INTENT(IN) :: comm
2668 :
2669 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b'
2670 :
2671 : INTEGER :: handle
2672 : #if defined(__parallel)
2673 : INTEGER :: ierr, msglen
2674 : #endif
2675 :
2676 705864 : CALL mp_timeset(routineN, handle)
2677 :
2678 : #if defined(__parallel)
2679 705864 : msglen = 1
2680 705864 : CALL mpi_bcast(msg, msglen, MPI_LOGICAL, source, comm%handle, ierr)
2681 705864 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2682 705864 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2683 : #else
2684 : MARK_USED(msg)
2685 : MARK_USED(source)
2686 : MARK_USED(comm)
2687 : #endif
2688 705864 : CALL mp_timestop(handle)
2689 705864 : END SUBROUTINE mp_bcast_b
2690 :
2691 : ! **************************************************************************************************
2692 : !> \brief ...
2693 : !> \param msg ...
2694 : !> \param source ...
2695 : !> \param comm ...
2696 : ! **************************************************************************************************
2697 667665 : SUBROUTINE mp_bcast_b_src(msg, comm)
2698 : LOGICAL, INTENT(INOUT) :: msg
2699 : CLASS(mp_comm_type), INTENT(IN) :: comm
2700 :
2701 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b_src'
2702 :
2703 : INTEGER :: handle
2704 : #if defined(__parallel)
2705 : INTEGER :: ierr, msglen
2706 : #endif
2707 :
2708 667665 : CALL mp_timeset(routineN, handle)
2709 :
2710 : #if defined(__parallel)
2711 667665 : msglen = 1
2712 667665 : CALL mpi_bcast(msg, msglen, MPI_LOGICAL, comm%source, comm%handle, ierr)
2713 667665 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2714 667665 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2715 : #else
2716 : MARK_USED(msg)
2717 : MARK_USED(comm)
2718 : #endif
2719 667665 : CALL mp_timestop(handle)
2720 667665 : END SUBROUTINE mp_bcast_b_src
2721 :
2722 : ! **************************************************************************************************
2723 : !> \brief ...
2724 : !> \param msg ...
2725 : !> \param source ...
2726 : !> \param comm ...
2727 : ! **************************************************************************************************
2728 0 : SUBROUTINE mp_bcast_bv(msg, source, comm)
2729 : LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2730 : INTEGER, INTENT(IN) :: source
2731 : CLASS(mp_comm_type), INTENT(IN) :: comm
2732 :
2733 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv'
2734 :
2735 : INTEGER :: handle
2736 : #if defined(__parallel)
2737 : INTEGER :: ierr, msglen
2738 : #endif
2739 :
2740 0 : CALL mp_timeset(routineN, handle)
2741 :
2742 : #if defined(__parallel)
2743 0 : msglen = SIZE(msg)
2744 0 : CALL mpi_bcast(msg, msglen, MPI_LOGICAL, source, comm%handle, ierr)
2745 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2746 0 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2747 : #else
2748 : MARK_USED(msg)
2749 : MARK_USED(source)
2750 : MARK_USED(comm)
2751 : #endif
2752 0 : CALL mp_timestop(handle)
2753 0 : END SUBROUTINE mp_bcast_bv
2754 :
2755 : ! **************************************************************************************************
2756 : !> \brief ...
2757 : !> \param msg ...
2758 : !> \param comm ...
2759 : ! **************************************************************************************************
2760 0 : SUBROUTINE mp_bcast_bv_src(msg, comm)
2761 : LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2762 : CLASS(mp_comm_type), INTENT(IN) :: comm
2763 :
2764 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv_src'
2765 :
2766 : INTEGER :: handle
2767 : #if defined(__parallel)
2768 : INTEGER :: ierr, msglen
2769 : #endif
2770 :
2771 0 : CALL mp_timeset(routineN, handle)
2772 :
2773 : #if defined(__parallel)
2774 0 : msglen = SIZE(msg)
2775 0 : CALL mpi_bcast(msg, msglen, MPI_LOGICAL, comm%source, comm%handle, ierr)
2776 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2777 0 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2778 : #else
2779 : MARK_USED(msg)
2780 : MARK_USED(comm)
2781 : #endif
2782 0 : CALL mp_timestop(handle)
2783 0 : END SUBROUTINE mp_bcast_bv_src
2784 :
2785 : ! **************************************************************************************************
2786 : !> \brief Non-blocking send of logical vector data
2787 : !> \param msgin the input message
2788 : !> \param dest the destination processor
2789 : !> \param comm the communicator object
2790 : !> \param request communication request index
2791 : !> \param tag message tag
2792 : !> \par History
2793 : !> 3.2016 added _bv subroutine [Nico Holmberg]
2794 : !> \author fawzi
2795 : !> \note see mp_irecv_iv
2796 : !> \note
2797 : !> arrays can be pointers or assumed shape, but they must be contiguous!
2798 : ! **************************************************************************************************
2799 16 : SUBROUTINE mp_isend_bv(msgin, dest, comm, request, tag)
2800 : LOGICAL, DIMENSION(:), INTENT(IN) :: msgin
2801 : INTEGER, INTENT(IN) :: dest
2802 : CLASS(mp_comm_type), INTENT(IN) :: comm
2803 : TYPE(mp_request_type), INTENT(out) :: request
2804 : INTEGER, INTENT(in), OPTIONAL :: tag
2805 :
2806 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bv'
2807 :
2808 : INTEGER :: handle
2809 : #if defined(__parallel)
2810 : INTEGER :: ierr, msglen, my_tag
2811 : LOGICAL :: foo(1)
2812 : #endif
2813 :
2814 16 : CALL mp_timeset(routineN, handle)
2815 :
2816 : #if defined(__parallel)
2817 : #if !defined(__GNUC__) || __GNUC__ >= 9
2818 16 : CPASSERT(IS_CONTIGUOUS(msgin))
2819 : #endif
2820 :
2821 16 : my_tag = 0
2822 16 : IF (PRESENT(tag)) my_tag = tag
2823 :
2824 16 : msglen = SIZE(msgin, 1)
2825 16 : IF (msglen > 0) THEN
2826 : CALL mpi_isend(msgin(1), msglen, MPI_LOGICAL, dest, my_tag, &
2827 16 : comm%handle, request%handle, ierr)
2828 : ELSE
2829 : CALL mpi_isend(foo, msglen, MPI_LOGICAL, dest, my_tag, &
2830 0 : comm%handle, request%handle, ierr)
2831 : END IF
2832 16 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
2833 :
2834 16 : CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2835 : #else
2836 : CPABORT("mp_isend called in non parallel case")
2837 : MARK_USED(msgin)
2838 : MARK_USED(dest)
2839 : MARK_USED(comm)
2840 : MARK_USED(tag)
2841 : request = mp_request_null
2842 : #endif
2843 16 : CALL mp_timestop(handle)
2844 16 : END SUBROUTINE mp_isend_bv
2845 :
2846 : ! **************************************************************************************************
2847 : !> \brief Non-blocking receive of logical vector data
2848 : !> \param msgout the received message
2849 : !> \param source the source processor
2850 : !> \param comm the communicator object
2851 : !> \param request communication request index
2852 : !> \param tag message tag
2853 : !> \par History
2854 : !> 3.2016 added _bv subroutine [Nico Holmberg]
2855 : !> \author fawzi
2856 : !> \note see mp_irecv_iv
2857 : !> \note
2858 : !> arrays can be pointers or assumed shape, but they must be contiguous!
2859 : ! **************************************************************************************************
2860 16 : SUBROUTINE mp_irecv_bv(msgout, source, comm, request, tag)
2861 : LOGICAL, DIMENSION(:), INTENT(INOUT) :: msgout
2862 : INTEGER, INTENT(IN) :: source
2863 : CLASS(mp_comm_type), INTENT(IN) :: comm
2864 : TYPE(mp_request_type), INTENT(out) :: request
2865 : INTEGER, INTENT(in), OPTIONAL :: tag
2866 :
2867 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bv'
2868 :
2869 : INTEGER :: handle
2870 : #if defined(__parallel)
2871 : INTEGER :: ierr, msglen, my_tag
2872 : LOGICAL :: foo(1)
2873 : #endif
2874 :
2875 16 : CALL mp_timeset(routineN, handle)
2876 :
2877 : #if defined(__parallel)
2878 : #if !defined(__GNUC__) || __GNUC__ >= 9
2879 16 : CPASSERT(IS_CONTIGUOUS(msgout))
2880 : #endif
2881 :
2882 16 : my_tag = 0
2883 16 : IF (PRESENT(tag)) my_tag = tag
2884 :
2885 16 : msglen = SIZE(msgout, 1)
2886 16 : IF (msglen > 0) THEN
2887 : CALL mpi_irecv(msgout(1), msglen, MPI_LOGICAL, source, my_tag, &
2888 16 : comm%handle, request%handle, ierr)
2889 : ELSE
2890 : CALL mpi_irecv(foo, msglen, MPI_LOGICAL, source, my_tag, &
2891 0 : comm%handle, request%handle, ierr)
2892 : END IF
2893 16 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routineN)
2894 :
2895 16 : CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
2896 : #else
2897 : CPABORT("mp_irecv called in non parallel case")
2898 : MARK_USED(msgout)
2899 : MARK_USED(source)
2900 : MARK_USED(comm)
2901 : MARK_USED(tag)
2902 : request = mp_request_null
2903 : #endif
2904 16 : CALL mp_timestop(handle)
2905 16 : END SUBROUTINE mp_irecv_bv
2906 :
2907 : ! **************************************************************************************************
2908 : !> \brief Non-blocking send of rank-3 logical data
2909 : !> \param msgin the input message
2910 : !> \param dest the destination processor
2911 : !> \param comm the communicator object
2912 : !> \param request communication request index
2913 : !> \param tag message tag
2914 : !> \par History
2915 : !> 2.2016 added _bm3 subroutine [Nico Holmberg]
2916 : !> \author fawzi
2917 : !> \note see mp_irecv_iv
2918 : !> \note
2919 : !> arrays can be pointers or assumed shape, but they must be contiguous!
2920 : ! **************************************************************************************************
2921 0 : SUBROUTINE mp_isend_bm3(msgin, dest, comm, request, tag)
2922 : LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgin
2923 : INTEGER, INTENT(IN) :: dest
2924 : CLASS(mp_comm_type), INTENT(IN) :: comm
2925 : TYPE(mp_request_type), INTENT(out) :: request
2926 : INTEGER, INTENT(in), OPTIONAL :: tag
2927 :
2928 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bm3'
2929 :
2930 : INTEGER :: handle
2931 : #if defined(__parallel)
2932 : INTEGER :: ierr, msglen, my_tag
2933 : LOGICAL :: foo(1)
2934 : #endif
2935 :
2936 0 : CALL mp_timeset(routineN, handle)
2937 :
2938 : #if defined(__parallel)
2939 : #if !defined(__GNUC__) || __GNUC__ >= 9
2940 0 : CPASSERT(IS_CONTIGUOUS(msgin))
2941 : #endif
2942 :
2943 0 : my_tag = 0
2944 0 : IF (PRESENT(tag)) my_tag = tag
2945 :
2946 0 : msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
2947 0 : IF (msglen > 0) THEN
2948 : CALL mpi_isend(msgin(1, 1, 1), msglen, MPI_LOGICAL, dest, my_tag, &
2949 0 : comm%handle, request%handle, ierr)
2950 : ELSE
2951 : CALL mpi_isend(foo, msglen, MPI_LOGICAL, dest, my_tag, &
2952 0 : comm%handle, request%handle, ierr)
2953 : END IF
2954 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
2955 :
2956 0 : CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2957 : #else
2958 : CPABORT("mp_isend called in non parallel case")
2959 : MARK_USED(msgin)
2960 : MARK_USED(dest)
2961 : MARK_USED(comm)
2962 : MARK_USED(tag)
2963 : request = mp_request_null
2964 : #endif
2965 0 : CALL mp_timestop(handle)
2966 0 : END SUBROUTINE mp_isend_bm3
2967 :
2968 : ! **************************************************************************************************
2969 : !> \brief Non-blocking receive of rank-3 logical data
2970 : !> \param msgout the received message
2971 : !> \param source the source processor
2972 : !> \param comm the communicator object
2973 : !> \param request communication request index
2974 : !> \param tag message tag
2975 : !> \par History
2976 : !> 2.2016 added _bm3 subroutine [Nico Holmberg]
2977 : !> \author fawzi
2978 : !> \note see mp_irecv_iv
2979 : !> \note
2980 : !> arrays can be pointers or assumed shape, but they must be contiguous!
2981 : ! **************************************************************************************************
2982 0 : SUBROUTINE mp_irecv_bm3(msgout, source, comm, request, tag)
2983 : LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgout
2984 : INTEGER, INTENT(IN) :: source
2985 : CLASS(mp_comm_type), INTENT(IN) :: comm
2986 : TYPE(mp_request_type), INTENT(out) :: request
2987 : INTEGER, INTENT(in), OPTIONAL :: tag
2988 :
2989 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bm3'
2990 :
2991 : INTEGER :: handle
2992 : #if defined(__parallel)
2993 : INTEGER :: ierr, msglen, my_tag
2994 : LOGICAL :: foo(1)
2995 : #endif
2996 :
2997 0 : CALL mp_timeset(routineN, handle)
2998 :
2999 : #if defined(__parallel)
3000 : #if !defined(__GNUC__) || __GNUC__ >= 9
3001 0 : CPASSERT(IS_CONTIGUOUS(msgout))
3002 : #endif
3003 :
3004 0 : my_tag = 0
3005 0 : IF (PRESENT(tag)) my_tag = tag
3006 :
3007 0 : msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
3008 0 : IF (msglen > 0) THEN
3009 : CALL mpi_irecv(msgout(1, 1, 1), msglen, MPI_LOGICAL, source, my_tag, &
3010 0 : comm%handle, request%handle, ierr)
3011 : ELSE
3012 : CALL mpi_irecv(foo, msglen, MPI_LOGICAL, source, my_tag, &
3013 0 : comm%handle, request%handle, ierr)
3014 : END IF
3015 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routineN)
3016 :
3017 0 : CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
3018 : #else
3019 : CPABORT("mp_irecv called in non parallel case")
3020 : MARK_USED(msgout)
3021 : MARK_USED(source)
3022 : MARK_USED(comm)
3023 : MARK_USED(request)
3024 : MARK_USED(tag)
3025 : request = mp_request_null
3026 : #endif
3027 0 : CALL mp_timestop(handle)
3028 0 : END SUBROUTINE mp_irecv_bm3
3029 :
3030 : ! **************************************************************************************************
3031 : !> \brief ...
3032 : !> \param msg ...
3033 : !> \param source ...
3034 : !> \param comm ...
3035 : ! **************************************************************************************************
3036 3899980 : SUBROUTINE mp_bcast_av(msg, source, comm)
3037 : CHARACTER(LEN=*), INTENT(INOUT) :: msg
3038 : INTEGER, INTENT(IN) :: source
3039 : CLASS(mp_comm_type), INTENT(IN) :: comm
3040 :
3041 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av'
3042 :
3043 : INTEGER :: handle
3044 : #if defined(__parallel)
3045 : INTEGER :: i, ierr, msglen
3046 3899980 : INTEGER, DIMENSION(:), ALLOCATABLE :: imsg
3047 : #endif
3048 :
3049 3899980 : CALL mp_timeset(routineN, handle)
3050 :
3051 : #if defined(__parallel)
3052 :
3053 3899980 : IF (comm%mepos == source) msglen = LEN_TRIM(msg)
3054 :
3055 3899980 : CALL comm%bcast(msglen, source)
3056 : ! this is a workaround to avoid problems on the T3E
3057 : ! at the moment we have a data alignment error when trying to
3058 : ! broadcast characters on the T3E (not always!)
3059 : ! JH 19/3/99 on galileo
3060 : ! CALL mpi_bcast(msg,msglen,MPI_CHARACTER,source,gid%handle,ierr)
3061 11690185 : ALLOCATE (imsg(1:msglen))
3062 76570295 : DO i = 1, msglen
3063 76570295 : imsg(i) = ICHAR(msg(i:i))
3064 : END DO
3065 3899980 : CALL mpi_bcast(imsg, msglen, MPI_INTEGER, source, comm%handle, ierr)
3066 3899980 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
3067 3899980 : msg = ""
3068 76570295 : DO i = 1, msglen
3069 76570295 : msg(i:i) = CHAR(imsg(i))
3070 : END DO
3071 3899980 : DEALLOCATE (imsg)
3072 3899980 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen)
3073 : #else
3074 : MARK_USED(msg)
3075 : MARK_USED(source)
3076 : MARK_USED(comm)
3077 : #endif
3078 3899980 : CALL mp_timestop(handle)
3079 3899980 : END SUBROUTINE mp_bcast_av
3080 :
3081 : ! **************************************************************************************************
3082 : !> \brief ...
3083 : !> \param msg ...
3084 : !> \param comm ...
3085 : ! **************************************************************************************************
3086 722 : SUBROUTINE mp_bcast_av_src(msg, comm)
3087 : CHARACTER(LEN=*), INTENT(INOUT) :: msg
3088 : CLASS(mp_comm_type), INTENT(IN) :: comm
3089 :
3090 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av_src'
3091 :
3092 : INTEGER :: handle
3093 : #if defined(__parallel)
3094 : INTEGER :: i, ierr, msglen
3095 722 : INTEGER, DIMENSION(:), ALLOCATABLE :: imsg
3096 : #endif
3097 :
3098 722 : CALL mp_timeset(routineN, handle)
3099 :
3100 : #if defined(__parallel)
3101 :
3102 722 : IF (comm%is_source()) msglen = LEN_TRIM(msg)
3103 :
3104 722 : CALL comm%bcast(msglen, comm%source)
3105 : ! this is a workaround to avoid problems on the T3E
3106 : ! at the moment we have a data alignment error when trying to
3107 : ! broadcast characters on the T3E (not always!)
3108 : ! JH 19/3/99 on galileo
3109 : ! CALL mpi_bcast(msg,msglen,MPI_CHARACTER,source,gid%handle,ierr)
3110 2166 : ALLOCATE (imsg(1:msglen))
3111 13988 : DO i = 1, msglen
3112 13988 : imsg(i) = ICHAR(msg(i:i))
3113 : END DO
3114 722 : CALL mpi_bcast(imsg, msglen, MPI_INTEGER, comm%source, comm%handle, ierr)
3115 722 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
3116 722 : msg = ""
3117 13988 : DO i = 1, msglen
3118 13988 : msg(i:i) = CHAR(imsg(i))
3119 : END DO
3120 722 : DEALLOCATE (imsg)
3121 722 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen)
3122 : #else
3123 : MARK_USED(msg)
3124 : MARK_USED(comm)
3125 : #endif
3126 722 : CALL mp_timestop(handle)
3127 722 : END SUBROUTINE mp_bcast_av_src
3128 :
3129 : ! **************************************************************************************************
3130 : !> \brief ...
3131 : !> \param msg ...
3132 : !> \param source ...
3133 : !> \param comm ...
3134 : ! **************************************************************************************************
3135 28 : SUBROUTINE mp_bcast_am(msg, source, comm)
3136 : CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3137 : INTEGER, INTENT(IN) :: source
3138 : CLASS(mp_comm_type), INTENT(IN) :: comm
3139 :
3140 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am'
3141 :
3142 : INTEGER :: handle
3143 : #if defined(__parallel)
3144 : INTEGER :: i, ierr, j, k, msglen, msgsiz
3145 28 : INTEGER, ALLOCATABLE :: imsg(:), imsglen(:)
3146 : #endif
3147 :
3148 28 : CALL mp_timeset(routineN, handle)
3149 :
3150 : #if defined(__parallel)
3151 28 : msgsiz = SIZE(msg)
3152 : ! Determine size of the minimum array of integers to broadcast the string
3153 84 : ALLOCATE (imsglen(1:msgsiz))
3154 28 : IF (comm%mepos == source) THEN
3155 1894 : DO j = 1, msgsiz
3156 1894 : imsglen(j) = LEN_TRIM(msg(j))
3157 : END DO
3158 : END IF
3159 28 : CALL comm%bcast(imsglen, source)
3160 3788 : msglen = SUM(imsglen)
3161 : ! this is a workaround to avoid problems on the T3E
3162 : ! at the moment we have a data alignment error when trying to
3163 : ! broadcast characters on the T3E (not always!)
3164 : ! JH 19/3/99 on galileo
3165 84 : ALLOCATE (imsg(1:msglen))
3166 3788 : k = 0
3167 3788 : DO j = 1, msgsiz
3168 7548 : DO i = 1, imsglen(j)
3169 3760 : k = k + 1
3170 7520 : imsg(k) = ICHAR(msg(j) (i:i))
3171 : END DO
3172 : END DO
3173 28 : CALL mpi_bcast(imsg, msglen, MPI_INTEGER, source, comm%handle, ierr)
3174 28 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
3175 3788 : msg = ""
3176 : k = 0
3177 3788 : DO j = 1, msgsiz
3178 7548 : DO i = 1, imsglen(j)
3179 3760 : k = k + 1
3180 7520 : msg(j) (i:i) = CHAR(imsg(k))
3181 : END DO
3182 : END DO
3183 28 : DEALLOCATE (imsg)
3184 28 : DEALLOCATE (imsglen)
3185 28 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen*msgsiz)
3186 : #else
3187 : MARK_USED(msg)
3188 : MARK_USED(source)
3189 : MARK_USED(comm)
3190 : #endif
3191 28 : CALL mp_timestop(handle)
3192 56 : END SUBROUTINE mp_bcast_am
3193 :
3194 78884 : SUBROUTINE mp_bcast_am_src(msg, comm)
3195 : CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3196 : CLASS(mp_comm_type), INTENT(IN) :: comm
3197 :
3198 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am_src'
3199 :
3200 : INTEGER :: handle
3201 : #if defined(__parallel)
3202 : INTEGER :: i, ierr, j, k, msglen, msgsiz
3203 78884 : INTEGER, ALLOCATABLE :: imsg(:), imsglen(:)
3204 : #endif
3205 :
3206 78884 : CALL mp_timeset(routineN, handle)
3207 :
3208 : #if defined(__parallel)
3209 78884 : msgsiz = SIZE(msg)
3210 : ! Determine size of the minimum array of integers to broadcast the string
3211 236652 : ALLOCATE (imsglen(1:msgsiz))
3212 78962884 : DO j = 1, msgsiz
3213 78962884 : imsglen(j) = LEN_TRIM(msg(j))
3214 : END DO
3215 78884 : CALL comm%bcast(imsglen, comm%source)
3216 78962884 : msglen = SUM(imsglen)
3217 : ! this is a workaround to avoid problems on the T3E
3218 : ! at the moment we have a data alignment error when trying to
3219 : ! broadcast characters on the T3E (not always!)
3220 : ! JH 19/3/99 on galileo
3221 236652 : ALLOCATE (imsg(1:msglen))
3222 78962884 : k = 0
3223 78962884 : DO j = 1, msgsiz
3224 2347390294 : DO i = 1, imsglen(j)
3225 2268427410 : k = k + 1
3226 2347311410 : imsg(k) = ICHAR(msg(j) (i:i))
3227 : END DO
3228 : END DO
3229 78884 : CALL mpi_bcast(imsg, msglen, MPI_INTEGER, comm%source, comm%handle, ierr)
3230 78884 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
3231 78962884 : msg = ""
3232 : k = 0
3233 78962884 : DO j = 1, msgsiz
3234 2347390294 : DO i = 1, imsglen(j)
3235 2268427410 : k = k + 1
3236 2347311410 : msg(j) (i:i) = CHAR(imsg(k))
3237 : END DO
3238 : END DO
3239 78884 : DEALLOCATE (imsg)
3240 78884 : DEALLOCATE (imsglen)
3241 78884 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen*msgsiz)
3242 : #else
3243 : MARK_USED(msg)
3244 : MARK_USED(comm)
3245 : #endif
3246 78884 : CALL mp_timestop(handle)
3247 157768 : END SUBROUTINE mp_bcast_am_src
3248 :
3249 : ! **************************************************************************************************
3250 : !> \brief Finds the location of the minimal element in a vector.
3251 : !> \param[in,out] msg Find location of maximum element among these
3252 : !> data (input).
3253 : !> \param[in] comm Message passing environment identifier
3254 : !> \par MPI mapping
3255 : !> mpi_allreduce with the MPI_MINLOC reduction function identifier
3256 : !> \par Invalid data types
3257 : !> This routine is invalid for (int_8) data!
3258 : ! **************************************************************************************************
3259 310 : SUBROUTINE mp_minloc_dv(msg, comm)
3260 : REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3261 : CLASS(mp_comm_type), INTENT(IN) :: comm
3262 :
3263 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_dv'
3264 :
3265 : INTEGER :: handle
3266 : #if defined(__parallel)
3267 : INTEGER :: ierr, msglen
3268 310 : REAL(kind=real_8), ALLOCATABLE :: res(:)
3269 : #endif
3270 :
3271 : IF ("d" .EQ. "l" .AND. real_8 .EQ. int_8) THEN
3272 : CPABORT("Minimal location not available with long integers @ "//routineN)
3273 : END IF
3274 310 : CALL mp_timeset(routineN, handle)
3275 :
3276 : #if defined(__parallel)
3277 310 : msglen = SIZE(msg)
3278 930 : ALLOCATE (res(1:msglen), STAT=ierr)
3279 310 : IF (ierr /= 0) &
3280 0 : CPABORT("allocate @ "//routineN)
3281 310 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2DOUBLE_PRECISION, MPI_MINLOC, comm%handle, ierr)
3282 310 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3283 930 : msg = res
3284 310 : DEALLOCATE (res)
3285 310 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3286 : #else
3287 : MARK_USED(msg)
3288 : MARK_USED(comm)
3289 : #endif
3290 310 : CALL mp_timestop(handle)
3291 310 : END SUBROUTINE mp_minloc_dv
3292 :
3293 : ! **************************************************************************************************
3294 : !> \brief Finds the location of the minimal element in a vector.
3295 : !> \param[in,out] msg Find location of maximum element among these
3296 : !> data (input).
3297 : !> \param[in] comm Message passing environment identifier
3298 : !> \par MPI mapping
3299 : !> mpi_allreduce with the MPI_MINLOC reduction function identifier
3300 : !> \par Invalid data types
3301 : !> This routine is invalid for (int_8) data!
3302 : ! **************************************************************************************************
3303 0 : SUBROUTINE mp_minloc_iv(msg, comm)
3304 : INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3305 : CLASS(mp_comm_type), INTENT(IN) :: comm
3306 :
3307 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_iv'
3308 :
3309 : INTEGER :: handle
3310 : #if defined(__parallel)
3311 : INTEGER :: ierr, msglen
3312 0 : INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3313 : #endif
3314 :
3315 : IF ("i" .EQ. "l" .AND. int_4 .EQ. int_8) THEN
3316 : CPABORT("Minimal location not available with long integers @ "//routineN)
3317 : END IF
3318 0 : CALL mp_timeset(routineN, handle)
3319 :
3320 : #if defined(__parallel)
3321 0 : msglen = SIZE(msg)
3322 0 : ALLOCATE (res(1:msglen))
3323 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2INTEGER, MPI_MINLOC, comm%handle, ierr)
3324 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3325 0 : msg = res
3326 0 : DEALLOCATE (res)
3327 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3328 : #else
3329 : MARK_USED(msg)
3330 : MARK_USED(comm)
3331 : #endif
3332 0 : CALL mp_timestop(handle)
3333 0 : END SUBROUTINE mp_minloc_iv
3334 :
3335 : ! **************************************************************************************************
3336 : !> \brief Finds the location of the minimal element in a vector.
3337 : !> \param[in,out] msg Find location of maximum element among these
3338 : !> data (input).
3339 : !> \param[in] comm Message passing environment identifier
3340 : !> \par MPI mapping
3341 : !> mpi_allreduce with the MPI_MINLOC reduction function identifier
3342 : !> \par Invalid data types
3343 : !> This routine is invalid for (int_8) data!
3344 : ! **************************************************************************************************
3345 0 : SUBROUTINE mp_minloc_lv(msg, comm)
3346 : INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3347 : CLASS(mp_comm_type), INTENT(IN) :: comm
3348 :
3349 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_lv'
3350 :
3351 : INTEGER :: handle
3352 : #if defined(__parallel)
3353 : INTEGER :: ierr, msglen
3354 0 : INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3355 : #endif
3356 :
3357 : IF ("l" .EQ. "l" .AND. int_8 .EQ. int_8) THEN
3358 0 : CPABORT("Minimal location not available with long integers @ "//routineN)
3359 : END IF
3360 0 : CALL mp_timeset(routineN, handle)
3361 :
3362 : #if defined(__parallel)
3363 0 : msglen = SIZE(msg)
3364 0 : ALLOCATE (res(1:msglen))
3365 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_INTEGER8, MPI_MINLOC, comm%handle, ierr)
3366 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3367 0 : msg = res
3368 0 : DEALLOCATE (res)
3369 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3370 : #else
3371 : MARK_USED(msg)
3372 : MARK_USED(comm)
3373 : #endif
3374 0 : CALL mp_timestop(handle)
3375 0 : END SUBROUTINE mp_minloc_lv
3376 :
3377 : ! **************************************************************************************************
3378 : !> \brief Finds the location of the minimal element in a vector.
3379 : !> \param[in,out] msg Find location of maximum element among these
3380 : !> data (input).
3381 : !> \param[in] comm Message passing environment identifier
3382 : !> \par MPI mapping
3383 : !> mpi_allreduce with the MPI_MINLOC reduction function identifier
3384 : !> \par Invalid data types
3385 : !> This routine is invalid for (int_8) data!
3386 : ! **************************************************************************************************
3387 0 : SUBROUTINE mp_minloc_rv(msg, comm)
3388 : REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3389 : CLASS(mp_comm_type), INTENT(IN) :: comm
3390 :
3391 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_rv'
3392 :
3393 : INTEGER :: handle
3394 : #if defined(__parallel)
3395 : INTEGER :: ierr, msglen
3396 0 : REAL(kind=real_4), ALLOCATABLE :: res(:)
3397 : #endif
3398 :
3399 : IF ("r" .EQ. "l" .AND. real_4 .EQ. int_8) THEN
3400 : CPABORT("Minimal location not available with long integers @ "//routineN)
3401 : END IF
3402 0 : CALL mp_timeset(routineN, handle)
3403 :
3404 : #if defined(__parallel)
3405 0 : msglen = SIZE(msg)
3406 0 : ALLOCATE (res(1:msglen))
3407 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2REAL, MPI_MINLOC, comm%handle, ierr)
3408 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3409 0 : msg = res
3410 0 : DEALLOCATE (res)
3411 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3412 : #else
3413 : MARK_USED(msg)
3414 : MARK_USED(comm)
3415 : #endif
3416 0 : CALL mp_timestop(handle)
3417 0 : END SUBROUTINE mp_minloc_rv
3418 :
3419 : ! **************************************************************************************************
3420 : !> \brief Finds the location of the maximal element in a vector.
3421 : !> \param[in,out] msg Find location of maximum element among these
3422 : !> data (input).
3423 : !> \param[in] comm Message passing environment identifier
3424 : !> \par MPI mapping
3425 : !> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3426 : !> \par Invalid data types
3427 : !> This routine is invalid for (int_8) data!
3428 : ! **************************************************************************************************
3429 7787585 : SUBROUTINE mp_maxloc_dv(msg, comm)
3430 : REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3431 : CLASS(mp_comm_type), INTENT(IN) :: comm
3432 :
3433 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_dv'
3434 :
3435 : INTEGER :: handle
3436 : #if defined(__parallel)
3437 : INTEGER :: ierr, msglen
3438 7787585 : REAL(kind=real_8), ALLOCATABLE :: res(:)
3439 : #endif
3440 :
3441 : IF ("d" .EQ. "l" .AND. real_8 .EQ. int_8) THEN
3442 : CPABORT("Maximal location not available with long integers @ "//routineN)
3443 : END IF
3444 7787585 : CALL mp_timeset(routineN, handle)
3445 :
3446 : #if defined(__parallel)
3447 7787585 : msglen = SIZE(msg)
3448 23362755 : ALLOCATE (res(1:msglen))
3449 7787585 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, comm%handle, ierr)
3450 7787585 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3451 23362755 : msg = res
3452 7787585 : DEALLOCATE (res)
3453 7787585 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3454 : #else
3455 : MARK_USED(msg)
3456 : MARK_USED(comm)
3457 : #endif
3458 7787585 : CALL mp_timestop(handle)
3459 7787585 : END SUBROUTINE mp_maxloc_dv
3460 :
3461 : ! **************************************************************************************************
3462 : !> \brief Finds the location of the maximal element in a vector.
3463 : !> \param[in,out] msg Find location of maximum element among these
3464 : !> data (input).
3465 : !> \param[in] comm Message passing environment identifier
3466 : !> \par MPI mapping
3467 : !> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3468 : !> \par Invalid data types
3469 : !> This routine is invalid for (int_8) data!
3470 : ! **************************************************************************************************
3471 138 : SUBROUTINE mp_maxloc_iv(msg, comm)
3472 : INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3473 : CLASS(mp_comm_type), INTENT(IN) :: comm
3474 :
3475 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_iv'
3476 :
3477 : INTEGER :: handle
3478 : #if defined(__parallel)
3479 : INTEGER :: ierr, msglen
3480 138 : INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3481 : #endif
3482 :
3483 : IF ("i" .EQ. "l" .AND. int_4 .EQ. int_8) THEN
3484 : CPABORT("Maximal location not available with long integers @ "//routineN)
3485 : END IF
3486 138 : CALL mp_timeset(routineN, handle)
3487 :
3488 : #if defined(__parallel)
3489 138 : msglen = SIZE(msg)
3490 414 : ALLOCATE (res(1:msglen))
3491 138 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2INTEGER, MPI_MAXLOC, comm%handle, ierr)
3492 138 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3493 414 : msg = res
3494 138 : DEALLOCATE (res)
3495 138 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3496 : #else
3497 : MARK_USED(msg)
3498 : MARK_USED(comm)
3499 : #endif
3500 138 : CALL mp_timestop(handle)
3501 138 : END SUBROUTINE mp_maxloc_iv
3502 :
3503 : ! **************************************************************************************************
3504 : !> \brief Finds the location of the maximal element in a vector.
3505 : !> \param[in,out] msg Find location of maximum element among these
3506 : !> data (input).
3507 : !> \param[in] comm Message passing environment identifier
3508 : !> \par MPI mapping
3509 : !> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3510 : !> \par Invalid data types
3511 : !> This routine is invalid for (int_8) data!
3512 : ! **************************************************************************************************
3513 0 : SUBROUTINE mp_maxloc_lv(msg, comm)
3514 : INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3515 : CLASS(mp_comm_type), INTENT(IN) :: comm
3516 :
3517 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_lv'
3518 :
3519 : INTEGER :: handle
3520 : #if defined(__parallel)
3521 : INTEGER :: ierr, msglen
3522 0 : INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3523 : #endif
3524 :
3525 : IF ("l" .EQ. "l" .AND. int_8 .EQ. int_8) THEN
3526 0 : CPABORT("Maximal location not available with long integers @ "//routineN)
3527 : END IF
3528 0 : CALL mp_timeset(routineN, handle)
3529 :
3530 : #if defined(__parallel)
3531 0 : msglen = SIZE(msg)
3532 0 : ALLOCATE (res(1:msglen))
3533 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_INTEGER8, MPI_MAXLOC, comm%handle, ierr)
3534 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3535 0 : msg = res
3536 0 : DEALLOCATE (res)
3537 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3538 : #else
3539 : MARK_USED(msg)
3540 : MARK_USED(comm)
3541 : #endif
3542 0 : CALL mp_timestop(handle)
3543 0 : END SUBROUTINE mp_maxloc_lv
3544 :
3545 : ! **************************************************************************************************
3546 : !> \brief Finds the location of the maximal element in a vector.
3547 : !> \param[in,out] msg Find location of maximum element among these
3548 : !> data (input).
3549 : !> \param[in] comm Message passing environment identifier
3550 : !> \par MPI mapping
3551 : !> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3552 : !> \par Invalid data types
3553 : !> This routine is invalid for (int_8) data!
3554 : ! **************************************************************************************************
3555 0 : SUBROUTINE mp_maxloc_rv(msg, comm)
3556 : REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3557 : CLASS(mp_comm_type), INTENT(IN) :: comm
3558 :
3559 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_rv'
3560 :
3561 : INTEGER :: handle
3562 : #if defined(__parallel)
3563 : INTEGER :: ierr, msglen
3564 0 : REAL(kind=real_4), ALLOCATABLE :: res(:)
3565 : #endif
3566 :
3567 : IF ("r" .EQ. "l" .AND. real_4 .EQ. int_8) THEN
3568 : CPABORT("Maximal location not available with long integers @ "//routineN)
3569 : END IF
3570 0 : CALL mp_timeset(routineN, handle)
3571 :
3572 : #if defined(__parallel)
3573 0 : msglen = SIZE(msg)
3574 0 : ALLOCATE (res(1:msglen))
3575 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2REAL, MPI_MAXLOC, comm%handle, ierr)
3576 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3577 0 : msg = res
3578 0 : DEALLOCATE (res)
3579 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3580 : #else
3581 : MARK_USED(msg)
3582 : MARK_USED(comm)
3583 : #endif
3584 0 : CALL mp_timestop(handle)
3585 0 : END SUBROUTINE mp_maxloc_rv
3586 :
3587 : ! **************************************************************************************************
3588 : !> \brief Logical OR reduction
3589 : !> \param[in,out] msg Datum to perform inclusive disjunction (input)
3590 : !> and resultant inclusive disjunction (output)
3591 : !> \param[in] comm Message passing environment identifier
3592 : !> \par MPI mapping
3593 : !> mpi_allreduce
3594 : ! **************************************************************************************************
3595 58746 : SUBROUTINE mp_sum_b(msg, comm)
3596 : LOGICAL, INTENT(INOUT) :: msg
3597 : CLASS(mp_comm_type), INTENT(IN) :: comm
3598 :
3599 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_b'
3600 :
3601 : INTEGER :: handle
3602 : #if defined(__parallel)
3603 : INTEGER :: ierr, msglen
3604 : #endif
3605 :
3606 58746 : CALL mp_timeset(routineN, handle)
3607 : #if defined(__parallel)
3608 58746 : msglen = 1
3609 58746 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, comm%handle, ierr)
3610 58746 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3611 : #else
3612 : MARK_USED(msg)
3613 : MARK_USED(comm)
3614 : #endif
3615 58746 : CALL mp_timestop(handle)
3616 58746 : END SUBROUTINE mp_sum_b
3617 :
3618 : ! **************************************************************************************************
3619 : !> \brief Logical OR reduction
3620 : !> \param[in,out] msg Datum to perform inclusive disjunction (input)
3621 : !> and resultant inclusive disjunction (output)
3622 : !> \param[in] comm Message passing environment identifier
3623 : !> \par MPI mapping
3624 : !> mpi_allreduce
3625 : ! **************************************************************************************************
3626 0 : SUBROUTINE mp_sum_bv(msg, comm)
3627 : LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: msg
3628 : CLASS(mp_comm_type), INTENT(IN) :: comm
3629 :
3630 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_bv'
3631 :
3632 : INTEGER :: handle
3633 : #if defined(__parallel)
3634 : INTEGER :: ierr, msglen
3635 : #endif
3636 :
3637 0 : CALL mp_timeset(routineN, handle)
3638 : #if defined(__parallel)
3639 0 : msglen = SIZE(msg)
3640 0 : IF (msglen .GT. 0) THEN
3641 0 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, comm%handle, ierr)
3642 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3643 : END IF
3644 : #else
3645 : MARK_USED(msg)
3646 : MARK_USED(comm)
3647 : #endif
3648 0 : CALL mp_timestop(handle)
3649 0 : END SUBROUTINE mp_sum_bv
3650 :
3651 : ! **************************************************************************************************
3652 : !> \brief Logical OR reduction
3653 : !> \param[in,out] msg Datum to perform inclusive disjunction (input)
3654 : !> and resultant inclusive disjunction (output)
3655 : !> \param[in] comm Message passing environment identifier
3656 : !> \param request ...
3657 : !> \par MPI mapping
3658 : !> mpi_allreduce
3659 : ! **************************************************************************************************
3660 0 : SUBROUTINE mp_isum_bv(msg, comm, request)
3661 : LOGICAL, DIMENSION(:), INTENT(INOUT) :: msg
3662 : CLASS(mp_comm_type), INTENT(IN) :: comm
3663 : TYPE(mp_request_type), INTENT(INOUT) :: request
3664 :
3665 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isum_bv'
3666 :
3667 : INTEGER :: handle
3668 : #if defined(__parallel)
3669 : INTEGER :: ierr, msglen
3670 : #endif
3671 :
3672 0 : CALL mp_timeset(routineN, handle)
3673 : #if defined(__parallel)
3674 0 : msglen = SIZE(msg)
3675 : #if !defined(__GNUC__) || __GNUC__ >= 9
3676 0 : CPASSERT(IS_CONTIGUOUS(msg))
3677 : #endif
3678 :
3679 0 : IF (msglen .GT. 0) THEN
3680 0 : CALL mpi_iallreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, comm%handle, request%handle, ierr)
3681 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3682 : ELSE
3683 0 : request = mp_request_null
3684 : END IF
3685 : #else
3686 : MARK_USED(msg)
3687 : MARK_USED(comm)
3688 : request = mp_request_null
3689 : #endif
3690 0 : CALL mp_timestop(handle)
3691 0 : END SUBROUTINE mp_isum_bv
3692 :
3693 : ! **************************************************************************************************
3694 : !> \brief Get Version of the MPI Library (MPI 3)
3695 : !> \param[out] version Version of the library,
3696 : !> declared as CHARACTER(LEN=mp_max_library_version_string)
3697 : !> \param[out] resultlen Length (in printable characters) of
3698 : !> the result returned in version (integer)
3699 : ! **************************************************************************************************
3700 0 : SUBROUTINE mp_get_library_version(version, resultlen)
3701 : CHARACTER(len=*), INTENT(OUT) :: version
3702 : INTEGER, INTENT(OUT) :: resultlen
3703 :
3704 : #if defined(__parallel)
3705 : INTEGER :: ierr
3706 : #endif
3707 :
3708 0 : version = ''
3709 :
3710 : #if defined(__parallel)
3711 0 : ierr = 0
3712 0 : CALL mpi_get_library_version(version, resultlen, ierr)
3713 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_get_library_version @ mp_get_library_version")
3714 : #else
3715 : resultlen = 0
3716 : #endif
3717 0 : END SUBROUTINE mp_get_library_version
3718 :
3719 : ! **************************************************************************************************
3720 : !> \brief Opens a file
3721 : !> \param[in] groupid message passing environment identifier
3722 : !> \param[out] fh file handle (file storage unit)
3723 : !> \param[in] filepath path to the file
3724 : !> \param amode_status access mode
3725 : !> \param info ...
3726 : !> \par MPI-I/O mapping mpi_file_open
3727 : !> \par STREAM-I/O mapping OPEN
3728 : !>
3729 : !> \param[in](optional) info info object
3730 : !> \par History
3731 : !> 11.2012 created [Hossein Bani-Hashemian]
3732 : ! **************************************************************************************************
3733 1888 : SUBROUTINE mp_file_open(groupid, fh, filepath, amode_status, info)
3734 : CLASS(mp_comm_type), INTENT(IN) :: groupid
3735 : CLASS(mp_file_type), INTENT(OUT) :: fh
3736 : CHARACTER(len=*), INTENT(IN) :: filepath
3737 : INTEGER, INTENT(IN) :: amode_status
3738 : TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3739 :
3740 : #if defined(__parallel)
3741 : INTEGER :: ierr
3742 : MPI_INFO_TYPE :: my_info
3743 : #else
3744 : CHARACTER(LEN=10) :: fstatus, fposition
3745 : INTEGER :: amode, handle, istat
3746 : LOGICAL :: exists, is_open
3747 : #endif
3748 :
3749 : #if defined(__parallel)
3750 1888 : ierr = 0
3751 1888 : my_info = mpi_info_null
3752 1888 : IF (PRESENT(info)) my_info = info%handle
3753 1888 : CALL mpi_file_open(groupid%handle, filepath, amode_status, my_info, fh%handle, ierr)
3754 1888 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
3755 1888 : IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open")
3756 : #else
3757 : MARK_USED(groupid)
3758 : MARK_USED(info)
3759 : amode = amode_status
3760 : IF (amode .GT. file_amode_append) THEN
3761 : fposition = "APPEND"
3762 : amode = amode - file_amode_append
3763 : ELSE
3764 : fposition = "REWIND"
3765 : END IF
3766 : IF ((amode .EQ. file_amode_create) .OR. &
3767 : (amode .EQ. file_amode_create + file_amode_wronly) .OR. &
3768 : (amode .EQ. file_amode_create + file_amode_wronly + file_amode_excl)) THEN
3769 : fstatus = "UNKNOWN"
3770 : ELSE
3771 : fstatus = "OLD"
3772 : END IF
3773 : ! Get a new unit number
3774 : DO handle = 1, 999
3775 : INQUIRE (UNIT=handle, EXIST=exists, OPENED=is_open, IOSTAT=istat)
3776 : IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) EXIT
3777 : END DO
3778 : OPEN (UNIT=handle, FILE=filepath, STATUS=fstatus, ACCESS="STREAM", POSITION=fposition)
3779 : fh%handle = handle
3780 : #endif
3781 1888 : END SUBROUTINE mp_file_open
3782 :
3783 : ! **************************************************************************************************
3784 : !> \brief Deletes a file. Auxiliary routine to emulate 'replace' action for mp_file_open.
3785 : !> Only the master processor should call this routine.
3786 : !> \param[in] filepath path to the file
3787 : !> \param[in](optional) info info object
3788 : !> \par History
3789 : !> 11.2017 created [Nico Holmberg]
3790 : ! **************************************************************************************************
3791 162 : SUBROUTINE mp_file_delete(filepath, info)
3792 : CHARACTER(len=*), INTENT(IN) :: filepath
3793 : TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3794 :
3795 : #if defined(__parallel)
3796 : INTEGER :: ierr
3797 : MPI_INFO_TYPE :: my_info
3798 : LOGICAL :: exists
3799 :
3800 162 : ierr = 0
3801 162 : my_info = mpi_info_null
3802 162 : IF (PRESENT(info)) my_info = info%handle
3803 162 : INQUIRE (FILE=filepath, EXIST=exists)
3804 162 : IF (exists) CALL mpi_file_delete(filepath, my_info, ierr)
3805 162 : IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete")
3806 : #else
3807 : MARK_USED(filepath)
3808 : MARK_USED(info)
3809 : ! Explicit file delete not necessary, handled by subsequent call to open_file with action 'replace'
3810 : #endif
3811 :
3812 162 : END SUBROUTINE mp_file_delete
3813 :
3814 : ! **************************************************************************************************
3815 : !> \brief Closes a file
3816 : !> \param[in] fh file handle (file storage unit)
3817 : !> \par MPI-I/O mapping mpi_file_close
3818 : !> \par STREAM-I/O mapping CLOSE
3819 : !>
3820 : !> \par History
3821 : !> 11.2012 created [Hossein Bani-Hashemian]
3822 : ! **************************************************************************************************
3823 1888 : SUBROUTINE mp_file_close(fh)
3824 : CLASS(mp_file_type), INTENT(INOUT) :: fh
3825 :
3826 : #if defined(__parallel)
3827 : INTEGER :: ierr
3828 :
3829 1888 : ierr = 0
3830 1888 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
3831 1888 : CALL mpi_file_close(fh%handle, ierr)
3832 1888 : IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close")
3833 : #else
3834 : CLOSE (fh%handle)
3835 : fh%handle = mp_file_null_handle
3836 : #endif
3837 1888 : END SUBROUTINE mp_file_close
3838 :
3839 0 : SUBROUTINE mp_file_assign(fh_new, fh_old)
3840 : CLASS(mp_file_type), INTENT(OUT) :: fh_new
3841 : CLASS(mp_file_type), INTENT(IN) :: fh_old
3842 :
3843 0 : fh_new%handle = fh_old%handle
3844 :
3845 0 : END SUBROUTINE
3846 :
3847 : ! **************************************************************************************************
3848 : !> \brief Returns the file size
3849 : !> \param[in] fh file handle (file storage unit)
3850 : !> \param[out] file_size the file size
3851 : !> \par MPI-I/O mapping mpi_file_get_size
3852 : !> \par STREAM-I/O mapping INQUIRE
3853 : !>
3854 : !> \par History
3855 : !> 12.2012 created [Hossein Bani-Hashemian]
3856 : ! **************************************************************************************************
3857 0 : SUBROUTINE mp_file_get_size(fh, file_size)
3858 : CLASS(mp_file_type), INTENT(IN) :: fh
3859 : INTEGER(kind=file_offset), INTENT(OUT) :: file_size
3860 :
3861 : #if defined(__parallel)
3862 : INTEGER :: ierr
3863 : #endif
3864 :
3865 : #if defined(__parallel)
3866 0 : ierr = 0
3867 0 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
3868 0 : CALL mpi_file_get_size(fh%handle, file_size, ierr)
3869 0 : IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size")
3870 : #else
3871 : INQUIRE (UNIT=fh%handle, SIZE=file_size)
3872 : #endif
3873 0 : END SUBROUTINE mp_file_get_size
3874 :
3875 : ! **************************************************************************************************
3876 : !> \brief Returns the file position
3877 : !> \param[in] fh file handle (file storage unit)
3878 : !> \param[out] file_size the file position
3879 : !> \par MPI-I/O mapping mpi_file_get_position
3880 : !> \par STREAM-I/O mapping INQUIRE
3881 : !>
3882 : !> \par History
3883 : !> 11.2017 created [Nico Holmberg]
3884 : ! **************************************************************************************************
3885 1850 : SUBROUTINE mp_file_get_position(fh, pos)
3886 : CLASS(mp_file_type), INTENT(IN) :: fh
3887 : INTEGER(kind=file_offset), INTENT(OUT) :: pos
3888 :
3889 : #if defined(__parallel)
3890 : INTEGER :: ierr
3891 : #endif
3892 :
3893 : #if defined(__parallel)
3894 1850 : ierr = 0
3895 1850 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
3896 1850 : CALL mpi_file_get_position(fh%handle, pos, ierr)
3897 1850 : IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position")
3898 : #else
3899 : INQUIRE (UNIT=fh%handle, POS=pos)
3900 : #endif
3901 1850 : END SUBROUTINE mp_file_get_position
3902 :
3903 : ! **************************************************************************************************
3904 : !> \brief (parallel) Blocking individual file write using explicit offsets
3905 : !> (serial) Unformatted stream write
3906 : !> \param[in] fh file handle (file storage unit)
3907 : !> \param[in] offset file offset (position)
3908 : !> \param[in] msg data to be written to the file
3909 : !> \param msglen ...
3910 : !> \par MPI-I/O mapping mpi_file_write_at
3911 : !> \par STREAM-I/O mapping WRITE
3912 : !> \param[in](optional) msglen number of the elements of data
3913 : ! **************************************************************************************************
3914 0 : SUBROUTINE mp_file_write_at_chv(fh, offset, msg, msglen)
3915 : CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
3916 : CLASS(mp_file_type), INTENT(IN) :: fh
3917 : INTEGER, INTENT(IN), OPTIONAL :: msglen
3918 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3919 :
3920 : #if defined(__parallel)
3921 : INTEGER :: ierr, msg_len
3922 : #endif
3923 :
3924 : #if defined(__parallel)
3925 0 : msg_len = SIZE(msg)
3926 0 : IF (PRESENT(msglen)) msg_len = msglen
3927 0 : CALL MPI_FILE_WRITE_AT(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3928 0 : IF (ierr .NE. 0) &
3929 0 : CPABORT("mpi_file_write_at_chv @ mp_file_write_at_chv")
3930 : #else
3931 : MARK_USED(msglen)
3932 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
3933 : #endif
3934 0 : END SUBROUTINE mp_file_write_at_chv
3935 :
3936 : ! **************************************************************************************************
3937 : !> \brief ...
3938 : !> \param fh ...
3939 : !> \param offset ...
3940 : !> \param msg ...
3941 : ! **************************************************************************************************
3942 8692 : SUBROUTINE mp_file_write_at_ch(fh, offset, msg)
3943 : CHARACTER(LEN=*), INTENT(IN) :: msg
3944 : CLASS(mp_file_type), INTENT(IN) :: fh
3945 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3946 :
3947 : #if defined(__parallel)
3948 : INTEGER :: ierr
3949 : #endif
3950 :
3951 : #if defined(__parallel)
3952 8692 : CALL MPI_FILE_WRITE_AT(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3953 8692 : IF (ierr .NE. 0) &
3954 0 : CPABORT("mpi_file_write_at_ch @ mp_file_write_at_ch")
3955 : #else
3956 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
3957 : #endif
3958 8692 : END SUBROUTINE mp_file_write_at_ch
3959 :
3960 : ! **************************************************************************************************
3961 : !> \brief (parallel) Blocking collective file write using explicit offsets
3962 : !> (serial) Unformatted stream write
3963 : !> \param fh ...
3964 : !> \param offset ...
3965 : !> \param msg ...
3966 : !> \param msglen ...
3967 : !> \par MPI-I/O mapping mpi_file_write_at_all
3968 : !> \par STREAM-I/O mapping WRITE
3969 : ! **************************************************************************************************
3970 0 : SUBROUTINE mp_file_write_at_all_chv(fh, offset, msg, msglen)
3971 : CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
3972 : CLASS(mp_file_type), INTENT(IN) :: fh
3973 : INTEGER, INTENT(IN), OPTIONAL :: msglen
3974 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3975 :
3976 : #if defined(__parallel)
3977 : INTEGER :: ierr, msg_len
3978 : #endif
3979 :
3980 : #if defined(__parallel)
3981 0 : msg_len = SIZE(msg)
3982 0 : IF (PRESENT(msglen)) msg_len = msglen
3983 0 : CALL MPI_FILE_WRITE_AT_ALL(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3984 0 : IF (ierr .NE. 0) &
3985 0 : CPABORT("mpi_file_write_at_all_chv @ mp_file_write_at_all_chv")
3986 : #else
3987 : MARK_USED(msglen)
3988 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
3989 : #endif
3990 0 : END SUBROUTINE mp_file_write_at_all_chv
3991 :
3992 : ! **************************************************************************************************
3993 : !> \brief wrapper to MPI_File_write_at_all
3994 : !> \param fh ...
3995 : !> \param offset ...
3996 : !> \param msg ...
3997 : ! **************************************************************************************************
3998 0 : SUBROUTINE mp_file_write_at_all_ch(fh, offset, msg)
3999 : CHARACTER(LEN=*), INTENT(IN) :: msg
4000 : CLASS(mp_file_type), INTENT(IN) :: fh
4001 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4002 :
4003 : #if defined(__parallel)
4004 : INTEGER :: ierr
4005 : #endif
4006 :
4007 : #if defined(__parallel)
4008 0 : CALL MPI_FILE_WRITE_AT_ALL(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4009 0 : IF (ierr .NE. 0) &
4010 0 : CPABORT("mpi_file_write_at_all_ch @ mp_file_write_at_all_ch")
4011 : #else
4012 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
4013 : #endif
4014 0 : END SUBROUTINE mp_file_write_at_all_ch
4015 :
4016 : ! **************************************************************************************************
4017 : !> \brief (parallel) Blocking individual file read using explicit offsets
4018 : !> (serial) Unformatted stream read
4019 : !> \param[in] fh file handle (file storage unit)
4020 : !> \param[in] offset file offset (position)
4021 : !> \param[out] msg data to be read from the file
4022 : !> \param msglen ...
4023 : !> \par MPI-I/O mapping mpi_file_read_at
4024 : !> \par STREAM-I/O mapping READ
4025 : !> \param[in](optional) msglen number of elements of data
4026 : ! **************************************************************************************************
4027 0 : SUBROUTINE mp_file_read_at_chv(fh, offset, msg, msglen)
4028 : CHARACTER, CONTIGUOUS, INTENT(OUT) :: msg(:)
4029 : CLASS(mp_file_type), INTENT(IN) :: fh
4030 : INTEGER, INTENT(IN), OPTIONAL :: msglen
4031 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4032 :
4033 : #if defined(__parallel)
4034 : INTEGER :: ierr, msg_len
4035 : #endif
4036 :
4037 : #if defined(__parallel)
4038 0 : msg_len = SIZE(msg)
4039 0 : IF (PRESENT(msglen)) msg_len = msglen
4040 0 : CALL MPI_FILE_READ_AT(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4041 0 : IF (ierr .NE. 0) &
4042 0 : CPABORT("mpi_file_read_at_chv @ mp_file_read_at_chv")
4043 : #else
4044 : MARK_USED(msglen)
4045 : READ (UNIT=fh%handle, POS=offset + 1) msg
4046 : #endif
4047 0 : END SUBROUTINE mp_file_read_at_chv
4048 :
4049 : ! **************************************************************************************************
4050 : !> \brief wrapper to MPI_File_read_at
4051 : !> \param fh ...
4052 : !> \param offset ...
4053 : !> \param msg ...
4054 : ! **************************************************************************************************
4055 0 : SUBROUTINE mp_file_read_at_ch(fh, offset, msg)
4056 : CHARACTER(LEN=*), INTENT(OUT) :: msg
4057 : CLASS(mp_file_type), INTENT(IN) :: fh
4058 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4059 :
4060 : #if defined(__parallel)
4061 : INTEGER :: ierr
4062 : #endif
4063 :
4064 : #if defined(__parallel)
4065 0 : CALL MPI_FILE_READ_AT(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4066 0 : IF (ierr .NE. 0) &
4067 0 : CPABORT("mpi_file_read_at_ch @ mp_file_read_at_ch")
4068 : #else
4069 : READ (UNIT=fh%handle, POS=offset + 1) msg
4070 : #endif
4071 0 : END SUBROUTINE mp_file_read_at_ch
4072 :
4073 : ! **************************************************************************************************
4074 : !> \brief (parallel) Blocking collective file read using explicit offsets
4075 : !> (serial) Unformatted stream read
4076 : !> \param fh ...
4077 : !> \param offset ...
4078 : !> \param msg ...
4079 : !> \param msglen ...
4080 : !> \par MPI-I/O mapping mpi_file_read_at_all
4081 : !> \par STREAM-I/O mapping READ
4082 : ! **************************************************************************************************
4083 0 : SUBROUTINE mp_file_read_at_all_chv(fh, offset, msg, msglen)
4084 : CHARACTER, INTENT(OUT) :: msg(:)
4085 : CLASS(mp_file_type), INTENT(IN) :: fh
4086 : INTEGER, INTENT(IN), OPTIONAL :: msglen
4087 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4088 :
4089 : #if defined(__parallel)
4090 : INTEGER :: ierr, msg_len
4091 : #endif
4092 :
4093 : #if defined(__parallel)
4094 0 : msg_len = SIZE(msg)
4095 0 : IF (PRESENT(msglen)) msg_len = msglen
4096 0 : CALL MPI_FILE_READ_AT_ALL(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4097 0 : IF (ierr .NE. 0) &
4098 0 : CPABORT("mpi_file_read_at_all_chv @ mp_file_read_at_all_chv")
4099 : #else
4100 : MARK_USED(msglen)
4101 : READ (UNIT=fh%handle, POS=offset + 1) msg
4102 : #endif
4103 0 : END SUBROUTINE mp_file_read_at_all_chv
4104 :
4105 : ! **************************************************************************************************
4106 : !> \brief wrapper to MPI_File_read_at_all
4107 : !> \param fh ...
4108 : !> \param offset ...
4109 : !> \param msg ...
4110 : ! **************************************************************************************************
4111 0 : SUBROUTINE mp_file_read_at_all_ch(fh, offset, msg)
4112 : CHARACTER(LEN=*), INTENT(OUT) :: msg
4113 : CLASS(mp_file_type), INTENT(IN) :: fh
4114 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4115 :
4116 : #if defined(__parallel)
4117 : INTEGER :: ierr
4118 : #endif
4119 :
4120 : #if defined(__parallel)
4121 0 : CALL MPI_FILE_READ_AT_ALL(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4122 0 : IF (ierr .NE. 0) &
4123 0 : CPABORT("mpi_file_read_at_all_ch @ mp_file_read_at_all_ch")
4124 : #else
4125 : READ (UNIT=fh%handle, POS=offset + 1) msg
4126 : #endif
4127 0 : END SUBROUTINE mp_file_read_at_all_ch
4128 :
4129 : ! **************************************************************************************************
4130 : !> \brief Returns the size of a data type in bytes
4131 : !> \param[in] type_descriptor data type
4132 : !> \param[out] type_size size of the data type
4133 : !> \par MPI mapping
4134 : !> mpi_type_size
4135 : !>
4136 : ! **************************************************************************************************
4137 0 : SUBROUTINE mp_type_size(type_descriptor, type_size)
4138 : TYPE(mp_type_descriptor_type), INTENT(IN) :: type_descriptor
4139 : INTEGER, INTENT(OUT) :: type_size
4140 :
4141 : #if defined(__parallel)
4142 : INTEGER :: ierr
4143 :
4144 0 : ierr = 0
4145 0 : CALL MPI_TYPE_SIZE(type_descriptor%type_handle, type_size, ierr)
4146 0 : IF (ierr .NE. 0) &
4147 0 : CPABORT("mpi_type_size failed @ mp_type_size")
4148 : #else
4149 : SELECT CASE (type_descriptor%type_handle)
4150 : CASE (1)
4151 : type_size = real_4_size
4152 : CASE (3)
4153 : type_size = real_8_size
4154 : CASE (5)
4155 : type_size = 2*real_4_size
4156 : CASE (7)
4157 : type_size = 2*real_8_size
4158 : END SELECT
4159 : #endif
4160 0 : END SUBROUTINE mp_type_size
4161 :
4162 : ! **************************************************************************************************
4163 : !> \brief wrapper to MPI_Type_create_struct
4164 : !> \param subtypes ...
4165 : !> \param vector_descriptor ...
4166 : !> \param index_descriptor ...
4167 : !> \return ...
4168 : ! **************************************************************************************************
4169 0 : FUNCTION mp_type_make_struct(subtypes, &
4170 : vector_descriptor, index_descriptor) &
4171 : RESULT(type_descriptor)
4172 : TYPE(mp_type_descriptor_type), &
4173 : DIMENSION(:), INTENT(IN) :: subtypes
4174 : INTEGER, DIMENSION(2), INTENT(IN), &
4175 : OPTIONAL :: vector_descriptor
4176 : TYPE(mp_indexing_meta_type), &
4177 : INTENT(IN), OPTIONAL :: index_descriptor
4178 : TYPE(mp_type_descriptor_type) :: type_descriptor
4179 :
4180 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_make_struct'
4181 :
4182 : INTEGER :: i, n
4183 0 : INTEGER, ALLOCATABLE, DIMENSION(:) :: lengths
4184 : #if defined(__parallel)
4185 : INTEGER :: ierr
4186 : INTEGER(kind=mpi_address_kind), &
4187 0 : ALLOCATABLE, DIMENSION(:) :: displacements
4188 : #endif
4189 0 : MPI_DATA_TYPE, ALLOCATABLE, DIMENSION(:) :: old_types
4190 :
4191 0 : n = SIZE(subtypes)
4192 0 : type_descriptor%length = 1
4193 : #if defined(__parallel)
4194 0 : ierr = 0
4195 0 : CALL mpi_get_address(MPI_BOTTOM, type_descriptor%base, ierr)
4196 0 : IF (ierr /= 0) &
4197 0 : CPABORT("MPI_get_address @ "//routineN)
4198 0 : ALLOCATE (displacements(n))
4199 : #endif
4200 0 : type_descriptor%vector_descriptor(1:2) = 1
4201 0 : type_descriptor%has_indexing = .FALSE.
4202 0 : ALLOCATE (type_descriptor%subtype(n))
4203 0 : type_descriptor%subtype(:) = subtypes(:)
4204 0 : ALLOCATE (lengths(n), old_types(n))
4205 0 : DO i = 1, SIZE(subtypes)
4206 : #if defined(__parallel)
4207 0 : displacements(i) = subtypes(i)%base
4208 : #endif
4209 0 : old_types(i) = subtypes(i)%type_handle
4210 0 : lengths(i) = subtypes(i)%length
4211 : END DO
4212 : #if defined(__parallel)
4213 : CALL MPI_Type_create_struct(n, &
4214 : lengths, displacements, old_types, &
4215 0 : type_descriptor%type_handle, ierr)
4216 0 : IF (ierr /= 0) &
4217 0 : CPABORT("MPI_Type_create_struct @ "//routineN)
4218 0 : CALL MPI_Type_commit(type_descriptor%type_handle, ierr)
4219 0 : IF (ierr /= 0) &
4220 0 : CPABORT("MPI_Type_commit @ "//routineN)
4221 : #endif
4222 0 : IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
4223 0 : CPABORT(routineN//" Vectors and indices NYI")
4224 : END IF
4225 0 : END FUNCTION mp_type_make_struct
4226 :
4227 : ! **************************************************************************************************
4228 : !> \brief wrapper to MPI_Type_free
4229 : !> \param type_descriptor ...
4230 : ! **************************************************************************************************
4231 0 : RECURSIVE SUBROUTINE mp_type_free_m(type_descriptor)
4232 : TYPE(mp_type_descriptor_type), INTENT(inout) :: type_descriptor
4233 :
4234 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_free_m'
4235 :
4236 : INTEGER :: handle, i
4237 : #if defined(__parallel)
4238 : INTEGER :: ierr
4239 : #endif
4240 :
4241 0 : CALL mp_timeset(routineN, handle)
4242 :
4243 : ! If the subtype is associated, then it's a user-defined data type.
4244 :
4245 0 : IF (ASSOCIATED(type_descriptor%subtype)) THEN
4246 0 : DO i = 1, SIZE(type_descriptor%subtype)
4247 0 : CALL mp_type_free_m(type_descriptor%subtype(i))
4248 : END DO
4249 0 : DEALLOCATE (type_descriptor%subtype)
4250 : END IF
4251 : #if defined(__parallel)
4252 0 : ierr = 0
4253 0 : CALL MPI_Type_free(type_descriptor%type_handle, ierr)
4254 0 : IF (ierr /= 0) &
4255 0 : CPABORT("MPI_Type_free @ "//routineN)
4256 : #endif
4257 :
4258 0 : CALL mp_timestop(handle)
4259 :
4260 0 : END SUBROUTINE mp_type_free_m
4261 :
4262 : ! **************************************************************************************************
4263 : !> \brief ...
4264 : !> \param type_descriptors ...
4265 : ! **************************************************************************************************
4266 0 : SUBROUTINE mp_type_free_v(type_descriptors)
4267 : TYPE(mp_type_descriptor_type), DIMENSION(:), &
4268 : INTENT(inout) :: type_descriptors
4269 :
4270 : INTEGER :: i
4271 :
4272 0 : DO i = 1, SIZE(type_descriptors)
4273 0 : CALL mp_type_free(type_descriptors(i))
4274 : END DO
4275 :
4276 0 : END SUBROUTINE mp_type_free_v
4277 :
4278 : ! **************************************************************************************************
4279 : !> \brief Creates an indexed MPI type for arrays of strings using bytes for spacing (hindexed type)
4280 : !> \param count number of array blocks to read
4281 : !> \param lengths lengths of each array block
4282 : !> \param displs byte offsets for array blocks
4283 : !> \return container holding the created type
4284 : !> \author Nico Holmberg [05.2017]
4285 : ! **************************************************************************************************
4286 1888 : FUNCTION mp_file_type_hindexed_make_chv(count, lengths, displs) &
4287 : RESULT(type_descriptor)
4288 : INTEGER, INTENT(IN) :: count
4289 : INTEGER, DIMENSION(1:count), &
4290 : INTENT(IN), TARGET :: lengths
4291 : INTEGER(kind=file_offset), &
4292 : DIMENSION(1:count), INTENT(in), TARGET :: displs
4293 : TYPE(mp_file_descriptor_type) :: type_descriptor
4294 :
4295 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_hindexed_make_chv'
4296 :
4297 : INTEGER :: ierr, handle
4298 :
4299 1888 : ierr = 0
4300 1888 : CALL mp_timeset(routineN, handle)
4301 :
4302 : #if defined(__parallel)
4303 : CALL MPI_Type_create_hindexed(count, lengths, INT(displs, KIND=address_kind), MPI_CHARACTER, &
4304 405894 : type_descriptor%type_handle, ierr)
4305 1888 : IF (ierr /= 0) &
4306 0 : CPABORT("MPI_Type_create_hindexed @ "//routineN)
4307 1888 : CALL MPI_Type_commit(type_descriptor%type_handle, ierr)
4308 1888 : IF (ierr /= 0) &
4309 0 : CPABORT("MPI_Type_commit @ "//routineN)
4310 : #else
4311 : type_descriptor%type_handle = 68
4312 : #endif
4313 1888 : type_descriptor%length = count
4314 1888 : type_descriptor%has_indexing = .TRUE.
4315 1888 : type_descriptor%index_descriptor%index => lengths
4316 1888 : type_descriptor%index_descriptor%chunks => displs
4317 :
4318 1888 : CALL mp_timestop(handle)
4319 :
4320 1888 : END FUNCTION mp_file_type_hindexed_make_chv
4321 :
4322 : ! **************************************************************************************************
4323 : !> \brief Uses a previously created indexed MPI character type to tell the MPI processes
4324 : !> how to partition (set_view) an opened file
4325 : !> \param fh the file handle associated with the input file
4326 : !> \param offset global offset determining where the relevant data begins
4327 : !> \param type_descriptor container for the MPI type
4328 : !> \author Nico Holmberg [05.2017]
4329 : ! **************************************************************************************************
4330 1888 : SUBROUTINE mp_file_type_set_view_chv(fh, offset, type_descriptor)
4331 : TYPE(mp_file_type), INTENT(IN) :: fh
4332 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4333 : TYPE(mp_file_descriptor_type) :: type_descriptor
4334 :
4335 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_set_view_chv'
4336 :
4337 : INTEGER :: handle
4338 : #if defined(__parallel)
4339 : INTEGER :: ierr
4340 : #endif
4341 :
4342 1888 : CALL mp_timeset(routineN, handle)
4343 :
4344 : #if defined(__parallel)
4345 1888 : ierr = 0
4346 1888 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
4347 : CALL MPI_File_set_view(fh%handle, offset, MPI_CHARACTER, &
4348 1888 : type_descriptor%type_handle, "native", MPI_INFO_NULL, ierr)
4349 1888 : IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view")
4350 : #else
4351 : ! Uses absolute offsets stored in mp_file_descriptor_type
4352 : MARK_USED(fh)
4353 : MARK_USED(offset)
4354 : MARK_USED(type_descriptor)
4355 : #endif
4356 :
4357 1888 : CALL mp_timestop(handle)
4358 :
4359 1888 : END SUBROUTINE mp_file_type_set_view_chv
4360 :
4361 : ! **************************************************************************************************
4362 : !> \brief (parallel) Collective, blocking read of a character array from a file. File access pattern
4363 : ! determined by a previously set file view.
4364 : !> (serial) Unformatted stream read using explicit offsets
4365 : !> \param fh the file handle associated with the input file
4366 : !> \param msglen the message length of an individual vector component
4367 : !> \param ndims the number of vector components
4368 : !> \param buffer the buffer where the data is placed
4369 : !> \param type_descriptor container for the MPI type
4370 : !> \author Nico Holmberg [05.2017]
4371 : ! **************************************************************************************************
4372 38 : SUBROUTINE mp_file_read_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4373 : CLASS(mp_file_type), INTENT(IN) :: fh
4374 : INTEGER, INTENT(IN) :: msglen
4375 : INTEGER, INTENT(IN) :: ndims
4376 : CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(INOUT) :: buffer
4377 : TYPE(mp_file_descriptor_type), &
4378 : INTENT(IN), OPTIONAL :: type_descriptor
4379 :
4380 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_read_all_chv'
4381 :
4382 : INTEGER :: handle
4383 : #if defined(__parallel)
4384 : INTEGER:: ierr
4385 : #else
4386 : INTEGER :: i
4387 : #endif
4388 :
4389 38 : CALL mp_timeset(routineN, handle)
4390 :
4391 : #if defined(__parallel)
4392 38 : ierr = 0
4393 : MARK_USED(type_descriptor)
4394 38 : CALL MPI_File_read_all(fh%handle, buffer, ndims*msglen, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4395 38 : IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all")
4396 38 : CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4397 : #else
4398 : MARK_USED(msglen)
4399 : MARK_USED(ndims)
4400 : IF (.NOT. PRESENT(type_descriptor)) &
4401 : CALL cp_abort(__LOCATION__, &
4402 : "Container for mp_file_descriptor_type must be present in serial call.")
4403 : IF (.NOT. type_descriptor%has_indexing) &
4404 : CALL cp_abort(__LOCATION__, &
4405 : "File view has not been set in mp_file_descriptor_type.")
4406 : ! Use explicit offsets
4407 : DO i = 1, ndims
4408 : READ (fh%handle, POS=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4409 : END DO
4410 : #endif
4411 :
4412 38 : CALL mp_timestop(handle)
4413 :
4414 38 : END SUBROUTINE mp_file_read_all_chv
4415 :
4416 : ! **************************************************************************************************
4417 : !> \brief (parallel) Collective, blocking write of a character array to a file. File access pattern
4418 : ! determined by a previously set file view.
4419 : !> (serial) Unformatted stream write using explicit offsets
4420 : !> \param fh the file handle associated with the output file
4421 : !> \param msglen the message length of an individual vector component
4422 : !> \param ndims the number of vector components
4423 : !> \param buffer the buffer where the data is placed
4424 : !> \param type_descriptor container for the MPI type
4425 : !> \author Nico Holmberg [05.2017]
4426 : ! **************************************************************************************************
4427 1850 : SUBROUTINE mp_file_write_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4428 : CLASS(mp_file_type), INTENT(IN) :: fh
4429 : INTEGER, INTENT(IN) :: msglen
4430 : INTEGER, INTENT(IN) :: ndims
4431 : CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(IN) :: buffer
4432 : TYPE(mp_file_descriptor_type), &
4433 : INTENT(IN), OPTIONAL :: type_descriptor
4434 :
4435 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_write_all_chv'
4436 :
4437 : INTEGER :: handle
4438 : #if defined(__parallel)
4439 : INTEGER :: ierr
4440 : #else
4441 : INTEGER :: i
4442 : #endif
4443 :
4444 1850 : CALL mp_timeset(routineN, handle)
4445 :
4446 : #if defined(__parallel)
4447 : MARK_USED(type_descriptor)
4448 1850 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
4449 1850 : CALL MPI_File_write_all(fh%handle, buffer, ndims*msglen, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4450 1850 : IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all")
4451 1850 : CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4452 : #else
4453 : MARK_USED(msglen)
4454 : MARK_USED(ndims)
4455 : IF (.NOT. PRESENT(type_descriptor)) &
4456 : CALL cp_abort(__LOCATION__, &
4457 : "Container for mp_file_descriptor_type must be present in serial call.")
4458 : IF (.NOT. type_descriptor%has_indexing) &
4459 : CALL cp_abort(__LOCATION__, &
4460 : "File view has not been set in mp_file_descriptor_type.")
4461 : ! Use explicit offsets
4462 : DO i = 1, ndims
4463 : WRITE (fh%handle, POS=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4464 : END DO
4465 : #endif
4466 :
4467 1850 : CALL mp_timestop(handle)
4468 :
4469 1850 : END SUBROUTINE mp_file_write_all_chv
4470 :
4471 : ! **************************************************************************************************
4472 : !> \brief Releases the type used for MPI I/O
4473 : !> \param type_descriptor the container for the MPI type
4474 : !> \author Nico Holmberg [05.2017]
4475 : ! **************************************************************************************************
4476 1888 : SUBROUTINE mp_file_type_free(type_descriptor)
4477 : TYPE(mp_file_descriptor_type) :: type_descriptor
4478 :
4479 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_type_free'
4480 :
4481 : INTEGER :: handle
4482 : #if defined(__parallel)
4483 : INTEGER :: ierr
4484 : #endif
4485 :
4486 1888 : CALL mp_timeset(routineN, handle)
4487 :
4488 : #if defined(__parallel)
4489 1888 : CALL MPI_Type_free(type_descriptor%type_handle, ierr)
4490 1888 : IF (ierr /= 0) &
4491 0 : CPABORT("MPI_Type_free @ "//routineN)
4492 : #endif
4493 : #if defined(__parallel) && defined(__MPI_F08)
4494 : type_descriptor%type_handle%mpi_val = -1
4495 : #else
4496 1888 : type_descriptor%type_handle = -1
4497 : #endif
4498 1888 : type_descriptor%length = -1
4499 1888 : IF (type_descriptor%has_indexing) THEN
4500 1888 : NULLIFY (type_descriptor%index_descriptor%index)
4501 1888 : NULLIFY (type_descriptor%index_descriptor%chunks)
4502 1888 : type_descriptor%has_indexing = .FALSE.
4503 : END IF
4504 :
4505 1888 : CALL mp_timestop(handle)
4506 :
4507 1888 : END SUBROUTINE mp_file_type_free
4508 :
4509 : ! **************************************************************************************************
4510 : !> \brief (parallel) Utility routine to determine MPI file access mode based on variables
4511 : ! that in the serial case would get passed to the intrinsic OPEN
4512 : !> (serial) No action
4513 : !> \param mpi_io flag that determines if MPI I/O will actually be used
4514 : !> \param replace flag that indicates whether file needs to be deleted prior to opening it
4515 : !> \param amode the MPI I/O access mode
4516 : !> \param form formatted or unformatted data?
4517 : !> \param action the variable that determines what to do with file
4518 : !> \param status the status flag:
4519 : !> \param position should the file be appended or rewound
4520 : !> \author Nico Holmberg [11.2017]
4521 : ! **************************************************************************************************
4522 1850 : SUBROUTINE mp_file_get_amode(mpi_io, replace, amode, form, action, status, position)
4523 : LOGICAL, INTENT(INOUT) :: mpi_io, replace
4524 : INTEGER, INTENT(OUT) :: amode
4525 : CHARACTER(len=*), INTENT(IN) :: form, action, status, position
4526 :
4527 1850 : amode = -1
4528 : #if defined(__parallel)
4529 : ! Disable mpi io for unformatted access
4530 0 : SELECT CASE (form)
4531 : CASE ("FORMATTED")
4532 : ! Do nothing
4533 : CASE ("UNFORMATTED")
4534 0 : mpi_io = .FALSE.
4535 : CASE DEFAULT
4536 1850 : CPABORT("Unknown MPI file form requested.")
4537 : END SELECT
4538 : ! Determine file access mode (limited set of allowed choices)
4539 1850 : SELECT CASE (action)
4540 : CASE ("WRITE")
4541 1850 : amode = file_amode_wronly
4542 0 : SELECT CASE (status)
4543 : CASE ("NEW")
4544 : ! Try to open new file for writing, crash if file already exists
4545 0 : amode = amode + file_amode_create + file_amode_excl
4546 : CASE ("UNKNOWN")
4547 : ! Open file for writing and create it if file does not exist
4548 1526 : amode = amode + file_amode_create
4549 76 : SELECT CASE (position)
4550 : CASE ("APPEND")
4551 : ! Append existing file
4552 76 : amode = amode + file_amode_append
4553 : CASE ("REWIND", "ASIS")
4554 : ! Do nothing
4555 : CASE DEFAULT
4556 1526 : CPABORT("Unknown MPI file position requested.")
4557 : END SELECT
4558 : CASE ("OLD")
4559 324 : SELECT CASE (position)
4560 : CASE ("APPEND")
4561 : ! Append existing file
4562 0 : amode = amode + file_amode_append
4563 : CASE ("REWIND", "ASIS")
4564 : ! Do nothing
4565 : CASE DEFAULT
4566 0 : CPABORT("Unknown MPI file position requested.")
4567 : END SELECT
4568 : CASE ("REPLACE")
4569 : ! Overwrite existing file. Must delete existing file first
4570 324 : amode = amode + file_amode_create
4571 324 : replace = .TRUE.
4572 : CASE ("SCRATCH")
4573 : ! Disable
4574 0 : mpi_io = .FALSE.
4575 : CASE DEFAULT
4576 1850 : CPABORT("Unknown MPI file status requested.")
4577 : END SELECT
4578 : CASE ("READ")
4579 0 : amode = file_amode_rdonly
4580 0 : SELECT CASE (status)
4581 : CASE ("NEW")
4582 0 : CPABORT("Cannot read from 'NEW' file.")
4583 : CASE ("REPLACE")
4584 0 : CPABORT("Illegal status 'REPLACE' for read.")
4585 : CASE ("UNKNOWN", "OLD")
4586 : ! Do nothing
4587 : CASE ("SCRATCH")
4588 : ! Disable
4589 0 : mpi_io = .FALSE.
4590 : CASE DEFAULT
4591 0 : CPABORT("Unknown MPI file status requested.")
4592 : END SELECT
4593 : CASE ("READWRITE")
4594 0 : amode = file_amode_rdwr
4595 0 : SELECT CASE (status)
4596 : CASE ("NEW")
4597 : ! Try to open new file, crash if file already exists
4598 0 : amode = amode + file_amode_create + file_amode_excl
4599 : CASE ("UNKNOWN")
4600 : ! Open file and create it if file does not exist
4601 0 : amode = amode + file_amode_create
4602 0 : SELECT CASE (position)
4603 : CASE ("APPEND")
4604 : ! Append existing file
4605 0 : amode = amode + file_amode_append
4606 : CASE ("REWIND", "ASIS")
4607 : ! Do nothing
4608 : CASE DEFAULT
4609 0 : CPABORT("Unknown MPI file position requested.")
4610 : END SELECT
4611 : CASE ("OLD")
4612 0 : SELECT CASE (position)
4613 : CASE ("APPEND")
4614 : ! Append existing file
4615 0 : amode = amode + file_amode_append
4616 : CASE ("REWIND", "ASIS")
4617 : ! Do nothing
4618 : CASE DEFAULT
4619 0 : CPABORT("Unknown MPI file position requested.")
4620 : END SELECT
4621 : CASE ("REPLACE")
4622 : ! Overwrite existing file. Must delete existing file first
4623 0 : amode = amode + file_amode_create
4624 0 : replace = .TRUE.
4625 : CASE ("SCRATCH")
4626 : ! Disable
4627 0 : mpi_io = .FALSE.
4628 : CASE DEFAULT
4629 0 : CPABORT("Unknown MPI file status requested.")
4630 : END SELECT
4631 : CASE DEFAULT
4632 1850 : CPABORT("Unknown MPI file action requested.")
4633 : END SELECT
4634 : #else
4635 : MARK_USED(replace)
4636 : MARK_USED(form)
4637 : MARK_USED(position)
4638 : MARK_USED(status)
4639 : MARK_USED(action)
4640 : mpi_io = .FALSE.
4641 : #endif
4642 :
4643 1850 : END SUBROUTINE mp_file_get_amode
4644 :
4645 : ! **************************************************************************************************
4646 : !> \brief Non-blocking send of custom type
4647 : !> \param msgin ...
4648 : !> \param dest ...
4649 : !> \param comm ...
4650 : !> \param request ...
4651 : !> \param tag ...
4652 : ! **************************************************************************************************
4653 0 : SUBROUTINE mp_isend_custom(msgin, dest, comm, request, tag)
4654 : TYPE(mp_type_descriptor_type), INTENT(IN) :: msgin
4655 : INTEGER, INTENT(IN) :: dest
4656 : CLASS(mp_comm_type), INTENT(IN) :: comm
4657 : TYPE(mp_request_type), INTENT(out) :: request
4658 : INTEGER, INTENT(in), OPTIONAL :: tag
4659 :
4660 : INTEGER :: ierr, my_tag
4661 :
4662 0 : ierr = 0
4663 0 : my_tag = 0
4664 :
4665 : #if defined(__parallel)
4666 0 : IF (PRESENT(tag)) my_tag = tag
4667 :
4668 : CALL mpi_isend(MPI_BOTTOM, 1, msgin%type_handle, dest, my_tag, &
4669 0 : comm%handle, request%handle, ierr)
4670 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ mp_isend_custom")
4671 : #else
4672 : MARK_USED(msgin)
4673 : MARK_USED(dest)
4674 : MARK_USED(comm)
4675 : MARK_USED(tag)
4676 : ierr = 1
4677 : request = mp_request_null
4678 : CALL mp_stop(ierr, "mp_isend called in non parallel case")
4679 : #endif
4680 0 : END SUBROUTINE mp_isend_custom
4681 :
4682 : ! **************************************************************************************************
4683 : !> \brief Non-blocking receive of vector data
4684 : !> \param msgout ...
4685 : !> \param source ...
4686 : !> \param comm ...
4687 : !> \param request ...
4688 : !> \param tag ...
4689 : ! **************************************************************************************************
4690 0 : SUBROUTINE mp_irecv_custom(msgout, source, comm, request, tag)
4691 : TYPE(mp_type_descriptor_type), INTENT(INOUT) :: msgout
4692 : INTEGER, INTENT(IN) :: source
4693 : CLASS(mp_comm_type), INTENT(IN) :: comm
4694 : TYPE(mp_request_type), INTENT(out) :: request
4695 : INTEGER, INTENT(in), OPTIONAL :: tag
4696 :
4697 : INTEGER :: ierr, my_tag
4698 :
4699 0 : ierr = 0
4700 0 : my_tag = 0
4701 :
4702 : #if defined(__parallel)
4703 0 : IF (PRESENT(tag)) my_tag = tag
4704 :
4705 : CALL mpi_irecv(MPI_BOTTOM, 1, msgout%type_handle, source, my_tag, &
4706 0 : comm%handle, request%handle, ierr)
4707 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ mp_irecv_custom")
4708 : #else
4709 : MARK_USED(msgout)
4710 : MARK_USED(source)
4711 : MARK_USED(comm)
4712 : MARK_USED(tag)
4713 : ierr = 1
4714 : request = mp_request_null
4715 : CPABORT("mp_irecv called in non parallel case")
4716 : #endif
4717 0 : END SUBROUTINE mp_irecv_custom
4718 :
4719 : ! **************************************************************************************************
4720 : !> \brief Window free
4721 : !> \param win ...
4722 : ! **************************************************************************************************
4723 0 : SUBROUTINE mp_win_free(win)
4724 : CLASS(mp_win_type), INTENT(INOUT) :: win
4725 :
4726 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_free'
4727 :
4728 : INTEGER :: handle
4729 : #if defined(__parallel)
4730 : INTEGER :: ierr
4731 : #endif
4732 :
4733 0 : CALL mp_timeset(routineN, handle)
4734 :
4735 : #if defined(__parallel)
4736 0 : ierr = 0
4737 0 : CALL mpi_win_free(win%handle, ierr)
4738 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_free @ "//routineN)
4739 :
4740 0 : CALL add_perf(perf_id=21, count=1)
4741 : #else
4742 : win%handle = mp_win_null_handle
4743 : #endif
4744 0 : CALL mp_timestop(handle)
4745 0 : END SUBROUTINE mp_win_free
4746 :
4747 0 : SUBROUTINE mp_win_assign(win_new, win_old)
4748 : CLASS(mp_win_type), INTENT(OUT) :: win_new
4749 : CLASS(mp_win_type), INTENT(IN) :: win_old
4750 :
4751 0 : win_new%handle = win_old%handle
4752 :
4753 0 : END SUBROUTINE mp_win_assign
4754 :
4755 : ! **************************************************************************************************
4756 : !> \brief Window flush
4757 : !> \param win ...
4758 : ! **************************************************************************************************
4759 0 : SUBROUTINE mp_win_flush_all(win)
4760 : CLASS(mp_win_type), INTENT(IN) :: win
4761 :
4762 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_flush_all'
4763 :
4764 : INTEGER :: handle, ierr
4765 :
4766 0 : ierr = 0
4767 0 : CALL mp_timeset(routineN, handle)
4768 :
4769 : #if defined(__parallel)
4770 0 : CALL mpi_win_flush_all(win%handle, ierr)
4771 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_flush_all @ "//routineN)
4772 : #else
4773 : MARK_USED(win)
4774 : #endif
4775 0 : CALL mp_timestop(handle)
4776 0 : END SUBROUTINE mp_win_flush_all
4777 :
4778 : ! **************************************************************************************************
4779 : !> \brief Window lock
4780 : !> \param win ...
4781 : ! **************************************************************************************************
4782 0 : SUBROUTINE mp_win_lock_all(win)
4783 : CLASS(mp_win_type), INTENT(IN) :: win
4784 :
4785 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_lock_all'
4786 :
4787 : INTEGER :: handle, ierr
4788 :
4789 0 : ierr = 0
4790 0 : CALL mp_timeset(routineN, handle)
4791 :
4792 : #if defined(__parallel)
4793 :
4794 0 : CALL mpi_win_lock_all(MPI_MODE_NOCHECK, win%handle, ierr)
4795 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_lock_all @ "//routineN)
4796 :
4797 0 : CALL add_perf(perf_id=19, count=1)
4798 : #else
4799 : MARK_USED(win)
4800 : #endif
4801 0 : CALL mp_timestop(handle)
4802 0 : END SUBROUTINE mp_win_lock_all
4803 :
4804 : ! **************************************************************************************************
4805 : !> \brief Window lock
4806 : !> \param win ...
4807 : ! **************************************************************************************************
4808 0 : SUBROUTINE mp_win_unlock_all(win)
4809 : CLASS(mp_win_type), INTENT(IN) :: win
4810 :
4811 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_unlock_all'
4812 :
4813 : INTEGER :: handle, ierr
4814 :
4815 0 : ierr = 0
4816 0 : CALL mp_timeset(routineN, handle)
4817 :
4818 : #if defined(__parallel)
4819 :
4820 0 : CALL mpi_win_unlock_all(win%handle, ierr)
4821 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_unlock_all @ "//routineN)
4822 :
4823 0 : CALL add_perf(perf_id=19, count=1)
4824 : #else
4825 : MARK_USED(win)
4826 : #endif
4827 0 : CALL mp_timestop(handle)
4828 0 : END SUBROUTINE mp_win_unlock_all
4829 :
4830 : ! **************************************************************************************************
4831 : !> \brief Starts a timer region
4832 : !> \param routineN ...
4833 : !> \param handle ...
4834 : ! **************************************************************************************************
4835 149534841 : SUBROUTINE mp_timeset(routineN, handle)
4836 : CHARACTER(len=*), INTENT(IN) :: routineN
4837 : INTEGER, INTENT(OUT) :: handle
4838 :
4839 149534841 : IF (mp_collect_timings) &
4840 149336035 : CALL timeset(routineN, handle)
4841 149534841 : END SUBROUTINE mp_timeset
4842 :
4843 : ! **************************************************************************************************
4844 : !> \brief Ends a timer region
4845 : !> \param handle ...
4846 : ! **************************************************************************************************
4847 149534841 : SUBROUTINE mp_timestop(handle)
4848 : INTEGER, INTENT(IN) :: handle
4849 :
4850 149534841 : IF (mp_collect_timings) &
4851 149336035 : CALL timestop(handle)
4852 149534841 : END SUBROUTINE mp_timestop
4853 :
4854 : #:include 'message_passing.fypp'
4855 :
4856 69716854 : END MODULE message_passing
|
