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
10 : !> \author Jan Wilhelm
11 : !> \date 08.2023
12 : ! **************************************************************************************************
13 : MODULE gw_communication
14 : USE cp_dbcsr_api, ONLY: &
15 : dbcsr_copy, dbcsr_create, dbcsr_filter, dbcsr_finalize, dbcsr_get_info, &
16 : dbcsr_get_stored_coordinates, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, &
17 : dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_p_type, &
18 : dbcsr_release, dbcsr_reserve_blocks, dbcsr_set, dbcsr_type
19 : USE cp_dbcsr_contrib, ONLY: dbcsr_reserve_all_blocks
20 : USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,&
21 : copy_fm_to_dbcsr
22 : USE cp_fm_types, ONLY: cp_fm_get_info,&
23 : cp_fm_type
24 : USE dbt_api, ONLY: dbt_clear,&
25 : dbt_copy,&
26 : dbt_copy_matrix_to_tensor,&
27 : dbt_copy_tensor_to_matrix,&
28 : dbt_create,&
29 : dbt_destroy,&
30 : dbt_type
31 : USE kinds, ONLY: dp
32 : USE message_passing, ONLY: mp_para_env_type,&
33 : mp_request_type,&
34 : mp_waitall
35 : USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type
36 : #include "./base/base_uses.f90"
37 :
38 : IMPLICIT NONE
39 :
40 : PRIVATE
41 :
42 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_communication'
43 :
44 : PUBLIC :: local_dbt_to_global_mat, fm_to_local_tensor, fm_to_local_array, local_array_to_fm, &
45 : local_dbt_to_global_fm
46 :
47 : TYPE buffer_type
48 : REAL(KIND=dp), DIMENSION(:), POINTER :: msg => NULL()
49 : INTEGER, DIMENSION(:), POINTER :: sizes => NULL()
50 : INTEGER, DIMENSION(:, :), POINTER :: indx => NULL()
51 : INTEGER :: proc = -1
52 : INTEGER :: msg_req = -1
53 : END TYPE buffer_type
54 :
55 : CONTAINS
56 :
57 : ! **************************************************************************************************
58 : !> \brief ...
59 : !> \param fm_global ...
60 : !> \param mat_global ...
61 : !> \param mat_local ...
62 : !> \param tensor ...
63 : !> \param bs_env ...
64 : !> \param atom_ranges ...
65 : ! **************************************************************************************************
66 4124 : SUBROUTINE fm_to_local_tensor(fm_global, mat_global, mat_local, tensor, bs_env, atom_ranges)
67 :
68 : TYPE(cp_fm_type) :: fm_global
69 : TYPE(dbcsr_type) :: mat_global, mat_local
70 : TYPE(dbt_type) :: tensor
71 : TYPE(post_scf_bandstructure_type), POINTER :: bs_env
72 : INTEGER, DIMENSION(:, :), OPTIONAL :: atom_ranges
73 :
74 : CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_to_local_tensor'
75 :
76 : INTEGER :: handle
77 37116 : TYPE(dbt_type) :: tensor_tmp
78 :
79 4124 : CALL timeset(routineN, handle)
80 :
81 4124 : CALL dbt_clear(tensor)
82 4124 : CALL copy_fm_to_dbcsr(fm_global, mat_global, keep_sparsity=.FALSE.)
83 4124 : CALL dbcsr_filter(mat_global, bs_env%eps_filter)
84 4124 : IF (PRESENT(atom_ranges)) THEN
85 : CALL global_matrix_to_local_matrix(mat_global, mat_local, bs_env%para_env, &
86 1460 : bs_env%para_env_tensor%num_pe, atom_ranges)
87 : ELSE
88 : CALL global_matrix_to_local_matrix(mat_global, mat_local, bs_env%para_env, &
89 2664 : bs_env%para_env_tensor%num_pe)
90 : END IF
91 4124 : CALL dbt_create(mat_local, tensor_tmp)
92 4124 : CALL dbt_copy_matrix_to_tensor(mat_local, tensor_tmp)
93 4124 : CALL dbt_copy(tensor_tmp, tensor, move_data=.TRUE.)
94 4124 : CALL dbt_destroy(tensor_tmp)
95 4124 : CALL dbcsr_set(mat_local, 0.0_dp)
96 4124 : CALL dbcsr_filter(mat_local, 1.0_dp)
97 :
98 4124 : CALL timestop(handle)
99 :
100 4124 : END SUBROUTINE fm_to_local_tensor
101 :
102 : ! **************************************************************************************************
103 : !> \brief ...
104 : !> \param tensor ...
105 : !> \param mat_tensor ...
106 : !> \param mat_global ...
107 : !> \param para_env ...
108 : ! **************************************************************************************************
109 2436 : SUBROUTINE local_dbt_to_global_mat(tensor, mat_tensor, mat_global, para_env)
110 :
111 : TYPE(dbt_type) :: tensor
112 : TYPE(dbcsr_type) :: mat_tensor, mat_global
113 : TYPE(mp_para_env_type), POINTER :: para_env
114 :
115 : CHARACTER(LEN=*), PARAMETER :: routineN = 'local_dbt_to_global_mat'
116 :
117 : INTEGER :: handle
118 :
119 2436 : CALL timeset(routineN, handle)
120 :
121 2436 : CALL dbt_copy_tensor_to_matrix(tensor, mat_tensor)
122 2436 : CALL dbt_clear(tensor)
123 : ! the next para_env%sync is not mandatory, but it makes the timing output
124 : ! of local_matrix_to_global_matrix correct
125 2436 : CALL para_env%sync()
126 2436 : CALL local_matrix_to_global_matrix(mat_tensor, mat_global, para_env)
127 :
128 2436 : CALL timestop(handle)
129 :
130 2436 : END SUBROUTINE local_dbt_to_global_mat
131 :
132 : ! **************************************************************************************************
133 : !> \brief ...
134 : !> \param mat_global ...
135 : !> \param mat_local ...
136 : !> \param para_env ...
137 : !> \param num_pe_sub ...
138 : !> \param atom_ranges ...
139 : ! **************************************************************************************************
140 4124 : SUBROUTINE global_matrix_to_local_matrix(mat_global, mat_local, para_env, num_pe_sub, atom_ranges)
141 : TYPE(dbcsr_type) :: mat_global, mat_local
142 : TYPE(mp_para_env_type), POINTER :: para_env
143 : INTEGER :: num_pe_sub
144 : INTEGER, DIMENSION(:, :), OPTIONAL :: atom_ranges
145 :
146 : CHARACTER(LEN=*), PARAMETER :: routineN = 'global_matrix_to_local_matrix'
147 :
148 : INTEGER :: block_counter, block_offset, block_size, col, col_from_buffer, col_offset, &
149 : col_size, handle, handle1, i_block, i_entry, i_mepos, igroup, imep, imep_sub, msg_offset, &
150 : nblkrows_total, ngroup, nmo, num_blocks, offset, row, row_from_buffer, row_offset, &
151 : row_size, total_num_entries
152 4124 : INTEGER, ALLOCATABLE, DIMENSION(:) :: blk_counter, cols_to_alloc, entry_counter, &
153 4124 : num_entries_blocks_rec, num_entries_blocks_send, row_block_from_index, rows_to_alloc, &
154 4124 : sizes_rec, sizes_send
155 4124 : INTEGER, DIMENSION(:), POINTER :: row_blk_offset, row_blk_size
156 4124 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
157 4124 : TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
158 : TYPE(dbcsr_iterator_type) :: iter
159 :
160 4124 : CALL timeset(routineN, handle)
161 :
162 4124 : CALL timeset("get_sizes", handle1)
163 :
164 4124 : NULLIFY (data_block)
165 :
166 12372 : ALLOCATE (num_entries_blocks_send(0:2*para_env%num_pe - 1))
167 20620 : num_entries_blocks_send(:) = 0
168 :
169 8248 : ALLOCATE (num_entries_blocks_rec(0:2*para_env%num_pe - 1))
170 20620 : num_entries_blocks_rec(:) = 0
171 :
172 4124 : ngroup = para_env%num_pe/num_pe_sub
173 :
174 4124 : CALL dbcsr_iterator_start(iter, mat_global)
175 12209 : DO WHILE (dbcsr_iterator_blocks_left(iter))
176 :
177 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
178 : row_size=row_size, col_size=col_size, &
179 8085 : row_offset=row_offset, col_offset=col_offset)
180 :
181 8085 : CALL dbcsr_get_stored_coordinates(mat_local, row, col, imep_sub)
182 :
183 25237 : DO igroup = 0, ngroup - 1
184 :
185 13028 : IF (PRESENT(atom_ranges)) THEN
186 3142 : IF (row < atom_ranges(1, igroup + 1) .OR. row > atom_ranges(2, igroup + 1)) CYCLE
187 : END IF
188 13028 : imep = imep_sub + igroup*num_pe_sub
189 :
190 13028 : num_entries_blocks_send(2*imep) = num_entries_blocks_send(2*imep) + row_size*col_size
191 21113 : num_entries_blocks_send(2*imep + 1) = num_entries_blocks_send(2*imep + 1) + 1
192 :
193 : END DO
194 :
195 : END DO
196 :
197 4124 : CALL dbcsr_iterator_stop(iter)
198 :
199 4124 : CALL timestop(handle1)
200 :
201 4124 : CALL timeset("send_sizes_1", handle1)
202 :
203 20620 : total_num_entries = SUM(num_entries_blocks_send)
204 4124 : CALL para_env%sum(total_num_entries)
205 :
206 4124 : CALL timestop(handle1)
207 :
208 4124 : CALL timeset("send_sizes_2", handle1)
209 :
210 4124 : IF (para_env%num_pe > 1) THEN
211 4124 : CALL para_env%alltoall(num_entries_blocks_send, num_entries_blocks_rec, 2)
212 : ELSE
213 0 : num_entries_blocks_rec(0:1) = num_entries_blocks_send(0:1)
214 : END IF
215 :
216 4124 : CALL timestop(handle1)
217 :
218 4124 : CALL timeset("get_data", handle1)
219 :
220 20620 : ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
221 20620 : ALLOCATE (buffer_send(0:para_env%num_pe - 1))
222 :
223 : ! allocate data message and corresponding indices
224 12372 : DO imep = 0, para_env%num_pe - 1
225 :
226 21672 : ALLOCATE (buffer_rec(imep)%msg(num_entries_blocks_rec(2*imep)))
227 259330 : buffer_rec(imep)%msg = 0.0_dp
228 :
229 21672 : ALLOCATE (buffer_send(imep)%msg(num_entries_blocks_send(2*imep)))
230 259330 : buffer_send(imep)%msg = 0.0_dp
231 :
232 21672 : ALLOCATE (buffer_rec(imep)%indx(num_entries_blocks_rec(2*imep + 1), 3))
233 72076 : buffer_rec(imep)%indx = 0
234 :
235 21672 : ALLOCATE (buffer_send(imep)%indx(num_entries_blocks_send(2*imep + 1), 3))
236 76200 : buffer_send(imep)%indx = 0
237 :
238 : END DO
239 :
240 12372 : ALLOCATE (entry_counter(0:para_env%num_pe - 1))
241 12372 : entry_counter(:) = 0
242 :
243 8248 : ALLOCATE (blk_counter(0:para_env%num_pe - 1))
244 12372 : blk_counter = 0
245 :
246 4124 : CALL dbcsr_iterator_start(iter, mat_global)
247 12209 : DO WHILE (dbcsr_iterator_blocks_left(iter))
248 :
249 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
250 : row_size=row_size, col_size=col_size, &
251 8085 : row_offset=row_offset, col_offset=col_offset)
252 :
253 8085 : CALL dbcsr_get_stored_coordinates(mat_local, row, col, imep_sub)
254 :
255 25237 : DO igroup = 0, ngroup - 1
256 :
257 13028 : IF (PRESENT(atom_ranges)) THEN
258 3142 : IF (row < atom_ranges(1, igroup + 1) .OR. row > atom_ranges(2, igroup + 1)) CYCLE
259 : END IF
260 :
261 13028 : imep = imep_sub + igroup*num_pe_sub
262 :
263 13028 : msg_offset = entry_counter(imep)
264 :
265 13028 : block_size = row_size*col_size
266 :
267 : buffer_send(imep)%msg(msg_offset + 1:msg_offset + block_size) = &
268 277138 : RESHAPE(data_block(1:row_size, 1:col_size), [block_size])
269 :
270 13028 : entry_counter(imep) = entry_counter(imep) + block_size
271 :
272 13028 : blk_counter(imep) = blk_counter(imep) + 1
273 :
274 13028 : block_offset = blk_counter(imep)
275 :
276 13028 : buffer_send(imep)%indx(block_offset, 1) = row
277 13028 : buffer_send(imep)%indx(block_offset, 2) = col
278 21113 : buffer_send(imep)%indx(block_offset, 3) = msg_offset
279 :
280 : END DO
281 :
282 : END DO
283 :
284 4124 : CALL dbcsr_iterator_stop(iter)
285 :
286 4124 : CALL timestop(handle1)
287 :
288 4124 : CALL timeset("send_data", handle1)
289 :
290 12372 : ALLOCATE (sizes_rec(0:para_env%num_pe - 1))
291 8248 : ALLOCATE (sizes_send(0:para_env%num_pe - 1))
292 :
293 12372 : DO imep = 0, para_env%num_pe - 1
294 8248 : sizes_send(imep) = num_entries_blocks_send(2*imep)
295 12372 : sizes_rec(imep) = num_entries_blocks_rec(2*imep)
296 : END DO
297 :
298 4124 : CALL communicate_buffer(para_env, sizes_rec, sizes_send, buffer_rec, buffer_send)
299 :
300 4124 : CALL timestop(handle1)
301 :
302 4124 : CALL timeset("row_block_from_index", handle1)
303 :
304 : CALL dbcsr_get_info(mat_local, &
305 : nblkrows_total=nblkrows_total, &
306 : row_blk_offset=row_blk_offset, &
307 4124 : row_blk_size=row_blk_size)
308 :
309 8248 : ALLOCATE (row_block_from_index(nmo))
310 4124 : row_block_from_index = 0
311 :
312 4124 : DO i_entry = 1, nmo
313 4124 : DO i_block = 1, nblkrows_total
314 :
315 0 : IF (i_entry >= row_blk_offset(i_block) .AND. &
316 0 : i_entry <= row_blk_offset(i_block) + row_blk_size(i_block) - 1) THEN
317 :
318 0 : row_block_from_index(i_entry) = i_block
319 :
320 : END IF
321 :
322 : END DO
323 : END DO
324 :
325 4124 : CALL timestop(handle1)
326 :
327 4124 : CALL timeset("reserve_blocks", handle1)
328 :
329 4124 : num_blocks = 0
330 :
331 : ! get the number of blocks, which have to be allocated
332 12372 : DO imep = 0, para_env%num_pe - 1
333 12372 : num_blocks = num_blocks + num_entries_blocks_rec(2*imep + 1)
334 : END DO
335 :
336 11714 : ALLOCATE (rows_to_alloc(num_blocks))
337 17152 : rows_to_alloc = 0
338 :
339 7590 : ALLOCATE (cols_to_alloc(num_blocks))
340 17152 : cols_to_alloc = 0
341 :
342 : block_counter = 0
343 :
344 12372 : DO i_mepos = 0, para_env%num_pe - 1
345 :
346 25400 : DO i_block = 1, num_entries_blocks_rec(2*i_mepos + 1)
347 :
348 13028 : block_counter = block_counter + 1
349 :
350 13028 : rows_to_alloc(block_counter) = buffer_rec(i_mepos)%indx(i_block, 1)
351 21276 : cols_to_alloc(block_counter) = buffer_rec(i_mepos)%indx(i_block, 2)
352 :
353 : END DO
354 :
355 : END DO
356 :
357 4124 : CALL dbcsr_set(mat_local, 0.0_dp)
358 4124 : CALL dbcsr_filter(mat_local, 1.0_dp)
359 4124 : CALL dbcsr_reserve_blocks(mat_local, rows=rows_to_alloc(:), cols=cols_to_alloc(:))
360 4124 : CALL dbcsr_finalize(mat_local)
361 4124 : CALL dbcsr_set(mat_local, 0.0_dp)
362 :
363 4124 : CALL timestop(handle1)
364 :
365 4124 : CALL timeset("fill_mat_local", handle1)
366 :
367 4124 : CALL dbcsr_iterator_start(iter, mat_local)
368 :
369 17152 : DO WHILE (dbcsr_iterator_blocks_left(iter))
370 :
371 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
372 13028 : row_size=row_size, col_size=col_size)
373 :
374 43208 : DO imep = 0, para_env%num_pe - 1
375 :
376 108052 : DO i_block = 1, num_entries_blocks_rec(2*imep + 1)
377 :
378 68968 : row_from_buffer = buffer_rec(imep)%indx(i_block, 1)
379 68968 : col_from_buffer = buffer_rec(imep)%indx(i_block, 2)
380 68968 : offset = buffer_rec(imep)%indx(i_block, 3)
381 :
382 95024 : IF (row == row_from_buffer .AND. col == col_from_buffer) THEN
383 :
384 : data_block(1:row_size, 1:col_size) = &
385 : RESHAPE(buffer_rec(imep)%msg(offset + 1:offset + row_size*col_size), &
386 340594 : [row_size, col_size])
387 :
388 : END IF
389 :
390 : END DO
391 :
392 : END DO
393 :
394 : END DO ! blocks
395 :
396 4124 : CALL dbcsr_iterator_stop(iter)
397 :
398 4124 : CALL timestop(handle1)
399 :
400 12372 : DO imep = 0, para_env%num_pe - 1
401 8248 : DEALLOCATE (buffer_rec(imep)%msg)
402 8248 : DEALLOCATE (buffer_rec(imep)%indx)
403 8248 : DEALLOCATE (buffer_send(imep)%msg)
404 12372 : DEALLOCATE (buffer_send(imep)%indx)
405 : END DO
406 :
407 4124 : CALL timestop(handle)
408 :
409 45364 : END SUBROUTINE global_matrix_to_local_matrix
410 :
411 : ! **************************************************************************************************
412 : !> \brief ...
413 : !> \param para_env ...
414 : !> \param num_entries_rec ...
415 : !> \param num_entries_send ...
416 : !> \param buffer_rec ...
417 : !> \param buffer_send ...
418 : !> \param do_indx ...
419 : !> \param do_msg ...
420 : ! **************************************************************************************************
421 4124 : SUBROUTINE communicate_buffer(para_env, num_entries_rec, num_entries_send, &
422 : buffer_rec, buffer_send, do_indx, do_msg)
423 :
424 : TYPE(mp_para_env_type), POINTER :: para_env
425 : INTEGER, ALLOCATABLE, DIMENSION(:) :: num_entries_rec, num_entries_send
426 : TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
427 : LOGICAL, OPTIONAL :: do_indx, do_msg
428 :
429 : CHARACTER(LEN=*), PARAMETER :: routineN = 'communicate_buffer'
430 :
431 : INTEGER :: handle, imep, rec_counter, send_counter
432 : LOGICAL :: my_do_indx, my_do_msg
433 4124 : TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req
434 :
435 4124 : CALL timeset(routineN, handle)
436 :
437 4124 : NULLIFY (req)
438 65984 : ALLOCATE (req(1:para_env%num_pe, 4))
439 :
440 4124 : my_do_indx = .TRUE.
441 4124 : IF (PRESENT(do_indx)) my_do_indx = do_indx
442 4124 : my_do_msg = .TRUE.
443 4124 : IF (PRESENT(do_msg)) my_do_msg = do_msg
444 :
445 4124 : IF (para_env%num_pe > 1) THEN
446 :
447 4124 : send_counter = 0
448 4124 : rec_counter = 0
449 :
450 12372 : DO imep = 0, para_env%num_pe - 1
451 12372 : IF (num_entries_rec(imep) > 0) THEN
452 5176 : rec_counter = rec_counter + 1
453 5176 : IF (my_do_indx) THEN
454 5176 : CALL para_env%irecv(buffer_rec(imep)%indx, imep, req(rec_counter, 3), tag=4)
455 : END IF
456 5176 : IF (my_do_msg) THEN
457 5176 : CALL para_env%irecv(buffer_rec(imep)%msg, imep, req(rec_counter, 4), tag=7)
458 : END IF
459 : END IF
460 : END DO
461 :
462 12372 : DO imep = 0, para_env%num_pe - 1
463 12372 : IF (num_entries_send(imep) > 0) THEN
464 5176 : send_counter = send_counter + 1
465 5176 : IF (my_do_indx) THEN
466 5176 : CALL para_env%isend(buffer_send(imep)%indx, imep, req(send_counter, 1), tag=4)
467 : END IF
468 5176 : IF (my_do_msg) THEN
469 5176 : CALL para_env%isend(buffer_send(imep)%msg, imep, req(send_counter, 2), tag=7)
470 : END IF
471 : END IF
472 : END DO
473 :
474 4124 : IF (my_do_indx) THEN
475 4124 : CALL mp_waitall(req(1:send_counter, 1))
476 4124 : CALL mp_waitall(req(1:rec_counter, 3))
477 : END IF
478 :
479 4124 : IF (my_do_msg) THEN
480 4124 : CALL mp_waitall(req(1:send_counter, 2))
481 4124 : CALL mp_waitall(req(1:rec_counter, 4))
482 : END IF
483 :
484 : ELSE
485 :
486 0 : buffer_rec(0)%indx = buffer_send(0)%indx
487 0 : buffer_rec(0)%msg = buffer_send(0)%msg
488 :
489 : END IF
490 :
491 4124 : DEALLOCATE (req)
492 :
493 4124 : CALL timestop(handle)
494 :
495 4124 : END SUBROUTINE communicate_buffer
496 :
497 : ! **************************************************************************************************
498 : !> \brief ...
499 : !> \param mat_local ...
500 : !> \param mat_global ...
501 : !> \param para_env ...
502 : ! **************************************************************************************************
503 2436 : SUBROUTINE local_matrix_to_global_matrix(mat_local, mat_global, para_env)
504 :
505 : TYPE(dbcsr_type) :: mat_local, mat_global
506 : TYPE(mp_para_env_type), POINTER :: para_env
507 :
508 : CHARACTER(LEN=*), PARAMETER :: routineN = 'local_matrix_to_global_matrix'
509 :
510 : INTEGER :: block_size, c, col, col_size, handle, &
511 : handle1, i_block, imep, o, offset, r, &
512 : rec_counter, row, row_size, &
513 : send_counter
514 2436 : INTEGER, ALLOCATABLE, DIMENSION(:) :: block_counter, entry_counter, num_blocks_rec, &
515 2436 : num_blocks_send, num_entries_rec, num_entries_send, sizes_rec, sizes_send
516 2436 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
517 2436 : TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
518 : TYPE(dbcsr_iterator_type) :: iter
519 : TYPE(dbcsr_type) :: mat_global_copy
520 2436 : TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req
521 :
522 2436 : CALL timeset(routineN, handle)
523 :
524 2436 : CALL timeset("get_coord", handle1)
525 :
526 2436 : CALL dbcsr_create(mat_global_copy, template=mat_global)
527 2436 : CALL dbcsr_reserve_all_blocks(mat_global_copy)
528 :
529 2436 : CALL dbcsr_set(mat_global, 0.0_dp)
530 2436 : CALL dbcsr_set(mat_global_copy, 0.0_dp)
531 :
532 14616 : ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
533 12180 : ALLOCATE (buffer_send(0:para_env%num_pe - 1))
534 :
535 7308 : ALLOCATE (num_entries_rec(0:para_env%num_pe - 1))
536 4872 : ALLOCATE (num_blocks_rec(0:para_env%num_pe - 1))
537 4872 : ALLOCATE (num_entries_send(0:para_env%num_pe - 1))
538 4872 : ALLOCATE (num_blocks_send(0:para_env%num_pe - 1))
539 7308 : num_entries_rec = 0
540 7308 : num_blocks_rec = 0
541 7308 : num_entries_send = 0
542 7308 : num_blocks_send = 0
543 :
544 2436 : CALL dbcsr_iterator_start(iter, mat_local)
545 6504 : DO WHILE (dbcsr_iterator_blocks_left(iter))
546 :
547 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
548 4068 : row_size=row_size, col_size=col_size)
549 :
550 4068 : CALL dbcsr_get_stored_coordinates(mat_global, row, col, imep)
551 :
552 4068 : num_entries_send(imep) = num_entries_send(imep) + row_size*col_size
553 4068 : num_blocks_send(imep) = num_blocks_send(imep) + 1
554 :
555 : END DO
556 :
557 2436 : CALL dbcsr_iterator_stop(iter)
558 :
559 2436 : CALL timestop(handle1)
560 :
561 2436 : CALL timeset("comm_size", handle1)
562 :
563 2436 : IF (para_env%num_pe > 1) THEN
564 :
565 7308 : ALLOCATE (sizes_rec(0:2*para_env%num_pe - 1))
566 4872 : ALLOCATE (sizes_send(0:2*para_env%num_pe - 1))
567 :
568 7308 : DO imep = 0, para_env%num_pe - 1
569 :
570 4872 : sizes_send(2*imep) = num_entries_send(imep)
571 7308 : sizes_send(2*imep + 1) = num_blocks_send(imep)
572 :
573 : END DO
574 :
575 2436 : CALL para_env%alltoall(sizes_send, sizes_rec, 2)
576 :
577 7308 : DO imep = 0, para_env%num_pe - 1
578 4872 : num_entries_rec(imep) = sizes_rec(2*imep)
579 7308 : num_blocks_rec(imep) = sizes_rec(2*imep + 1)
580 : END DO
581 :
582 2436 : DEALLOCATE (sizes_rec, sizes_send)
583 :
584 : ELSE
585 :
586 0 : num_entries_rec(0) = num_entries_send(0)
587 0 : num_blocks_rec(0) = num_blocks_send(0)
588 :
589 : END IF
590 :
591 2436 : CALL timestop(handle1)
592 :
593 2436 : CALL timeset("fill_buffer", handle1)
594 :
595 : ! allocate data message and corresponding indices
596 7308 : DO imep = 0, para_env%num_pe - 1
597 :
598 11818 : ALLOCATE (buffer_rec(imep)%msg(num_entries_rec(imep)))
599 102560 : buffer_rec(imep)%msg = 0.0_dp
600 :
601 11818 : ALLOCATE (buffer_send(imep)%msg(num_entries_send(imep)))
602 102560 : buffer_send(imep)%msg = 0.0_dp
603 :
604 11818 : ALLOCATE (buffer_rec(imep)%indx(num_blocks_rec(imep), 5))
605 49572 : buffer_rec(imep)%indx = 0
606 :
607 11818 : ALLOCATE (buffer_send(imep)%indx(num_blocks_send(imep), 5))
608 52008 : buffer_send(imep)%indx = 0
609 :
610 : END DO
611 :
612 7308 : ALLOCATE (block_counter(0:para_env%num_pe - 1))
613 7308 : block_counter(:) = 0
614 :
615 4872 : ALLOCATE (entry_counter(0:para_env%num_pe - 1))
616 7308 : entry_counter(:) = 0
617 :
618 : ! fill buffer_send
619 2436 : CALL dbcsr_iterator_start(iter, mat_local)
620 6504 : DO WHILE (dbcsr_iterator_blocks_left(iter))
621 :
622 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
623 4068 : row_size=row_size, col_size=col_size)
624 :
625 4068 : CALL dbcsr_get_stored_coordinates(mat_global, row, col, imep)
626 :
627 4068 : block_size = row_size*col_size
628 :
629 4068 : offset = entry_counter(imep)
630 :
631 : buffer_send(imep)%msg(offset + 1:offset + block_size) = &
632 105824 : RESHAPE(data_block(1:row_size, 1:col_size), [block_size])
633 :
634 4068 : i_block = block_counter(imep) + 1
635 :
636 4068 : buffer_send(imep)%indx(i_block, 1) = row
637 4068 : buffer_send(imep)%indx(i_block, 2) = col
638 4068 : buffer_send(imep)%indx(i_block, 3) = offset
639 :
640 4068 : entry_counter(imep) = entry_counter(imep) + block_size
641 :
642 4068 : block_counter(imep) = block_counter(imep) + 1
643 :
644 : END DO
645 :
646 2436 : CALL dbcsr_iterator_stop(iter)
647 :
648 2436 : CALL timestop(handle1)
649 :
650 2436 : CALL timeset("comm_data", handle1)
651 :
652 2436 : NULLIFY (req)
653 38976 : ALLOCATE (req(1:para_env%num_pe, 4))
654 :
655 2436 : IF (para_env%num_pe > 1) THEN
656 :
657 2436 : send_counter = 0
658 2436 : rec_counter = 0
659 :
660 7308 : DO imep = 0, para_env%num_pe - 1
661 4872 : IF (num_entries_rec(imep) > 0) THEN
662 2074 : rec_counter = rec_counter + 1
663 2074 : CALL para_env%irecv(buffer_rec(imep)%indx, imep, req(rec_counter, 3), tag=4)
664 : END IF
665 7308 : IF (num_entries_rec(imep) > 0) THEN
666 2074 : CALL para_env%irecv(buffer_rec(imep)%msg, imep, req(rec_counter, 4), tag=7)
667 : END IF
668 : END DO
669 :
670 7308 : DO imep = 0, para_env%num_pe - 1
671 4872 : IF (num_entries_send(imep) > 0) THEN
672 2074 : send_counter = send_counter + 1
673 2074 : CALL para_env%isend(buffer_send(imep)%indx, imep, req(send_counter, 1), tag=4)
674 : END IF
675 7308 : IF (num_entries_send(imep) > 0) THEN
676 2074 : CALL para_env%isend(buffer_send(imep)%msg, imep, req(send_counter, 2), tag=7)
677 : END IF
678 : END DO
679 :
680 2436 : CALL mp_waitall(req(1:send_counter, 1:2))
681 2436 : CALL mp_waitall(req(1:rec_counter, 3:4))
682 :
683 : ELSE
684 :
685 0 : buffer_rec(0)%indx = buffer_send(0)%indx
686 0 : buffer_rec(0)%msg = buffer_send(0)%msg
687 :
688 : END IF
689 :
690 2436 : CALL timestop(handle1)
691 :
692 2436 : CALL timeset("set_blocks", handle1)
693 :
694 : ! fill mat_global_copy
695 2436 : CALL dbcsr_iterator_start(iter, mat_global_copy)
696 10063 : DO WHILE (dbcsr_iterator_blocks_left(iter))
697 :
698 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
699 7627 : row_size=row_size, col_size=col_size)
700 :
701 25317 : DO imep = 0, para_env%num_pe - 1
702 :
703 38421 : DO i_block = 1, num_blocks_rec(imep)
704 :
705 15540 : IF (row == buffer_rec(imep)%indx(i_block, 1) .AND. &
706 15254 : col == buffer_rec(imep)%indx(i_block, 2)) THEN
707 :
708 4068 : offset = buffer_rec(imep)%indx(i_block, 3)
709 :
710 4068 : r = row_size
711 4068 : c = col_size
712 4068 : o = offset
713 :
714 : data_block(1:r, 1:c) = data_block(1:r, 1:c) + &
715 125813 : RESHAPE(buffer_rec(imep)%msg(o + 1:o + r*c), [r, c])
716 :
717 : END IF
718 :
719 : END DO
720 :
721 : END DO
722 :
723 : END DO
724 :
725 2436 : CALL dbcsr_iterator_stop(iter)
726 :
727 2436 : CALL dbcsr_copy(mat_global, mat_global_copy)
728 :
729 2436 : CALL dbcsr_release(mat_global_copy)
730 :
731 : ! remove the blocks which are exactly zero from mat_global
732 2436 : CALL dbcsr_filter(mat_global, 1.0E-30_dp)
733 :
734 7308 : DO imep = 0, para_env%num_pe - 1
735 4872 : DEALLOCATE (buffer_rec(imep)%msg)
736 4872 : DEALLOCATE (buffer_send(imep)%msg)
737 4872 : DEALLOCATE (buffer_rec(imep)%indx)
738 7308 : DEALLOCATE (buffer_send(imep)%indx)
739 : END DO
740 :
741 2436 : DEALLOCATE (buffer_rec, buffer_send)
742 :
743 2436 : DEALLOCATE (block_counter, entry_counter)
744 :
745 2436 : DEALLOCATE (req)
746 :
747 2436 : CALL dbcsr_set(mat_local, 0.0_dp)
748 2436 : CALL dbcsr_filter(mat_local, 1.0_dp)
749 :
750 2436 : CALL timestop(handle1)
751 :
752 2436 : CALL timestop(handle)
753 :
754 19488 : END SUBROUTINE local_matrix_to_global_matrix
755 :
756 : ! **************************************************************************************************
757 : !> \brief ...
758 : !> \param fm_S ...
759 : !> \param array_S ...
760 : !> \param weight ...
761 : !> \param add ...
762 : ! **************************************************************************************************
763 504 : SUBROUTINE fm_to_local_array(fm_S, array_S, weight, add)
764 :
765 : TYPE(cp_fm_type), DIMENSION(:) :: fm_S
766 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: array_S
767 : REAL(KIND=dp), OPTIONAL :: weight
768 : LOGICAL, OPTIONAL :: add
769 :
770 : CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_to_local_array'
771 :
772 : INTEGER :: handle, i, i_row_local, img, j, &
773 : j_col_local, n_basis, ncol_local, &
774 : nimages, nrow_local
775 504 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
776 : LOGICAL :: my_add
777 : REAL(KIND=dp) :: my_weight
778 504 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: array_tmp
779 :
780 504 : CALL timeset(routineN, handle)
781 :
782 504 : my_weight = 1.0_dp
783 504 : IF (PRESENT(weight)) my_weight = weight
784 :
785 504 : my_add = .FALSE.
786 504 : IF (PRESENT(add)) my_add = add
787 :
788 504 : n_basis = SIZE(array_S, 1)
789 504 : nimages = SIZE(array_S, 3)
790 :
791 : ! checks
792 504 : CPASSERT(SIZE(array_S, 2) == n_basis)
793 504 : CPASSERT(SIZE(fm_S) == nimages)
794 504 : CPASSERT(LBOUND(array_S, 1) == 1)
795 504 : CPASSERT(LBOUND(array_S, 2) == 1)
796 504 : CPASSERT(LBOUND(array_S, 3) == 1)
797 :
798 : CALL cp_fm_get_info(matrix=fm_S(1), &
799 : nrow_local=nrow_local, &
800 : ncol_local=ncol_local, &
801 : row_indices=row_indices, &
802 504 : col_indices=col_indices)
803 :
804 31536 : IF (.NOT. my_add) array_S(:, :, :) = 0.0_dp
805 2520 : ALLOCATE (array_tmp(SIZE(array_S, 1), SIZE(array_S, 2), SIZE(array_S, 3)))
806 170928 : array_tmp(:, :, :) = 0.0_dp
807 :
808 5040 : DO img = 1, nimages
809 17622 : DO i_row_local = 1, nrow_local
810 :
811 12582 : i = row_indices(i_row_local)
812 :
813 87480 : DO j_col_local = 1, ncol_local
814 :
815 70362 : j = col_indices(j_col_local)
816 :
817 82944 : array_tmp(i, j, img) = fm_S(img)%local_data(i_row_local, j_col_local)
818 :
819 : END DO ! j_col_local
820 : END DO ! i_row_local
821 : END DO ! img
822 :
823 504 : CALL fm_S(1)%matrix_struct%para_env%sync()
824 504 : CALL fm_S(1)%matrix_struct%para_env%sum(array_tmp)
825 504 : CALL fm_S(1)%matrix_struct%para_env%sync()
826 :
827 170928 : array_S(:, :, :) = array_S(:, :, :) + my_weight*array_tmp(:, :, :)
828 :
829 504 : CALL timestop(handle)
830 :
831 1512 : END SUBROUTINE fm_to_local_array
832 :
833 : ! **************************************************************************************************
834 : !> \brief ...
835 : !> \param array_S ...
836 : !> \param fm_S ...
837 : !> \param weight ...
838 : !> \param add ...
839 : ! **************************************************************************************************
840 424 : SUBROUTINE local_array_to_fm(array_S, fm_S, weight, add)
841 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: array_S
842 : TYPE(cp_fm_type), DIMENSION(:) :: fm_S
843 : REAL(KIND=dp), OPTIONAL :: weight
844 : LOGICAL, OPTIONAL :: add
845 :
846 : CHARACTER(LEN=*), PARAMETER :: routineN = 'local_array_to_fm'
847 :
848 : INTEGER :: handle, i, i_row_local, img, j, &
849 : j_col_local, n_basis, ncol_local, &
850 : nimages, nrow_local
851 424 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
852 : LOGICAL :: my_add
853 : REAL(KIND=dp) :: my_weight, S_ij
854 :
855 424 : CALL timeset(routineN, handle)
856 :
857 424 : my_weight = 1.0_dp
858 424 : IF (PRESENT(weight)) my_weight = weight
859 :
860 424 : my_add = .FALSE.
861 424 : IF (PRESENT(add)) my_add = add
862 :
863 424 : n_basis = SIZE(array_S, 1)
864 424 : nimages = SIZE(array_S, 3)
865 :
866 : ! checks
867 424 : CPASSERT(SIZE(array_S, 2) == n_basis)
868 424 : CPASSERT(SIZE(fm_S) == nimages)
869 424 : CPASSERT(LBOUND(array_S, 1) == 1)
870 424 : CPASSERT(LBOUND(array_S, 2) == 1)
871 424 : CPASSERT(LBOUND(array_S, 3) == 1)
872 :
873 : CALL cp_fm_get_info(matrix=fm_S(1), &
874 : nrow_local=nrow_local, &
875 : ncol_local=ncol_local, &
876 : row_indices=row_indices, &
877 424 : col_indices=col_indices)
878 :
879 4240 : DO img = 1, nimages
880 :
881 14779 : DO i_row_local = 1, nrow_local
882 :
883 10539 : i = row_indices(i_row_local)
884 :
885 73044 : DO j_col_local = 1, ncol_local
886 :
887 58689 : j = col_indices(j_col_local)
888 :
889 58689 : IF (my_add) THEN
890 : S_ij = fm_S(img)%local_data(i_row_local, j_col_local) + &
891 57492 : array_S(i, j, img)*my_weight
892 : ELSE
893 1197 : S_ij = array_S(i, j, img)*my_weight
894 : END IF
895 69228 : fm_S(img)%local_data(i_row_local, j_col_local) = S_ij
896 :
897 : END DO ! j_col_local
898 :
899 : END DO ! i_row_local
900 :
901 : END DO ! img
902 :
903 424 : CALL timestop(handle)
904 :
905 424 : END SUBROUTINE local_array_to_fm
906 :
907 : ! **************************************************************************************************
908 : !> \brief ...
909 : !> \param t_R ...
910 : !> \param fm_R ...
911 : !> \param mat_global ...
912 : !> \param mat_local ...
913 : !> \param bs_env ...
914 : ! **************************************************************************************************
915 176 : SUBROUTINE local_dbt_to_global_fm(t_R, fm_R, mat_global, mat_local, bs_env)
916 : TYPE(dbt_type), DIMENSION(:) :: t_R
917 : TYPE(cp_fm_type), DIMENSION(:) :: fm_R
918 : TYPE(dbcsr_p_type) :: mat_global, mat_local
919 : TYPE(post_scf_bandstructure_type), POINTER :: bs_env
920 :
921 : CHARACTER(LEN=*), PARAMETER :: routineN = 'local_dbt_to_global_fm'
922 :
923 : INTEGER :: handle, i_cell, n_images
924 :
925 176 : CALL timeset(routineN, handle)
926 :
927 176 : n_images = SIZE(t_R)
928 :
929 176 : CPASSERT(n_images == SIZE(fm_R))
930 :
931 1760 : DO i_cell = 1, n_images
932 1584 : CALL dbcsr_set(mat_global%matrix, 0.0_dp)
933 1584 : CALL dbcsr_set(mat_local%matrix, 0.0_dp)
934 : CALL local_dbt_to_global_mat(t_R(i_cell), mat_local%matrix, mat_global%matrix, &
935 1584 : bs_env%para_env)
936 1760 : CALL copy_dbcsr_to_fm(mat_global%matrix, fm_R(i_cell))
937 : END DO
938 :
939 176 : CALL timestop(handle)
940 :
941 176 : END SUBROUTINE local_dbt_to_global_fm
942 :
943 0 : END MODULE gw_communication
|
