Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Handles the MPI communication of the swarm framework.
10 : !> \author Ole Schuett
11 : ! **************************************************************************************************
12 : MODULE swarm_mpi
13 : USE cp_files, ONLY: close_file,&
14 : open_file
15 : USE cp_iter_types, ONLY: cp_iteration_info_create,&
16 : cp_iteration_info_release,&
17 : cp_iteration_info_type
18 : USE cp_log_handling, ONLY: cp_add_default_logger,&
19 : cp_get_default_logger,&
20 : cp_logger_create,&
21 : cp_logger_release,&
22 : cp_logger_type,&
23 : cp_rm_default_logger
24 : USE input_section_types, ONLY: section_vals_type,&
25 : section_vals_val_set
26 : USE kinds, ONLY: default_path_length,&
27 : default_string_length
28 : USE machine, ONLY: default_output_unit
29 : USE message_passing, ONLY: mp_any_source,&
30 : mp_comm_type,&
31 : mp_para_env_release,&
32 : mp_para_env_type
33 : USE swarm_message, ONLY: swarm_message_get,&
34 : swarm_message_mpi_bcast,&
35 : swarm_message_mpi_recv,&
36 : swarm_message_mpi_send,&
37 : swarm_message_type
38 : #include "../base/base_uses.f90"
39 :
40 : IMPLICIT NONE
41 : PRIVATE
42 :
43 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'swarm_mpi'
44 :
45 : PUBLIC :: swarm_mpi_type, swarm_mpi_init, swarm_mpi_finalize
46 : PUBLIC :: swarm_mpi_send_report, swarm_mpi_recv_report
47 : PUBLIC :: swarm_mpi_send_command, swarm_mpi_recv_command
48 :
49 : TYPE swarm_mpi_type
50 : TYPE(mp_para_env_type), POINTER :: world => Null()
51 : TYPE(mp_para_env_type), POINTER :: worker => Null()
52 : TYPE(mp_para_env_type), POINTER :: master => Null()
53 : INTEGER, DIMENSION(:), ALLOCATABLE :: wid2group
54 : CHARACTER(LEN=default_path_length) :: master_output_path = ""
55 : END TYPE swarm_mpi_type
56 :
57 : CONTAINS
58 :
59 : ! **************************************************************************************************
60 : !> \brief Initialize MPI communicators for a swarm run.
61 : !> \param swarm_mpi ...
62 : !> \param world_para_env ...
63 : !> \param root_section ...
64 : !> \param n_workers ...
65 : !> \param worker_id ...
66 : !> \param iw ...
67 : !> \author Ole Schuett
68 : ! **************************************************************************************************
69 6 : SUBROUTINE swarm_mpi_init(swarm_mpi, world_para_env, root_section, n_workers, worker_id, iw)
70 : TYPE(swarm_mpi_type) :: swarm_mpi
71 : TYPE(mp_para_env_type), POINTER :: world_para_env
72 : TYPE(section_vals_type), POINTER :: root_section
73 : INTEGER, INTENT(IN) :: n_workers
74 : INTEGER, INTENT(OUT) :: worker_id
75 : INTEGER, INTENT(IN) :: iw
76 :
77 : INTEGER :: n_groups_created, pe_per_worker, &
78 : subgroup_rank, subgroup_size
79 : TYPE(mp_comm_type) :: subgroup
80 : LOGICAL :: im_the_master
81 6 : INTEGER, DIMENSION(:), POINTER :: group_distribution_p
82 : INTEGER, DIMENSION(0:world_para_env%num_pe-2), &
83 12 : TARGET :: group_distribution
84 :
85 : ! ====== Setup of MPI-Groups ======
86 :
87 6 : worker_id = -1
88 6 : swarm_mpi%world => world_para_env
89 :
90 6 : IF (MOD(swarm_mpi%world%num_pe - 1, n_workers) /= 0) THEN
91 0 : CPABORT("number of processors-1 is not divisible by n_workers.")
92 : END IF
93 6 : IF (swarm_mpi%world%num_pe < n_workers + 1) THEN
94 0 : CPABORT("There are not enough processes for n_workers + 1. Aborting.")
95 : END IF
96 :
97 6 : pe_per_worker = (swarm_mpi%world%num_pe - 1)/n_workers
98 :
99 6 : IF (iw > 0) THEN
100 3 : WRITE (iw, '(A,45X,I8)') " SWARM| Number of mpi ranks", swarm_mpi%world%num_pe
101 3 : WRITE (iw, '(A,47X,I8)') " SWARM| Number of workers", n_workers
102 : END IF
103 :
104 : ! the last task becomes the master. Preseves node-alignment of other tasks.
105 6 : im_the_master = (swarm_mpi%world%mepos == swarm_mpi%world%num_pe - 1)
106 :
107 : ! First split split para_env into a master- and a workers-groups...
108 6 : IF (im_the_master) THEN
109 3 : ALLOCATE (swarm_mpi%master)
110 3 : CALL swarm_mpi%master%from_split(swarm_mpi%world, 1)
111 3 : subgroup_size = swarm_mpi%master%num_pe
112 3 : subgroup_rank = swarm_mpi%master%mepos
113 3 : IF (swarm_mpi%master%num_pe /= 1) CPABORT("mp_comm_split_direct failed (master)")
114 : ELSE
115 3 : CALL subgroup%from_split(swarm_mpi%world, 2)
116 3 : subgroup_size = subgroup%num_pe
117 3 : subgroup_rank = subgroup%mepos
118 3 : IF (subgroup_size /= swarm_mpi%world%num_pe - 1) CPABORT("mp_comm_split_direct failed (worker)")
119 : END IF
120 :
121 18 : ALLOCATE (swarm_mpi%wid2group(n_workers))
122 12 : swarm_mpi%wid2group = 0
123 :
124 6 : IF (.NOT. im_the_master) THEN
125 : ! ...then split workers-group into n_workers groups - one for each worker.
126 3 : group_distribution_p => group_distribution
127 3 : ALLOCATE (swarm_mpi%worker)
128 3 : CALL swarm_mpi%worker%from_split(subgroup, n_groups_created, group_distribution_p, n_subgroups=n_workers)
129 3 : worker_id = group_distribution(subgroup_rank) + 1 ! shall start by 1
130 3 : IF (n_groups_created /= n_workers) CPABORT("mp_comm_split failed.")
131 3 : CALL subgroup%free()
132 :
133 : !WRITE (*,*) "this is worker ", worker_id, swarm_mpi%worker%mepos, swarm_mpi%worker%num_pe
134 :
135 : ! collect world-ranks of each worker groups rank-0 node
136 3 : IF (swarm_mpi%worker%mepos == 0) THEN
137 3 : swarm_mpi%wid2group(worker_id) = swarm_mpi%world%mepos
138 : END IF
139 :
140 : END IF
141 :
142 6 : CALL swarm_mpi%world%sum(swarm_mpi%wid2group)
143 : !WRITE (*,*), "wid2group table: ",swarm_mpi%wid2group
144 :
145 6 : CALL logger_init_master(swarm_mpi)
146 6 : CALL logger_init_worker(swarm_mpi, root_section, worker_id)
147 6 : END SUBROUTINE swarm_mpi_init
148 :
149 : ! **************************************************************************************************
150 : !> \brief Helper routine for swarm_mpi_init, configures the master's logger.
151 : !> \param swarm_mpi ...
152 : !> \author Ole Schuett
153 : ! **************************************************************************************************
154 6 : SUBROUTINE logger_init_master(swarm_mpi)
155 : TYPE(swarm_mpi_type) :: swarm_mpi
156 :
157 : INTEGER :: output_unit
158 : TYPE(cp_logger_type), POINTER :: logger
159 :
160 : ! broadcast master_output_path to all ranks
161 :
162 6 : IF (swarm_mpi%world%is_source()) THEN
163 3 : logger => cp_get_default_logger()
164 3 : output_unit = logger%default_local_unit_nr
165 3 : swarm_mpi%master_output_path = output_unit2path(output_unit)
166 3 : IF (output_unit /= default_output_unit) THEN
167 0 : CLOSE (output_unit)
168 : END IF
169 : END IF
170 :
171 6 : CALL swarm_mpi%world%bcast(swarm_mpi%master_output_path)
172 :
173 6 : IF (ASSOCIATED(swarm_mpi%master)) THEN
174 3 : CALL error_add_new_logger(swarm_mpi%master, swarm_mpi%master_output_path)
175 : END IF
176 6 : END SUBROUTINE logger_init_master
177 :
178 : ! **************************************************************************************************
179 : !> \brief Helper routine for logger_init_master, inquires filename for given unit.
180 : !> \param output_unit ...
181 : !> \return ...
182 : !> \author Ole Schuett
183 : ! **************************************************************************************************
184 3 : FUNCTION output_unit2path(output_unit) RESULT(output_path)
185 : INTEGER, INTENT(IN) :: output_unit
186 : CHARACTER(LEN=default_path_length) :: output_path
187 :
188 3 : output_path = "__STD_OUT__"
189 3 : IF (output_unit /= default_output_unit) THEN
190 0 : INQUIRE (unit=output_unit, name=output_path)
191 : END IF
192 3 : END FUNCTION output_unit2path
193 :
194 : ! **************************************************************************************************
195 : !> \brief Helper routine for swarm_mpi_init, configures the workers's logger.
196 : !> \param swarm_mpi ...
197 : !> \param root_section ...
198 : !> \param worker_id ...
199 : !> \author Ole Schuett
200 : ! **************************************************************************************************
201 6 : SUBROUTINE logger_init_worker(swarm_mpi, root_section, worker_id)
202 : TYPE(swarm_mpi_type) :: swarm_mpi
203 : TYPE(section_vals_type), POINTER :: root_section
204 : INTEGER :: worker_id
205 :
206 : CHARACTER(LEN=default_path_length) :: output_path
207 : CHARACTER(len=default_string_length) :: new_project_name, project_name, &
208 : worker_name
209 : TYPE(cp_iteration_info_type), POINTER :: new_iter_info
210 : TYPE(cp_logger_type), POINTER :: old_logger
211 :
212 6 : NULLIFY (old_logger, new_iter_info)
213 6 : IF (ASSOCIATED(swarm_mpi%worker)) THEN
214 3 : old_logger => cp_get_default_logger()
215 3 : project_name = old_logger%iter_info%project_name
216 3 : IF (worker_id > 99999) THEN
217 0 : CPABORT("Did not expect so many workers.")
218 : END IF
219 3 : WRITE (worker_name, "(A,I5.5)") 'WORKER', worker_id
220 3 : IF (LEN_TRIM(project_name) + 1 + LEN_TRIM(worker_name) > default_string_length) THEN
221 0 : CPABORT("project name too long")
222 : END IF
223 3 : output_path = TRIM(project_name)//"-"//TRIM(worker_name)//".out"
224 3 : new_project_name = TRIM(project_name)//"-"//TRIM(worker_name)
225 3 : CALL section_vals_val_set(root_section, "GLOBAL%PROJECT_NAME", c_val=new_project_name)
226 3 : CALL cp_iteration_info_create(new_iter_info, new_project_name)
227 3 : CALL error_add_new_logger(swarm_mpi%worker, output_path, new_iter_info)
228 3 : CALL cp_iteration_info_release(new_iter_info)
229 : END IF
230 6 : END SUBROUTINE logger_init_worker
231 :
232 : ! **************************************************************************************************
233 : !> \brief Helper routine for logger_init_master and logger_init_worker
234 : !> \param para_env ...
235 : !> \param output_path ...
236 : !> \param iter_info ...
237 : !> \author Ole Schuett
238 : ! **************************************************************************************************
239 6 : SUBROUTINE error_add_new_logger(para_env, output_path, iter_info)
240 : TYPE(mp_para_env_type), POINTER :: para_env
241 : CHARACTER(LEN=default_path_length) :: output_path
242 : TYPE(cp_iteration_info_type), OPTIONAL, POINTER :: iter_info
243 :
244 : INTEGER :: output_unit
245 : TYPE(cp_logger_type), POINTER :: new_logger, old_logger
246 :
247 6 : NULLIFY (new_logger, old_logger)
248 6 : output_unit = -1
249 6 : IF (para_env%is_source()) THEN
250 : ! open output_unit according to output_path
251 6 : output_unit = default_output_unit
252 6 : IF (output_path /= "__STD_OUT__") THEN
253 : CALL open_file(file_name=output_path, file_status="UNKNOWN", &
254 3 : file_action="WRITE", file_position="APPEND", unit_number=output_unit)
255 : END IF
256 : END IF
257 :
258 6 : old_logger => cp_get_default_logger()
259 : CALL cp_logger_create(new_logger, para_env=para_env, &
260 : default_global_unit_nr=output_unit, close_global_unit_on_dealloc=.FALSE., &
261 6 : template_logger=old_logger, iter_info=iter_info)
262 :
263 6 : CALL cp_add_default_logger(new_logger)
264 6 : CALL cp_logger_release(new_logger)
265 6 : END SUBROUTINE error_add_new_logger
266 :
267 : ! **************************************************************************************************
268 : !> \brief Finalizes the MPI communicators of a swarm run.
269 : !> \param swarm_mpi ...
270 : !> \param root_section ...
271 : !> \author Ole Schuett
272 : ! **************************************************************************************************
273 6 : SUBROUTINE swarm_mpi_finalize(swarm_mpi, root_section)
274 : TYPE(swarm_mpi_type) :: swarm_mpi
275 : TYPE(section_vals_type), POINTER :: root_section
276 :
277 6 : CALL swarm_mpi%world%sync()
278 6 : CALL logger_finalize(swarm_mpi, root_section)
279 :
280 6 : IF (ASSOCIATED(swarm_mpi%worker)) CALL mp_para_env_release(swarm_mpi%worker)
281 6 : IF (ASSOCIATED(swarm_mpi%master)) CALL mp_para_env_release(swarm_mpi%master)
282 6 : NULLIFY (swarm_mpi%worker, swarm_mpi%master)
283 6 : DEALLOCATE (swarm_mpi%wid2group)
284 6 : END SUBROUTINE swarm_mpi_finalize
285 :
286 : ! **************************************************************************************************
287 : !> \brief Helper routine for swarm_mpi_finalize, restores the original loggers
288 : !> \param swarm_mpi ...
289 : !> \param root_section ...
290 : !> \author Ole Schuett
291 : ! **************************************************************************************************
292 6 : SUBROUTINE logger_finalize(swarm_mpi, root_section)
293 : TYPE(swarm_mpi_type) :: swarm_mpi
294 : TYPE(section_vals_type), POINTER :: root_section
295 :
296 : INTEGER :: output_unit
297 : TYPE(cp_logger_type), POINTER :: logger, old_logger
298 :
299 6 : NULLIFY (logger, old_logger)
300 6 : logger => cp_get_default_logger()
301 6 : output_unit = logger%default_local_unit_nr
302 6 : IF (output_unit > 0 .AND. output_unit /= default_output_unit) THEN
303 0 : CALL close_file(output_unit)
304 : END IF
305 :
306 6 : CALL cp_rm_default_logger() !pops the top-most logger
307 6 : old_logger => cp_get_default_logger()
308 :
309 : ! restore GLOBAL%PROJECT_NAME
310 : CALL section_vals_val_set(root_section, "GLOBAL%PROJECT_NAME", &
311 6 : c_val=old_logger%iter_info%project_name)
312 :
313 6 : CALL swarm_mpi%world%sync()
314 :
315 : ! do this only on master's rank 0
316 6 : IF (swarm_mpi%world%is_source() .AND. output_unit /= default_output_unit) THEN
317 0 : output_unit = old_logger%default_local_unit_nr
318 : OPEN (unit=output_unit, file=swarm_mpi%master_output_path, &
319 0 : status="UNKNOWN", action="WRITE", position="APPEND")
320 : END IF
321 6 : END SUBROUTINE logger_finalize
322 :
323 : ! **************************************************************************************************
324 : !> \brief Sends a report via MPI
325 : !> \param swarm_mpi ...
326 : !> \param report ...
327 : !> \author Ole Schuett
328 : ! **************************************************************************************************
329 31 : SUBROUTINE swarm_mpi_send_report(swarm_mpi, report)
330 : TYPE(swarm_mpi_type) :: swarm_mpi
331 : TYPE(swarm_message_type) :: report
332 :
333 : INTEGER :: dest, tag
334 :
335 : ! Only rank-0 of worker group sends its report
336 :
337 31 : IF (swarm_mpi%worker%is_source()) THEN
338 31 : dest = swarm_mpi%world%num_pe - 1
339 31 : tag = 42
340 31 : CALL swarm_message_mpi_send(report, group=swarm_mpi%world, dest=dest, tag=tag)
341 : END IF
342 :
343 31 : END SUBROUTINE swarm_mpi_send_report
344 :
345 : ! **************************************************************************************************
346 : !> \brief Receives a report via MPI
347 : !> \param swarm_mpi ...
348 : !> \param report ...
349 : !> \author Ole Schuett
350 : ! **************************************************************************************************
351 31 : SUBROUTINE swarm_mpi_recv_report(swarm_mpi, report)
352 : TYPE(swarm_mpi_type) :: swarm_mpi
353 : TYPE(swarm_message_type), INTENT(OUT) :: report
354 :
355 : INTEGER :: src, tag
356 :
357 31 : tag = 42
358 31 : src = mp_any_source
359 :
360 31 : CALL swarm_message_mpi_recv(report, group=swarm_mpi%world, src=src, tag=tag)
361 :
362 31 : END SUBROUTINE swarm_mpi_recv_report
363 :
364 : ! **************************************************************************************************
365 : !> \brief Sends a command via MPI
366 : !> \param swarm_mpi ...
367 : !> \param cmd ...
368 : !> \author Ole Schuett
369 : ! **************************************************************************************************
370 31 : SUBROUTINE swarm_mpi_send_command(swarm_mpi, cmd)
371 : TYPE(swarm_mpi_type) :: swarm_mpi
372 : TYPE(swarm_message_type) :: cmd
373 :
374 : INTEGER :: dest, tag, worker_id
375 :
376 31 : CALL swarm_message_get(cmd, "worker_id", worker_id)
377 31 : tag = 42
378 31 : dest = swarm_mpi%wid2group(worker_id)
379 :
380 31 : CALL swarm_message_mpi_send(cmd, group=swarm_mpi%world, dest=dest, tag=tag)
381 :
382 31 : END SUBROUTINE swarm_mpi_send_command
383 :
384 : ! **************************************************************************************************
385 : !> \brief Receives a command via MPI and broadcasts it within a worker.
386 : !> \param swarm_mpi ...
387 : !> \param cmd ...
388 : !> \author Ole Schuett
389 : ! **************************************************************************************************
390 31 : SUBROUTINE swarm_mpi_recv_command(swarm_mpi, cmd)
391 : TYPE(swarm_mpi_type) :: swarm_mpi
392 : TYPE(swarm_message_type), INTENT(OUT) :: cmd
393 :
394 : INTEGER :: src, tag
395 :
396 : ! This is a two step communication schema.
397 : ! First: The rank-0 of the worker groups receives the command from the master.
398 :
399 31 : IF (swarm_mpi%worker%is_source()) THEN
400 31 : src = swarm_mpi%world%num_pe - 1 !
401 31 : tag = 42
402 31 : CALL swarm_message_mpi_recv(cmd, group=swarm_mpi%world, src=src, tag=tag)
403 :
404 : END IF
405 :
406 : ! ! Second: The command is broadcasted within the worker group.
407 31 : CALL swarm_message_mpi_bcast(cmd, src=swarm_mpi%worker%source, group=swarm_mpi%worker)
408 :
409 31 : END SUBROUTINE swarm_mpi_recv_command
410 :
411 0 : END MODULE swarm_mpi
412 :
|
