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 Routines for data exchange between MPI processes
10 : !> \par History
11 : !> 04.2008 created [Manuel Guidon]
12 : !> \author Manuel Guidon
13 : ! **************************************************************************************************
14 : MODULE hfx_communication
15 : USE atomic_kind_types, ONLY: atomic_kind_type,&
16 : get_atomic_kind_set
17 : USE cp_control_types, ONLY: dft_control_type
18 : USE cp_dbcsr_api, ONLY: dbcsr_get_block_p,&
19 : dbcsr_iterator_blocks_left,&
20 : dbcsr_iterator_next_block,&
21 : dbcsr_iterator_start,&
22 : dbcsr_iterator_stop,&
23 : dbcsr_iterator_type,&
24 : dbcsr_p_type,&
25 : dbcsr_type
26 : USE hfx_types, ONLY: hfx_2D_map,&
27 : hfx_basis_type,&
28 : hfx_type
29 : USE kinds, ONLY: dp,&
30 : int_8
31 : USE message_passing, ONLY: mp_para_env_type,&
32 : mp_request_type,&
33 : mp_waitall
34 : USE particle_types, ONLY: particle_type
35 : USE qs_environment_types, ONLY: get_qs_env,&
36 : qs_environment_type
37 : #include "./base/base_uses.f90"
38 :
39 : IMPLICIT NONE
40 : PRIVATE
41 :
42 : PUBLIC :: get_full_density, &
43 : distribute_ks_matrix, &
44 : scale_and_add_fock_to_ks_matrix, &
45 : get_atomic_block_maps
46 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'hfx_communication'
47 :
48 : !***
49 :
50 : CONTAINS
51 :
52 : ! **************************************************************************************************
53 : !> \brief - Collects full density matrix from all CPUs
54 : !> \param para_env ...
55 : !> \param full_density The full Density matrix
56 : !> \param rho Distributed density
57 : !> \param number_of_p_entries Maximal buffer size
58 : !> \param block_offset ...
59 : !> \param kind_of ...
60 : !> \param basis_parameter ...
61 : !> \param get_max_vals_spin ...
62 : !> \param rho_beta ...
63 : !> \param antisymmetric ...
64 : !> \par History
65 : !> 11.2007 created [Manuel Guidon]
66 : !> \author Manuel Guidon
67 : !> \note
68 : !> - Communication with left/right node only
69 : !> added a mpi_sync before and after the ring of isendrecv. This *speed up* the
70 : !> communication, and might protect against idle neighbors flooding a busy node
71 : !> with messages [Joost]
72 : ! **************************************************************************************************
73 41861 : SUBROUTINE get_full_density(para_env, full_density, rho, number_of_p_entries, &
74 : block_offset, kind_of, basis_parameter, &
75 : get_max_vals_spin, rho_beta, antisymmetric)
76 :
77 : TYPE(mp_para_env_type), POINTER :: para_env
78 : REAL(dp), DIMENSION(:) :: full_density
79 : TYPE(dbcsr_type), POINTER :: rho
80 : INTEGER, INTENT(IN) :: number_of_p_entries
81 : INTEGER, DIMENSION(:), POINTER :: block_offset
82 : INTEGER :: kind_of(*)
83 : TYPE(hfx_basis_type), DIMENSION(:), POINTER :: basis_parameter
84 : LOGICAL, INTENT(IN) :: get_max_vals_spin
85 : TYPE(dbcsr_type), OPTIONAL, POINTER :: rho_beta
86 : LOGICAL, INTENT(IN) :: antisymmetric
87 :
88 : INTEGER :: block_size, data_from, dest, i, iatom, icpu, ikind, iset, jatom, jkind, jset, &
89 : mepos, ncpu, nseta, nsetb, pa, pa1, pb, pb1, source, source_cpu
90 41861 : INTEGER, DIMENSION(:), POINTER :: nsgfa, nsgfb
91 : LOGICAL :: found
92 : REAL(dp) :: symmfac
93 41861 : REAL(dp), DIMENSION(:), POINTER :: recbuffer, sendbuffer, swapbuffer
94 41861 : REAL(dp), DIMENSION(:, :), POINTER :: sparse_block, sparse_block_beta
95 : TYPE(dbcsr_iterator_type) :: iter
96 125583 : TYPE(mp_request_type), DIMENSION(2) :: req
97 :
98 12459580 : full_density = 0.0_dp
99 125583 : ALLOCATE (sendbuffer(number_of_p_entries))
100 83722 : ALLOCATE (recbuffer(number_of_p_entries))
101 :
102 41861 : i = 1
103 41861 : CALL dbcsr_iterator_start(iter, rho, shared=.FALSE.)
104 172348 : DO WHILE (dbcsr_iterator_blocks_left(iter))
105 130487 : CALL dbcsr_iterator_next_block(iter, iatom, jatom, sparse_block)
106 : ! the resulting vector will be only the upper triangle.
107 : ! in case of antisymmetry take care to change signs if a lower block gets copied
108 130487 : symmfac = 1.0_dp
109 130487 : IF (antisymmetric .AND. iatom > jatom) symmfac = -1.0_dp
110 130487 : ikind = kind_of(iatom)
111 130487 : nseta = basis_parameter(ikind)%nset
112 130487 : nsgfa => basis_parameter(ikind)%nsgf
113 130487 : jkind = kind_of(jatom)
114 130487 : nsetb = basis_parameter(jkind)%nset
115 130487 : nsgfb => basis_parameter(jkind)%nsgf
116 172348 : IF (get_max_vals_spin) THEN
117 : CALL dbcsr_get_block_p(rho_beta, &
118 0 : row=iatom, col=jatom, BLOCK=sparse_block_beta, found=found)
119 0 : pa = 0
120 0 : DO iset = 1, nseta
121 : pb = 0
122 0 : DO jset = 1, nsetb
123 0 : DO pa1 = pa + 1, pa + nsgfa(iset)
124 0 : DO pb1 = pb + 1, pb + nsgfb(jset)
125 0 : sendbuffer(i) = MAX(ABS(sparse_block(pa1, pb1)), ABS(sparse_block_beta(pa1, pb1)))
126 0 : i = i + 1
127 : END DO
128 : END DO
129 0 : pb = pb + nsgfb(jset)
130 : END DO
131 0 : pa = pa + nsgfa(iset)
132 : END DO
133 : ELSE
134 : pa = 0
135 511244 : DO iset = 1, nseta
136 : pb = 0
137 1584245 : DO jset = 1, nsetb
138 3964803 : DO pa1 = pa + 1, pa + nsgfa(iset)
139 10164463 : DO pb1 = pb + 1, pb + nsgfb(jset)
140 6199660 : sendbuffer(i) = sparse_block(pa1, pb1)*symmfac
141 8960975 : i = i + 1
142 : END DO
143 : END DO
144 1584245 : pb = pb + nsgfb(jset)
145 : END DO
146 511244 : pa = pa + nsgfa(iset)
147 : END DO
148 : END IF
149 : END DO
150 41861 : CALL dbcsr_iterator_stop(iter)
151 :
152 : ! sync before/after a ring of isendrecv
153 41861 : CALL para_env%sync()
154 41861 : ncpu = para_env%num_pe
155 41861 : mepos = para_env%mepos
156 41861 : dest = MODULO(mepos + 1, ncpu)
157 41861 : source = MODULO(mepos - 1, ncpu)
158 125500 : DO icpu = 0, ncpu - 1
159 83639 : IF (icpu .NE. ncpu - 1) THEN
160 : CALL para_env%isendrecv(sendbuffer, dest, recbuffer, source, &
161 41778 : req(1), req(2), 13)
162 : END IF
163 83639 : data_from = MODULO(mepos - icpu, ncpu)
164 83639 : source_cpu = MODULO(data_from, ncpu) + 1
165 83639 : block_size = block_offset(source_cpu + 1) - block_offset(source_cpu)
166 12459497 : full_density(block_offset(source_cpu):block_offset(source_cpu) + block_size - 1) = sendbuffer(1:block_size)
167 :
168 83639 : IF (icpu .NE. ncpu - 1) THEN
169 41778 : CALL mp_waitall(req)
170 : END IF
171 83639 : swapbuffer => sendbuffer
172 83639 : sendbuffer => recbuffer
173 125500 : recbuffer => swapbuffer
174 : END DO
175 41861 : DEALLOCATE (sendbuffer, recbuffer)
176 : ! sync before/after a ring of isendrecv
177 41861 : CALL para_env%sync()
178 :
179 83722 : END SUBROUTINE get_full_density
180 :
181 : ! **************************************************************************************************
182 : !> \brief - Distributes the local full Kohn-Sham matrix to all CPUS
183 : !> \param para_env ...
184 : !> \param full_ks The full Kohn-Sham matrix
185 : !> \param ks_matrix Distributed Kohn-Sham matrix
186 : !> \param number_of_p_entries Maximal buffer size
187 : !> \param block_offset ...
188 : !> \param kind_of ...
189 : !> \param basis_parameter ...
190 : !> \param off_diag_fac ...
191 : !> \param diag_fac ...
192 : !> \par History
193 : !> 11.2007 created [Manuel Guidon]
194 : !> \author Manuel Guidon
195 : !> \note
196 : !> - Communication with left/right node only
197 : ! **************************************************************************************************
198 39095 : SUBROUTINE distribute_ks_matrix(para_env, full_ks, ks_matrix, number_of_p_entries, &
199 : block_offset, kind_of, basis_parameter, &
200 : off_diag_fac, diag_fac)
201 :
202 : TYPE(mp_para_env_type), POINTER :: para_env
203 : REAL(dp), DIMENSION(:) :: full_ks
204 : TYPE(dbcsr_type), POINTER :: ks_matrix
205 : INTEGER, INTENT(IN) :: number_of_p_entries
206 : INTEGER, DIMENSION(:), POINTER :: block_offset
207 : INTEGER :: kind_of(*)
208 : TYPE(hfx_basis_type), DIMENSION(:), POINTER :: basis_parameter
209 : REAL(dp), INTENT(IN), OPTIONAL :: off_diag_fac, diag_fac
210 :
211 : INTEGER :: block_size, data_to, dest, dest_cpu, i, iatom, icpu, ikind, iset, jatom, jkind, &
212 : jset, mepos, ncpu, nseta, nsetb, pa, pa1, pb, pb1, source
213 39095 : INTEGER, DIMENSION(:), POINTER :: nsgfa, nsgfb
214 : REAL(dp) :: my_fac, myd_fac
215 39095 : REAL(dp), DIMENSION(:), POINTER :: recbuffer, sendbuffer, swapbuffer
216 39095 : REAL(dp), DIMENSION(:, :), POINTER :: sparse_block
217 : TYPE(dbcsr_iterator_type) :: iter
218 117285 : TYPE(mp_request_type), DIMENSION(2) :: req
219 :
220 39095 : my_fac = 1.0_dp; myd_fac = 1.0_dp
221 39095 : IF (PRESENT(off_diag_fac)) my_fac = off_diag_fac
222 39095 : IF (PRESENT(diag_fac)) myd_fac = diag_fac
223 :
224 117285 : ALLOCATE (sendbuffer(number_of_p_entries))
225 7897997 : sendbuffer = 0.0_dp
226 78190 : ALLOCATE (recbuffer(number_of_p_entries))
227 7897997 : recbuffer = 0.0_dp
228 :
229 39095 : ncpu = para_env%num_pe
230 39095 : mepos = para_env%mepos
231 39095 : dest = MODULO(mepos + 1, ncpu)
232 39095 : source = MODULO(mepos - 1, ncpu)
233 :
234 : ! sync before/after a ring of isendrecv
235 39095 : CALL para_env%sync()
236 78107 : DO icpu = 1, ncpu
237 78107 : i = 1
238 78107 : data_to = mepos - icpu
239 78107 : dest_cpu = MODULO(data_to, ncpu) + 1
240 78107 : block_size = block_offset(dest_cpu + 1) - block_offset(dest_cpu)
241 11698411 : sendbuffer(1:block_size) = sendbuffer(1:block_size) + full_ks(block_offset(dest_cpu):block_offset(dest_cpu) + block_size - 1)
242 78107 : IF (icpu .EQ. ncpu) EXIT
243 : CALL para_env%isendrecv(sendbuffer, dest, recbuffer, source, &
244 39012 : req(1), req(2), 13)
245 :
246 39012 : CALL mp_waitall(req)
247 39012 : swapbuffer => sendbuffer
248 39012 : sendbuffer => recbuffer
249 78107 : recbuffer => swapbuffer
250 : END DO
251 : ! sync before/after a ring of isendrecv
252 39095 : CALL para_env%sync()
253 :
254 39095 : i = 1
255 39095 : CALL dbcsr_iterator_start(iter, ks_matrix, shared=.FALSE.)
256 161497 : DO WHILE (dbcsr_iterator_blocks_left(iter))
257 122402 : CALL dbcsr_iterator_next_block(iter, iatom, jatom, sparse_block)
258 :
259 122402 : ikind = kind_of(iatom)
260 122402 : nseta = basis_parameter(ikind)%nset
261 122402 : nsgfa => basis_parameter(ikind)%nsgf
262 122402 : jkind = kind_of(jatom)
263 122402 : nsetb = basis_parameter(jkind)%nset
264 122402 : nsgfb => basis_parameter(jkind)%nsgf
265 122402 : pa = 0
266 519869 : DO iset = 1, nseta
267 : pb = 0
268 1494543 : DO jset = 1, nsetb
269 3737774 : DO pa1 = pa + 1, pa + nsgfa(iset)
270 9563447 : DO pb1 = pb + 1, pb + nsgfb(jset)
271 5825673 : IF (iatom == jatom .AND. pa1 == pb1) THEN
272 365653 : sparse_block(pa1, pb1) = sendbuffer(i)*myd_fac + sparse_block(pa1, pb1)
273 : ELSE
274 5460020 : sparse_block(pa1, pb1) = sendbuffer(i)*my_fac + sparse_block(pa1, pb1)
275 : END IF
276 8427276 : i = i + 1
277 : END DO
278 : END DO
279 1494543 : pb = pb + nsgfb(jset)
280 : END DO
281 480774 : pa = pa + nsgfa(iset)
282 : END DO
283 : END DO
284 39095 : CALL dbcsr_iterator_stop(iter)
285 :
286 39095 : DEALLOCATE (sendbuffer, recbuffer)
287 :
288 78190 : END SUBROUTINE distribute_ks_matrix
289 :
290 : ! **************************************************************************************************
291 : !> \brief - Distributes the local full Kohn-Sham matrix to all CPUS. Is called in
292 : !> case of adiabatic rescaling. This is just a refactored version of
293 : !> distribute_ks_matrix
294 : !> \param para_env ...
295 : !> \param qs_env ...
296 : !> \param ks_matrix Distributed Kohn-Sham matrix
297 : !> \param irep ...
298 : !> \param scaling_factor ...
299 : !> \par History
300 : !> 11.2007 created [Manuel Guidon]
301 : !> \author Manuel Guidon
302 : !> \note
303 : !> - Communication with left/right node only
304 : ! **************************************************************************************************
305 96 : SUBROUTINE scale_and_add_fock_to_ks_matrix(para_env, qs_env, ks_matrix, irep, &
306 : scaling_factor)
307 :
308 : TYPE(mp_para_env_type), POINTER :: para_env
309 : TYPE(qs_environment_type), POINTER :: qs_env
310 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix
311 : INTEGER, INTENT(IN) :: irep
312 : REAL(dp), INTENT(IN) :: scaling_factor
313 :
314 : INTEGER :: iatom, ikind, img, natom, nimages, nspins
315 96 : INTEGER, ALLOCATABLE, DIMENSION(:) :: kind_of, last_sgf_global
316 96 : REAL(dp), DIMENSION(:, :), POINTER :: full_ks
317 96 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
318 : TYPE(dft_control_type), POINTER :: dft_control
319 : TYPE(hfx_basis_type), DIMENSION(:), POINTER :: basis_parameter
320 : TYPE(hfx_type), POINTER :: actual_x_data
321 96 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
322 :
323 : !! All shared data is saved in i_thread = 1!
324 :
325 96 : NULLIFY (dft_control)
326 96 : actual_x_data => qs_env%x_data(irep, 1)
327 96 : basis_parameter => actual_x_data%basis_parameter
328 :
329 : CALL get_qs_env(qs_env=qs_env, &
330 : atomic_kind_set=atomic_kind_set, &
331 : particle_set=particle_set, &
332 96 : dft_control=dft_control)
333 :
334 96 : nspins = dft_control%nspins
335 96 : nimages = dft_control%nimages
336 96 : CPASSERT(nimages == 1)
337 :
338 96 : CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of)
339 :
340 96 : natom = SIZE(particle_set, 1)
341 288 : ALLOCATE (last_sgf_global(0:natom))
342 96 : last_sgf_global(0) = 0
343 192 : DO iatom = 1, natom
344 96 : ikind = kind_of(iatom)
345 192 : last_sgf_global(iatom) = last_sgf_global(iatom - 1) + basis_parameter(ikind)%nsgf_total
346 : END DO
347 96 : full_ks => actual_x_data%full_ks_alpha
348 96 : IF (scaling_factor /= 1.0_dp) THEN
349 19104 : full_ks = full_ks*scaling_factor
350 : END IF
351 192 : DO img = 1, nimages
352 : CALL distribute_ks_matrix(para_env, full_ks(:, img), ks_matrix(1, img)%matrix, actual_x_data%number_of_p_entries, &
353 : actual_x_data%block_offset, kind_of, basis_parameter, &
354 192 : off_diag_fac=0.5_dp)
355 : END DO
356 96 : DEALLOCATE (actual_x_data%full_ks_alpha)
357 :
358 96 : IF (nspins == 2) THEN
359 60 : full_ks => actual_x_data%full_ks_beta
360 60 : IF (scaling_factor /= 1.0_dp) THEN
361 11940 : full_ks = full_ks*scaling_factor
362 : END IF
363 120 : DO img = 1, nimages
364 : CALL distribute_ks_matrix(para_env, full_ks(:, img), ks_matrix(2, img)%matrix, actual_x_data%number_of_p_entries, &
365 : actual_x_data%block_offset, kind_of, basis_parameter, &
366 120 : off_diag_fac=0.5_dp)
367 : END DO
368 60 : DEALLOCATE (actual_x_data%full_ks_beta)
369 : END IF
370 :
371 96 : DEALLOCATE (last_sgf_global)
372 :
373 192 : END SUBROUTINE scale_and_add_fock_to_ks_matrix
374 :
375 : ! **************************************************************************************************
376 : !> \brief Given a 2d index pair, this function returns a 1d index pair for
377 : !> a symmetric upper triangle NxN matrix
378 : !> The compiler should inline this function, therefore it appears in
379 : !> several modules
380 : !> \param i 2d index
381 : !> \param j 2d index
382 : !> \param N matrix size
383 : !> \return ...
384 : !> \par History
385 : !> 03.2009 created [Manuel Guidon]
386 : !> \author Manuel Guidon
387 : ! **************************************************************************************************
388 0 : PURE FUNCTION get_1D_idx(i, j, N)
389 : INTEGER, INTENT(IN) :: i, j
390 : INTEGER(int_8), INTENT(IN) :: N
391 : INTEGER(int_8) :: get_1D_idx
392 :
393 : INTEGER(int_8) :: min_ij
394 :
395 0 : min_ij = MIN(i, j)
396 0 : get_1D_idx = min_ij*N + MAX(i, j) - (min_ij - 1)*min_ij/2 - N
397 :
398 0 : END FUNCTION get_1D_idx
399 :
400 : ! **************************************************************************************************
401 : !> \brief create a several maps array that reflects the ks matrix sparsity
402 : !> \param matrix ...
403 : !> \param basis_parameter ...
404 : !> \param kind_of ...
405 : !> \param is_assoc_atomic_block ...
406 : !> \param number_of_p_entries ...
407 : !> \param para_env ...
408 : !> \param atomic_block_offset ...
409 : !> \param set_offset ...
410 : !> \param block_offset ...
411 : !> \param map_atoms_to_cpus ...
412 : !> \param nkind ...
413 : !> \par History
414 : !> 11.2007 refactored [Joost VandeVondele]
415 : !> 07.2009 add new maps
416 : !> \author Manuel Guidon
417 : !> \notes
418 : !> is_assoc_atomic_block returns the mpi rank + 1 for associated blocks,
419 : !> zero for unassiated blocks
420 : ! **************************************************************************************************
421 2060 : SUBROUTINE get_atomic_block_maps(matrix, basis_parameter, kind_of, &
422 2060 : is_assoc_atomic_block, number_of_p_entries, &
423 : para_env, atomic_block_offset, set_offset, &
424 : block_offset, map_atoms_to_cpus, nkind)
425 :
426 : TYPE(dbcsr_type), POINTER :: matrix
427 : TYPE(hfx_basis_type), DIMENSION(:) :: basis_parameter
428 : INTEGER, DIMENSION(:) :: kind_of
429 : INTEGER, DIMENSION(:, :), INTENT(OUT) :: is_assoc_atomic_block
430 : INTEGER, INTENT(OUT) :: number_of_p_entries
431 : TYPE(mp_para_env_type), POINTER :: para_env
432 : INTEGER, DIMENSION(:, :), POINTER :: atomic_block_offset
433 : INTEGER, DIMENSION(:, :, :, :), POINTER :: set_offset
434 : INTEGER, DIMENSION(:), POINTER :: block_offset
435 : TYPE(hfx_2D_map), DIMENSION(:), POINTER :: map_atoms_to_cpus
436 : INTEGER :: nkind
437 :
438 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_atomic_block_maps'
439 :
440 : INTEGER :: handle, iatom, ibuf, icpu, ikind, ilist, iset, itask, jatom, jkind, jset, natom, &
441 : ncpu, nseta, nsetb, number_of_p_blocks, offset, tmp(2)
442 2060 : INTEGER, ALLOCATABLE, DIMENSION(:) :: buffer_in, buffer_out, counter, rcount, &
443 2060 : rdispl
444 2060 : INTEGER, DIMENSION(:), POINTER :: iatom_list, jatom_list, nsgfa, nsgfb
445 2060 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: sparse_block
446 : TYPE(dbcsr_iterator_type) :: iter
447 :
448 2060 : CALL timeset(routineN, handle)
449 :
450 31328 : is_assoc_atomic_block = 0
451 2060 : number_of_p_entries = 0
452 2060 : number_of_p_blocks = 0
453 :
454 : !
455 : ! count number_of_p_blocks and number_of_p_entries
456 : !
457 2060 : CALL dbcsr_iterator_start(iter, matrix, shared=.FALSE.)
458 9334 : DO WHILE (dbcsr_iterator_blocks_left(iter))
459 7274 : CALL dbcsr_iterator_next_block(iter, iatom, jatom, sparse_block)
460 7274 : ikind = kind_of(iatom)
461 7274 : jkind = kind_of(jatom)
462 7274 : number_of_p_blocks = number_of_p_blocks + 1
463 : number_of_p_entries = number_of_p_entries + &
464 7274 : basis_parameter(ikind)%nsgf_total*basis_parameter(jkind)%nsgf_total
465 : END DO
466 2060 : CALL dbcsr_iterator_stop(iter)
467 :
468 6180 : tmp = (/number_of_p_entries, number_of_p_blocks/)
469 2060 : CALL para_env%max(tmp)
470 2060 : number_of_p_entries = tmp(1)
471 2060 : number_of_p_blocks = tmp(2)
472 : !
473 : ! send this info around, so we can construct is_assoc_atomic_block
474 : ! pack all data in buffers and use allgatherv
475 : !
476 6180 : ALLOCATE (buffer_in(3*number_of_p_blocks))
477 6180 : ALLOCATE (buffer_out(3*number_of_p_blocks*para_env%num_pe))
478 8240 : ALLOCATE (rcount(para_env%num_pe), rdispl(para_env%num_pe))
479 :
480 29870 : buffer_in = 0
481 2060 : ibuf = 0
482 :
483 2060 : CALL dbcsr_iterator_start(iter, matrix, shared=.FALSE.)
484 9334 : DO WHILE (dbcsr_iterator_blocks_left(iter))
485 7274 : CALL dbcsr_iterator_next_block(iter, iatom, jatom, sparse_block)
486 :
487 7274 : buffer_in(ibuf + 1) = iatom
488 7274 : buffer_in(ibuf + 2) = jatom
489 7274 : buffer_in(ibuf + 3) = para_env%mepos + 1
490 7274 : ibuf = ibuf + 3
491 : END DO
492 2060 : CALL dbcsr_iterator_stop(iter)
493 :
494 6178 : rcount = SIZE(buffer_in)
495 2060 : rdispl(1) = 0
496 4118 : DO icpu = 2, para_env%num_pe
497 4118 : rdispl(icpu) = rdispl(icpu - 1) + rcount(icpu - 1)
498 : END DO
499 2060 : CALL para_env%allgatherv(buffer_in, buffer_out, rcount, rdispl)
500 :
501 20588 : DO ibuf = 0, number_of_p_blocks*para_env%num_pe*3 - 3, 3
502 18528 : itask = buffer_out(ibuf + 3)
503 : ! buffer_out can be 0 if buffer_in contained less elements than the max number of atom pairs
504 : ! is_assoc_atomic_block is a map for atom pairs to a processor (assumes symmetry, i,j on the ame as j,i)
505 20588 : IF (itask .NE. 0) THEN
506 14536 : iatom = buffer_out(ibuf + 1)
507 14536 : jatom = buffer_out(ibuf + 2)
508 14536 : is_assoc_atomic_block(iatom, jatom) = itask
509 14536 : is_assoc_atomic_block(jatom, iatom) = itask
510 : END IF
511 : END DO
512 :
513 2060 : IF (ASSOCIATED(map_atoms_to_cpus)) THEN
514 2640 : DO icpu = 1, para_env%num_pe
515 1760 : DEALLOCATE (map_atoms_to_cpus(icpu)%iatom_list)
516 2640 : DEALLOCATE (map_atoms_to_cpus(icpu)%jatom_list)
517 : END DO
518 880 : DEALLOCATE (map_atoms_to_cpus)
519 : END IF
520 :
521 2060 : natom = SIZE(is_assoc_atomic_block, 1)
522 10298 : ALLOCATE (map_atoms_to_cpus(para_env%num_pe))
523 6180 : ALLOCATE (counter(para_env%num_pe))
524 6178 : counter = 0
525 :
526 8308 : DO iatom = 1, natom
527 22942 : DO jatom = iatom, natom
528 14634 : icpu = is_assoc_atomic_block(jatom, iatom)
529 20882 : IF (icpu > 0) counter(icpu) = counter(icpu) + 1
530 : END DO
531 : END DO
532 6178 : DO icpu = 1, para_env%num_pe
533 12298 : ALLOCATE (map_atoms_to_cpus(icpu)%iatom_list(counter(icpu)))
534 10240 : ALLOCATE (map_atoms_to_cpus(icpu)%jatom_list(counter(icpu)))
535 : END DO
536 6178 : counter = 0
537 8308 : DO iatom = 1, natom
538 22942 : DO jatom = iatom, natom
539 14634 : icpu = is_assoc_atomic_block(jatom, iatom)
540 20882 : IF (icpu > 0) THEN
541 14536 : counter(icpu) = counter(icpu) + 1
542 14536 : map_atoms_to_cpus(icpu)%jatom_list(counter(icpu)) = jatom
543 14536 : map_atoms_to_cpus(icpu)%iatom_list(counter(icpu)) = iatom
544 : END IF
545 : END DO
546 : END DO
547 :
548 2060 : DEALLOCATE (counter)
549 :
550 2060 : ncpu = para_env%num_pe
551 2060 : offset = 1
552 31328 : atomic_block_offset = 0
553 8238 : block_offset = 0
554 6178 : DO icpu = 1, ncpu
555 4118 : iatom_list => map_atoms_to_cpus(icpu)%iatom_list
556 4118 : jatom_list => map_atoms_to_cpus(icpu)%jatom_list
557 4118 : block_offset(icpu) = offset
558 20714 : DO ilist = 1, SIZE(iatom_list)
559 14536 : iatom = iatom_list(ilist)
560 14536 : ikind = kind_of(iatom)
561 14536 : jatom = jatom_list(ilist)
562 14536 : jkind = kind_of(jatom)
563 14536 : atomic_block_offset(iatom, jatom) = offset
564 14536 : atomic_block_offset(jatom, iatom) = offset
565 18654 : offset = offset + basis_parameter(ikind)%nsgf_total*basis_parameter(jkind)%nsgf_total
566 : END DO
567 : END DO
568 2060 : block_offset(ncpu + 1) = offset
569 146808 : set_offset = 0
570 5816 : DO ikind = 1, nkind
571 3756 : nseta = basis_parameter(ikind)%nset
572 3756 : nsgfa => basis_parameter(ikind)%nsgf
573 14164 : DO jkind = 1, nkind
574 8348 : nsetb = basis_parameter(jkind)%nset
575 8348 : nsgfb => basis_parameter(jkind)%nsgf
576 8348 : offset = 1
577 34156 : DO iset = 1, nseta
578 105236 : DO jset = 1, nsetb
579 74836 : set_offset(jset, iset, jkind, ikind) = offset
580 96888 : offset = offset + nsgfa(iset)*nsgfb(jset)
581 : END DO
582 : END DO
583 : END DO
584 : END DO
585 :
586 2060 : CALL timestop(handle)
587 :
588 4120 : END SUBROUTINE get_atomic_block_maps
589 :
590 : END MODULE hfx_communication
|
