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 Module containing a MiMiC communicator class
10 : !> \par History
11 : !> 05.2025 Created [AA]
12 : !> \author Andrej Antalik
13 : ! **************************************************************************************************
14 :
15 : MODULE mimic_communicator
16 :
17 : USE atomic_kind_list_types, ONLY: atomic_kind_list_type
18 : USE atomic_kind_types, ONLY: get_atomic_kind
19 : USE cp_control_types, ONLY: dft_control_type
20 : USE cp_result_methods, ONLY: get_results
21 : USE cp_result_types, ONLY: cp_result_type
22 : USE cp_subsys_types, ONLY: cp_subsys_get,&
23 : cp_subsys_type
24 : USE cp_units, ONLY: cp_unit_from_cp2k
25 : USE force_env_types, ONLY: force_env_get,&
26 : force_env_type
27 : USE kinds, ONLY: default_string_length,&
28 : dp
29 : USE mcl_api, ONLY: mcl_finalize,&
30 : mcl_get_api_version,&
31 : mcl_get_program_id,&
32 : mcl_receive,&
33 : mcl_send
34 : USE mcl_requests, ONLY: MCL_DATA,&
35 : MCL_LENGTH,&
36 : MCL_REQUEST,&
37 : MCL_RUNTYPE_QM_RS_GRID
38 : USE message_passing, ONLY: mp_para_env_type
39 : USE particle_list_types, ONLY: particle_list_type
40 : USE pw_env_types, ONLY: pw_env_get,&
41 : pw_env_type
42 : USE pw_pool_types, ONLY: pw_pool_type
43 : USE pw_types, ONLY: pw_r3d_rs_type
44 : USE qs_energy_types, ONLY: qs_energy_type
45 : USE qs_environment_types, ONLY: get_qs_env,&
46 : qs_environment_type,&
47 : set_qs_env
48 : USE qs_kind_types, ONLY: get_qs_kind,&
49 : qs_kind_type
50 : USE qs_ks_types, ONLY: qs_ks_env_type,&
51 : set_ks_env
52 : USE qs_rho_types, ONLY: qs_rho_get,&
53 : qs_rho_type
54 : #include "../base/base_uses.f90"
55 :
56 : IMPLICIT NONE
57 :
58 : PRIVATE
59 :
60 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mimic_communicator'
61 :
62 : ! **************************************************************************************************
63 : !> \brief MiMiC communicator class that facilitates MiMiC client-server data exchange
64 : !> \par History
65 : !> 05.2025 Created [AA]
66 : ! **************************************************************************************************
67 : TYPE, PUBLIC :: mimic_communicator_type
68 : PRIVATE
69 : !> communication
70 : TYPE(mp_para_env_type), POINTER :: para_env => Null()
71 : LOGICAL :: is_ionode = .FALSE.
72 : INTEGER :: mcl_server = 0, &
73 : client_id = -1
74 : !> CP2K data
75 : TYPE(force_env_type), POINTER :: force_env => Null()
76 : TYPE(pw_pool_type), POINTER :: pw_info => Null()
77 : TYPE(particle_list_type), POINTER :: atoms => Null()
78 : TYPE(atomic_kind_list_type), POINTER :: kinds => Null()
79 : TYPE(qs_energy_type), POINTER :: energy => Null()
80 : TYPE(pw_r3d_rs_type), POINTER :: potential => Null()
81 : TYPE(qs_rho_type), POINTER :: density => Null()
82 : INTEGER :: n_atoms = -1, &
83 : n_kinds = -1, &
84 : n_spins = -1
85 : INTEGER, DIMENSION(:, :), ALLOCATABLE :: npts_pproc
86 : !> beginning index of the local buffer in the global buffer diminished by 1
87 : INTEGER, DIMENSION(:), ALLOCATABLE :: lb_pproc
88 :
89 : CONTAINS
90 :
91 : PROCEDURE :: initialize
92 : PROCEDURE :: finalize
93 : PROCEDURE :: receive_request
94 : PROCEDURE :: send_value
95 : PROCEDURE :: send_client_info
96 : PROCEDURE :: send_atom_info
97 : PROCEDURE :: send_kind_info
98 : PROCEDURE :: send_box_info
99 : PROCEDURE :: send_result
100 : PROCEDURE :: send_grid_coordinates
101 : PROCEDURE :: send_density
102 : PROCEDURE :: send_forces
103 : PROCEDURE :: send_positions
104 : PROCEDURE :: receive_positions
105 : PROCEDURE :: receive_potential
106 :
107 : END TYPE mimic_communicator_type
108 :
109 : CONTAINS
110 :
111 : ! **************************************************************************************************
112 : !> \brief Initialize the communicator by loading data and saving pointers to relevant data
113 : !> \param this ...
114 : !> \param force_env ...
115 : !> \par History
116 : !> 05.2025 Created [AA]
117 : ! **************************************************************************************************
118 0 : SUBROUTINE initialize(this, force_env)
119 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
120 : TYPE(force_env_type), TARGET :: force_env
121 :
122 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':initialize'
123 :
124 : TYPE(cp_subsys_type), POINTER :: subsys
125 : TYPE(dft_control_type), POINTER :: dft_control
126 : TYPE(pw_env_type), POINTER :: pw_env
127 : TYPE(qs_environment_type), POINTER :: qs_env
128 : TYPE(qs_ks_env_type), POINTER :: ks_env
129 : INTEGER :: handle
130 :
131 0 : CALL timeset(routineN, handle)
132 :
133 0 : CALL mcl_get_program_id(this%client_id)
134 :
135 0 : NULLIFY (subsys, qs_env, ks_env, pw_env)
136 0 : this%force_env => force_env
137 0 : CALL force_env_get(this%force_env, subsys=subsys, para_env=this%para_env, qs_env=qs_env)
138 : CALL cp_subsys_get(subsys, natom=this%n_atoms, particles=this%atoms, &
139 0 : nkind=this%n_kinds, atomic_kinds=this%kinds)
140 : CALL get_qs_env(qs_env, energy=this%energy, vee=this%potential, rho=this%density, &
141 0 : dft_control=dft_control, ks_env=ks_env, pw_env=pw_env)
142 0 : CALL pw_env_get(pw_env, auxbas_pw_pool=this%pw_info)
143 :
144 0 : this%is_ionode = this%para_env%is_source()
145 :
146 0 : ALLOCATE (this%npts_pproc(3, 0:this%para_env%num_pe - 1), source=0)
147 0 : this%npts_pproc(:, this%para_env%mepos) = this%pw_info%pw_grid%npts_local
148 0 : CALL this%para_env%sum(this%npts_pproc)
149 :
150 0 : ALLOCATE (this%lb_pproc(0:this%para_env%num_pe - 1), source=0)
151 : this%lb_pproc(this%para_env%mepos) = this%pw_info%pw_grid%bounds_local(1, 1) &
152 0 : - this%pw_info%pw_grid%bounds(1, 1)
153 0 : CALL this%para_env%sum(this%lb_pproc)
154 :
155 0 : this%n_spins = dft_control%nspins
156 :
157 0 : CALL set_qs_env(qs_env, mimic=.TRUE.)
158 0 : dft_control%apply_external_potential = .TRUE.
159 0 : dft_control%eval_external_potential = .FALSE.
160 :
161 : ! allocate external electrostatic potential
162 0 : IF (ASSOCIATED(this%potential)) THEN
163 0 : CALL this%potential%release()
164 0 : DEALLOCATE (this%potential)
165 : END IF
166 0 : ALLOCATE (this%potential)
167 0 : CALL this%pw_info%create_pw(this%potential)
168 0 : CALL set_ks_env(ks_env, vee=this%potential)
169 :
170 0 : CALL timestop(handle)
171 :
172 0 : END SUBROUTINE initialize
173 :
174 : ! **************************************************************************************************
175 : !> \brief Finalize the simulation by deallocating memory
176 : !> \param this ...
177 : ! **************************************************************************************************
178 0 : SUBROUTINE finalize(this)
179 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
180 :
181 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':finalize'
182 :
183 : INTEGER :: handle
184 :
185 0 : CALL timeset(routineN, handle)
186 :
187 0 : CALL this%para_env%sync()
188 :
189 0 : CALL mcl_finalize()
190 :
191 0 : CALL timestop(handle)
192 :
193 0 : END SUBROUTINE finalize
194 :
195 : ! **************************************************************************************************
196 : !> \brief Receive a request from the server
197 : !> \param this ...
198 : !> \return ...
199 : ! **************************************************************************************************
200 0 : FUNCTION receive_request(this) RESULT(request)
201 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
202 : INTEGER :: request
203 :
204 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':receive_request'
205 :
206 : INTEGER :: handle
207 :
208 0 : CALL timeset(routineN, handle)
209 :
210 0 : request = -1
211 0 : CALL mcl_receive(request, 1, MCL_REQUEST, this%mcl_server)
212 0 : CALL this%para_env%bcast(request)
213 :
214 0 : CALL timestop(handle)
215 :
216 0 : END FUNCTION receive_request
217 :
218 : ! **************************************************************************************************
219 : !> \brief Send the specified single value data to the server
220 : !> \param this ...
221 : !> \param option word corresponding to available options
222 : !> \note Several values hardcoded for now
223 : ! **************************************************************************************************
224 0 : SUBROUTINE send_value(this, option)
225 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
226 : CHARACTER(LEN=*) :: option
227 :
228 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_value'
229 :
230 : REAL(dp) :: energy
231 : INTEGER :: handle
232 :
233 0 : CALL timeset(routineN, handle)
234 :
235 0 : SELECT CASE (option)
236 : CASE ("num_atoms", "num_atoms_in_fragments")
237 0 : CALL mcl_send(this%n_atoms, 1, MCL_DATA, this%mcl_server)
238 : CASE ("num_kinds")
239 0 : CALL mcl_send(this%n_kinds, 1, MCL_DATA, this%mcl_server)
240 : CASE ("num_fragments")
241 0 : CALL mcl_send(1, 1, MCL_DATA, this%mcl_server)
242 : CASE ("num_bonds") ! later use to communicate constraints
243 0 : CALL mcl_send(0, 1, MCL_DATA, this%mcl_server)
244 : CASE ("num_angles") ! later use to communicate constraints
245 0 : CALL mcl_send(0, 1, MCL_DATA, this%mcl_server)
246 : CASE ("energy")
247 0 : energy = this%energy%total - this%energy%ee
248 0 : CALL mcl_send(energy, 1, MCL_DATA, this%mcl_server)
249 : CASE DEFAULT
250 0 : CPABORT("The value chosen in "//routineN//" is not implemented.")
251 : END SELECT
252 :
253 0 : CALL timestop(handle)
254 :
255 0 : END SUBROUTINE send_value
256 :
257 : ! **************************************************************************************************
258 : !> \brief Send the specified information about the client to the server
259 : !> \param this ...
260 : !> \param option word corresponding to available options
261 : ! **************************************************************************************************
262 0 : SUBROUTINE send_client_info(this, option)
263 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
264 : CHARACTER(LEN=*) :: option
265 :
266 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_client_info'
267 :
268 : CHARACTER(LEN=*), PARAMETER :: client_name = "CP2K"
269 : INTEGER, DIMENSION(3) :: api_version
270 : INTEGER :: handle, length
271 :
272 0 : CALL timeset(routineN, handle)
273 :
274 0 : SELECT CASE (option)
275 : CASE ("id")
276 0 : CALL mcl_send(this%client_id, 1, MCL_DATA, this%mcl_server)
277 : CASE ("name")
278 0 : length = LEN(client_name)
279 0 : CALL mcl_send(length, 1, MCL_LENGTH, this%mcl_server)
280 0 : CALL mcl_send(client_name, length, MCL_DATA, this%mcl_server)
281 : CASE ("run_type")
282 0 : CALL mcl_send(MCL_RUNTYPE_QM_RS_GRID, 1, MCL_DATA, this%mcl_server)
283 : CASE ("api_version")
284 0 : CALL mcl_get_api_version(api_version)
285 0 : CALL mcl_send(api_version, 3, MCL_DATA, this%mcl_server)
286 : CASE DEFAULT
287 0 : CPABORT("The value chosen in "//routineN//" is not implemented.")
288 : END SELECT
289 :
290 0 : CALL timestop(handle)
291 :
292 0 : END SUBROUTINE send_client_info
293 :
294 : ! **************************************************************************************************
295 : !> \brief Send the specified data for each atom to the server
296 : !> \param this ...
297 : !> \param option word corresponding to available options
298 : ! **************************************************************************************************
299 0 : SUBROUTINE send_atom_info(this, option)
300 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
301 : CHARACTER(LEN=*) :: option
302 :
303 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_atom_info'
304 :
305 0 : INTEGER, DIMENSION(:), ALLOCATABLE :: buffer
306 : INTEGER :: handle, i
307 :
308 0 : CALL timeset(routineN, handle)
309 :
310 0 : ALLOCATE (buffer(this%n_atoms))
311 : SELECT CASE (option)
312 : CASE ("kinds")
313 0 : DO i = 1, this%n_atoms
314 0 : buffer(i) = this%atoms%els(i)%atomic_kind%kind_number
315 : END DO
316 : CASE ("ids")
317 0 : DO i = 1, this%n_atoms
318 0 : buffer(i) = this%atoms%els(i)%atom_index
319 : END DO
320 : CASE DEFAULT
321 0 : CPABORT("The value chosen in "//routineN//" is not implemented.")
322 : END SELECT
323 0 : CALL mcl_send(buffer, SIZE(buffer), MCL_DATA, this%mcl_server)
324 :
325 0 : CALL timestop(handle)
326 :
327 0 : END SUBROUTINE send_atom_info
328 :
329 : ! **************************************************************************************************
330 : !> \brief Send the specified data for each kind to the server
331 : !> \param this ...
332 : !> \param option word corresponding to available options
333 : ! **************************************************************************************************
334 0 : SUBROUTINE send_kind_info(this, option)
335 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
336 : CHARACTER(LEN=*) :: option
337 :
338 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_kind_info'
339 :
340 : TYPE(qs_environment_type), POINTER :: qs_env
341 0 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kinds
342 0 : REAL(dp), DIMENSION(:), ALLOCATABLE :: buffer_dp
343 0 : INTEGER, DIMENSION(:), ALLOCATABLE :: buffer_i
344 0 : CHARACTER(LEN=:), ALLOCATABLE :: labels
345 : CHARACTER(LEN=default_string_length) :: label
346 : INTEGER :: handle, length, i
347 :
348 0 : CALL timeset(routineN, handle)
349 :
350 0 : SELECT CASE (option)
351 : CASE ("labels")
352 0 : ALLOCATE (CHARACTER(30*this%n_kinds) :: labels)
353 0 : labels = ""
354 0 : DO i = 1, this%n_kinds
355 0 : CALL get_atomic_kind(this%kinds%els(i), name=label)
356 0 : labels = TRIM(labels)//TRIM(label)//","
357 : END DO
358 0 : length = LEN(TRIM(labels)) - 1
359 0 : CALL mcl_send(length, 1, MCL_LENGTH, this%mcl_server)
360 0 : CALL mcl_send(labels, length, MCL_DATA, this%mcl_server)
361 : CASE ("elements")
362 0 : ALLOCATE (buffer_i(this%n_kinds))
363 0 : DO i = 1, this%n_kinds
364 0 : CALL get_atomic_kind(this%kinds%els(i), z=buffer_i(i))
365 : END DO
366 0 : CALL mcl_send(buffer_i, SIZE(buffer_i), MCL_DATA, this%mcl_server)
367 : CASE ("masses")
368 0 : ALLOCATE (buffer_dp(this%n_kinds))
369 0 : DO i = 1, this%n_kinds
370 0 : buffer_dp(i) = cp_unit_from_cp2k(this%kinds%els(i)%mass, "AMU")
371 : END DO
372 0 : CALL mcl_send(buffer_dp, SIZE(buffer_dp), MCL_DATA, this%mcl_server)
373 : CASE ("nuclear_charges")
374 0 : NULLIFY (qs_env, qs_kinds)
375 0 : CALL force_env_get(this%force_env, qs_env=qs_env)
376 0 : CALL get_qs_env(qs_env, qs_kind_set=qs_kinds)
377 0 : ALLOCATE (buffer_dp(this%n_kinds))
378 0 : DO i = 1, this%n_kinds
379 0 : CALL get_qs_kind(qs_kinds(i), zeff=buffer_dp(i))
380 : END DO
381 0 : CALL mcl_send(buffer_dp, SIZE(buffer_dp), MCL_DATA, this%mcl_server)
382 : CASE DEFAULT
383 0 : CPABORT("The value chosen in "//routineN//" is not implemented.")
384 : END SELECT
385 :
386 0 : CALL timestop(handle)
387 :
388 0 : END SUBROUTINE send_kind_info
389 :
390 : ! **************************************************************************************************
391 : !> \brief Send the specified box information to the server
392 : !> \param this ...
393 : !> \param option word corresponding to available options
394 : ! **************************************************************************************************
395 0 : SUBROUTINE send_box_info(this, option)
396 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
397 : CHARACTER(LEN=*) :: option
398 :
399 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_box_info'
400 :
401 : INTEGER, DIMENSION(3) :: npts_glob
402 : REAL(dp), DIMENSION(3) :: origin
403 : REAL(dp), DIMENSION(9) :: box_vectors
404 : INTEGER :: handle, i
405 :
406 0 : CALL timeset(routineN, handle)
407 :
408 0 : npts_glob = this%pw_info%pw_grid%npts
409 :
410 0 : SELECT CASE (option)
411 : CASE ("num_gridpoints")
412 0 : CALL mcl_send(npts_glob, 3, MCL_DATA, this%mcl_server)
413 : CASE ("origin")
414 0 : origin = 0.0_dp
415 0 : CALL mcl_send(origin, 3, MCL_DATA, this%mcl_server)
416 : CASE ("box_vectors")
417 0 : box_vectors = [(this%pw_info%pw_grid%dh(:, i)*REAL(npts_glob(i), dp), i=1, 3)]
418 0 : CALL mcl_send(box_vectors, 9, MCL_DATA, this%mcl_server)
419 : CASE DEFAULT
420 0 : CPABORT("The value chosen in "//routineN//" is not implemented.")
421 : END SELECT
422 :
423 0 : CALL timestop(handle)
424 :
425 0 : END SUBROUTINE send_box_info
426 :
427 : ! **************************************************************************************************
428 : !> \brief Send the specified result to the server
429 : !> \param this ...
430 : !> \param option word corresponding to available options
431 : ! **************************************************************************************************
432 0 : SUBROUTINE send_result(this, option)
433 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
434 : CHARACTER(LEN=*) :: option
435 :
436 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_result'
437 :
438 : TYPE(qs_environment_type), POINTER :: qs_env
439 : TYPE(cp_result_type), POINTER :: results
440 : CHARACTER(LEN=default_string_length) :: description
441 0 : REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: buffer
442 : INTEGER :: handle
443 :
444 0 : CALL timeset(routineN, handle)
445 :
446 0 : NULLIFY (qs_env, results)
447 0 : CALL force_env_get(this%force_env, qs_env=qs_env)
448 0 : CALL get_qs_env(qs_env, results=results)
449 :
450 0 : SELECT CASE (option)
451 : CASE ("hirshfeld_charges")
452 0 : description = "[HIRSHFELD-CHARGES]"
453 0 : ALLOCATE (buffer(this%n_atoms), source=0.0_dp)
454 0 : CALL get_results(results, description, buffer)
455 0 : CALL mcl_send(buffer, SIZE(buffer), MCL_DATA, this%mcl_server)
456 : CASE DEFAULT
457 0 : CPABORT("The value chosen in "//routineN//" is not implemented.")
458 : END SELECT
459 :
460 0 : CALL timestop(handle)
461 :
462 0 : END SUBROUTINE send_result
463 :
464 : ! **************************************************************************************************
465 : !> \brief Send grid point coordinates to the server
466 : !> \param this ...
467 : ! **************************************************************************************************
468 0 : SUBROUTINE send_grid_coordinates(this)
469 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
470 :
471 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_grid_coordinates'
472 :
473 : INTEGER, DIMENSION(3) :: npts_glob, npts, lb_glob, lb, ub
474 : REAL(dp), DIMENSION(3) :: origin
475 : REAL(dp), DIMENSION(3, 3) :: box_vectors
476 0 : REAL(dp), DIMENSION(:, :), ALLOCATABLE :: coords
477 : INTEGER :: handle, i, j, k, offset
478 :
479 0 : CALL timeset(routineN, handle)
480 :
481 : origin = 0.0_dp
482 0 : box_vectors = this%pw_info%pw_grid%dh
483 : ! number of grid points
484 0 : npts_glob = this%pw_info%pw_grid%npts
485 0 : npts = this%pw_info%pw_grid%npts_local
486 : ! bounds
487 0 : lb_glob = this%pw_info%pw_grid%bounds(1, :)
488 0 : lb = this%pw_info%pw_grid%bounds_local(1, :)
489 0 : ub = this%pw_info%pw_grid%bounds_local(2, :)
490 :
491 0 : ALLOCATE (coords(3, PRODUCT(npts_glob)), source=0.0_dp)
492 0 : offset = (lb(1) - lb_glob(1))*PRODUCT(npts(2:))
493 0 : DO k = lb(3), ub(3)
494 0 : DO j = lb(2), ub(2)
495 0 : DO i = lb(1), ub(1)
496 0 : offset = offset + 1
497 : coords(:, offset) = origin + box_vectors(:, 1)*REAL(i - lb_glob(1), dp) &
498 : + box_vectors(:, 2)*REAL(j - lb_glob(2), dp) &
499 0 : + box_vectors(:, 3)*REAL(k - lb_glob(3), dp)
500 : END DO
501 : END DO
502 : END DO
503 0 : CALL this%para_env%sum(coords)
504 :
505 0 : CALL mcl_send(coords, SIZE(coords), MCL_DATA, this%mcl_server)
506 :
507 0 : CALL timestop(handle)
508 :
509 0 : END SUBROUTINE send_grid_coordinates
510 :
511 : ! **************************************************************************************************
512 : !> \brief Receive external potential from the server
513 : !> \param this ...
514 : ! **************************************************************************************************
515 0 : SUBROUTINE receive_potential(this)
516 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
517 :
518 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':receive_potential'
519 :
520 : INTEGER, DIMENSION(3) :: npts, lb, ub
521 0 : REAL(dp), DIMENSION(:), ALLOCATABLE, TARGET :: buffer
522 : REAL(dp), DIMENSION(:), ALLOCATABLE :: buffer_loc
523 0 : REAL(dp), DIMENSION(:), POINTER :: buffer_p
524 : INTEGER :: i, j, k, i_proc, offset
525 : INTEGER :: handle, length, tag
526 :
527 0 : CALL timeset(routineN, handle)
528 :
529 0 : NULLIFY (buffer_p)
530 0 : npts = this%pw_info%pw_grid%npts_local
531 0 : lb = this%pw_info%pw_grid%bounds_local(1, :)
532 0 : ub = this%pw_info%pw_grid%bounds_local(2, :)
533 0 : ALLOCATE (buffer_loc(PRODUCT(npts)))
534 :
535 0 : tag = 1
536 :
537 0 : IF (this%is_ionode) THEN
538 0 : ALLOCATE (buffer(PRODUCT(this%pw_info%pw_grid%npts)))
539 : ! receive potential at the IO process
540 0 : CALL mcl_receive(buffer, SIZE(buffer), MCL_DATA, this%mcl_server)
541 : ! distribute across processes
542 0 : DO i_proc = 0, this%para_env%num_pe - 1
543 0 : length = PRODUCT(this%npts_pproc(:, i_proc))
544 0 : offset = this%lb_pproc(i_proc)*PRODUCT(npts(2:)) + 1
545 0 : buffer_p => buffer(offset:offset + length - 1)
546 0 : IF (i_proc /= this%para_env%source) THEN
547 0 : i = i_proc
548 0 : CALL this%para_env%send(buffer_p, i, tag)
549 : ELSE
550 0 : buffer_loc(:) = buffer_p
551 : END IF
552 : END DO
553 : ELSE
554 0 : CALL this%para_env%recv(buffer_loc, this%para_env%source, tag)
555 : END IF
556 :
557 : ! set the potential
558 0 : offset = 0
559 0 : DO k = lb(3), ub(3)
560 0 : DO j = lb(2), ub(2)
561 0 : DO i = lb(1), ub(1)
562 0 : offset = offset + 1
563 0 : this%potential%array(i, j, k) = -buffer_loc(offset)
564 : END DO
565 : END DO
566 : END DO
567 :
568 0 : CALL timestop(handle)
569 :
570 0 : END SUBROUTINE receive_potential
571 :
572 : ! **************************************************************************************************
573 : !> \brief Send electron density to the server
574 : !> \param this ...
575 : ! **************************************************************************************************
576 0 : SUBROUTINE send_density(this)
577 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
578 :
579 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_density'
580 :
581 : INTEGER, DIMENSION(3) :: npts, lb, ub
582 0 : TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho
583 0 : REAL(dp), DIMENSION(:), ALLOCATABLE, TARGET :: buffer
584 : REAL(dp), DIMENSION(:), ALLOCATABLE :: buffer_loc
585 0 : REAL(dp), DIMENSION(:), POINTER :: buffer_p
586 : INTEGER :: i_spin, i_proc, i, j, k, offset
587 : INTEGER :: handle, length, tag
588 :
589 0 : CALL timeset(routineN, handle)
590 :
591 0 : NULLIFY (rho, buffer_p)
592 0 : CALL qs_rho_get(this%density, rho_r=rho)
593 0 : npts = this%pw_info%pw_grid%npts_local
594 0 : lb = this%pw_info%pw_grid%bounds_local(1, :)
595 0 : ub = this%pw_info%pw_grid%bounds_local(2, :)
596 0 : ALLOCATE (buffer_loc(PRODUCT(npts)))
597 :
598 : ! gather density values
599 0 : buffer_loc = 0.0_dp
600 0 : DO i_spin = 1, this%n_spins
601 0 : offset = 0
602 0 : DO k = lb(3), ub(3)
603 0 : DO j = lb(2), ub(2)
604 0 : DO i = lb(1), ub(1)
605 0 : offset = offset + 1
606 0 : buffer_loc(offset) = buffer_loc(offset) + rho(i_spin)%array(i, j, k)
607 : END DO
608 : END DO
609 : END DO
610 : END DO
611 :
612 0 : tag = 1
613 :
614 0 : IF (.NOT. this%is_ionode) THEN
615 0 : CALL this%para_env%send(buffer_loc, this%para_env%source, tag)
616 : ELSE
617 0 : ALLOCATE (buffer(PRODUCT(this%pw_info%pw_grid%npts)))
618 : ! collect from the processes at the IO process
619 0 : DO i_proc = 0, this%para_env%num_pe - 1
620 0 : length = PRODUCT(this%npts_pproc(:, i_proc))
621 0 : offset = this%lb_pproc(i_proc)*PRODUCT(npts(2:)) + 1
622 0 : buffer_p => buffer(offset:offset + length - 1)
623 0 : IF (i_proc /= this%para_env%source) THEN
624 0 : i = i_proc
625 0 : CALL this%para_env%recv(buffer_p, i, tag)
626 : ELSE
627 0 : buffer_p = buffer_loc
628 : END IF
629 : END DO
630 : ! send the density
631 0 : CALL mcl_send(buffer, SIZE(buffer), MCL_DATA, this%mcl_server)
632 : END IF
633 :
634 0 : CALL timestop(handle)
635 :
636 0 : END SUBROUTINE send_density
637 :
638 : ! **************************************************************************************************
639 : !> \brief Send positions of all atoms to the server
640 : !> \param this ...
641 : ! **************************************************************************************************
642 0 : SUBROUTINE send_positions(this)
643 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
644 :
645 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_positions'
646 :
647 0 : REAL(dp), DIMENSION(:, :), ALLOCATABLE :: buffer
648 : INTEGER :: handle, i_atom
649 :
650 0 : CALL timeset(routineN, handle)
651 :
652 0 : ALLOCATE (buffer(3, this%n_atoms))
653 0 : DO i_atom = 1, this%n_atoms
654 0 : buffer(:, i_atom) = this%atoms%els(i_atom)%r
655 : END DO
656 0 : CALL mcl_send(buffer, SIZE(buffer), MCL_DATA, this%mcl_server)
657 :
658 0 : CALL timestop(handle)
659 :
660 0 : END SUBROUTINE send_positions
661 :
662 : ! **************************************************************************************************
663 : !> \brief Receive positions of all atoms from the server
664 : !> \param this ...
665 : ! **************************************************************************************************
666 0 : SUBROUTINE receive_positions(this)
667 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
668 :
669 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':receive_positions'
670 :
671 0 : REAL(dp), DIMENSION(:, :), ALLOCATABLE :: buffer
672 : INTEGER :: handle, i_atom
673 :
674 0 : CALL timeset(routineN, handle)
675 :
676 0 : ALLOCATE (buffer(3, this%n_atoms))
677 0 : CALL mcl_receive(buffer, SIZE(buffer), MCL_DATA, this%mcl_server)
678 0 : CALL this%para_env%bcast(buffer)
679 0 : DO i_atom = 1, this%n_atoms
680 0 : this%atoms%els(i_atom)%r = buffer(:, i_atom)
681 : END DO
682 :
683 0 : CALL timestop(handle)
684 :
685 0 : END SUBROUTINE receive_positions
686 :
687 : ! **************************************************************************************************
688 : !> \brief Send QM forces of all atoms to the server
689 : !> \param this ...
690 : ! **************************************************************************************************
691 0 : SUBROUTINE send_forces(this)
692 : CLASS(mimic_communicator_type), INTENT(INOUT) :: this
693 :
694 : CHARACTER(LEN=*), PARAMETER :: routineN = moduleN//':send_forces'
695 :
696 0 : REAL(dp), DIMENSION(:, :), ALLOCATABLE :: buffer
697 : INTEGER :: handle, i_atom
698 :
699 0 : CALL timeset(routineN, handle)
700 :
701 0 : ALLOCATE (buffer(3, this%n_atoms))
702 0 : DO i_atom = 1, this%n_atoms
703 0 : buffer(:, i_atom) = this%atoms%els(i_atom)%f
704 : END DO
705 0 : CALL mcl_send(buffer, SIZE(buffer), MCL_DATA, this%mcl_server)
706 :
707 0 : CALL timestop(handle)
708 :
709 0 : END SUBROUTINE send_forces
710 :
711 0 : END MODULE mimic_communicator
|
