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
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
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 3344 : 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 30096 : TYPE(dbt_type) :: tensor_tmp
78 :
79 3344 : CALL timeset(routineN, handle)
80 :
81 3344 : CALL dbt_clear(tensor)
82 3344 : CALL copy_fm_to_dbcsr(fm_global, mat_global, keep_sparsity=.FALSE.)
83 3344 : CALL dbcsr_filter(mat_global, bs_env%eps_filter)
84 3344 : IF (PRESENT(atom_ranges)) THEN
85 : CALL global_matrix_to_local_matrix(mat_global, mat_local, bs_env%para_env, &
86 1256 : 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 2088 : bs_env%para_env_tensor%num_pe)
90 : END IF
91 3344 : CALL dbt_create(mat_local, tensor_tmp)
92 3344 : CALL dbt_copy_matrix_to_tensor(mat_local, tensor_tmp)
93 3344 : CALL dbt_copy(tensor_tmp, tensor, move_data=.TRUE.)
94 3344 : CALL dbt_destroy(tensor_tmp)
95 3344 : CALL dbcsr_set(mat_local, 0.0_dp)
96 3344 : CALL dbcsr_filter(mat_local, 1.0_dp)
97 :
98 3344 : CALL timestop(handle)
99 :
100 3344 : 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 1972 : 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 1972 : CALL timeset(routineN, handle)
120 :
121 1972 : CALL dbt_copy_tensor_to_matrix(tensor, mat_tensor)
122 1972 : 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 1972 : CALL para_env%sync()
126 1972 : CALL local_matrix_to_global_matrix(mat_tensor, mat_global, para_env)
127 :
128 1972 : CALL timestop(handle)
129 :
130 1972 : 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 3344 : 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 3344 : INTEGER, ALLOCATABLE, DIMENSION(:) :: blk_counter, cols_to_alloc, entry_counter, &
153 3344 : num_entries_blocks_rec, num_entries_blocks_send, row_block_from_index, rows_to_alloc, &
154 3344 : sizes_rec, sizes_send
155 3344 : INTEGER, DIMENSION(:), POINTER :: row_blk_offset, row_blk_size
156 3344 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
157 3344 : TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
158 : TYPE(dbcsr_iterator_type) :: iter
159 :
160 3344 : CALL timeset(routineN, handle)
161 :
162 3344 : CALL timeset("get_sizes", handle1)
163 :
164 3344 : NULLIFY (data_block)
165 :
166 10032 : ALLOCATE (num_entries_blocks_send(0:2*para_env%num_pe - 1))
167 16720 : num_entries_blocks_send(:) = 0
168 :
169 6688 : ALLOCATE (num_entries_blocks_rec(0:2*para_env%num_pe - 1))
170 16720 : num_entries_blocks_rec(:) = 0
171 :
172 3344 : ngroup = para_env%num_pe/num_pe_sub
173 :
174 3344 : CALL dbcsr_iterator_start(iter, mat_global)
175 9631 : 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 6287 : row_offset=row_offset, col_offset=col_offset)
180 :
181 6287 : CALL dbcsr_get_stored_coordinates(mat_local, row, col, imep_sub)
182 :
183 19471 : DO igroup = 0, ngroup - 1
184 :
185 9840 : IF (PRESENT(atom_ranges)) THEN
186 2734 : IF (row < atom_ranges(1, igroup + 1) .OR. row > atom_ranges(2, igroup + 1)) CYCLE
187 : END IF
188 9840 : imep = imep_sub + igroup*num_pe_sub
189 :
190 9840 : num_entries_blocks_send(2*imep) = num_entries_blocks_send(2*imep) + row_size*col_size
191 16127 : 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 3344 : CALL dbcsr_iterator_stop(iter)
198 :
199 3344 : CALL timestop(handle1)
200 :
201 3344 : CALL timeset("send_sizes_1", handle1)
202 :
203 16720 : total_num_entries = SUM(num_entries_blocks_send)
204 3344 : CALL para_env%sum(total_num_entries)
205 :
206 3344 : CALL timestop(handle1)
207 :
208 3344 : CALL timeset("send_sizes_2", handle1)
209 :
210 3344 : IF (para_env%num_pe > 1) THEN
211 3344 : 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 3344 : CALL timestop(handle1)
217 :
218 3344 : CALL timeset("get_data", handle1)
219 :
220 16720 : ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
221 16720 : ALLOCATE (buffer_send(0:para_env%num_pe - 1))
222 :
223 : ! allocate data message and corresponding indices
224 10032 : DO imep = 0, para_env%num_pe - 1
225 :
226 17356 : ALLOCATE (buffer_rec(imep)%msg(num_entries_blocks_rec(2*imep)))
227 201030 : buffer_rec(imep)%msg = 0.0_dp
228 :
229 17356 : ALLOCATE (buffer_send(imep)%msg(num_entries_blocks_send(2*imep)))
230 201030 : buffer_send(imep)%msg = 0.0_dp
231 :
232 17356 : ALLOCATE (buffer_rec(imep)%indx(num_entries_blocks_rec(2*imep + 1), 3))
233 56272 : buffer_rec(imep)%indx = 0
234 :
235 17356 : ALLOCATE (buffer_send(imep)%indx(num_entries_blocks_send(2*imep + 1), 3))
236 59616 : buffer_send(imep)%indx = 0
237 :
238 : END DO
239 :
240 10032 : ALLOCATE (entry_counter(0:para_env%num_pe - 1))
241 10032 : entry_counter(:) = 0
242 :
243 6688 : ALLOCATE (blk_counter(0:para_env%num_pe - 1))
244 10032 : blk_counter = 0
245 :
246 3344 : CALL dbcsr_iterator_start(iter, mat_global)
247 9631 : 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 6287 : row_offset=row_offset, col_offset=col_offset)
252 :
253 6287 : CALL dbcsr_get_stored_coordinates(mat_local, row, col, imep_sub)
254 :
255 19471 : DO igroup = 0, ngroup - 1
256 :
257 9840 : IF (PRESENT(atom_ranges)) THEN
258 2734 : IF (row < atom_ranges(1, igroup + 1) .OR. row > atom_ranges(2, igroup + 1)) CYCLE
259 : END IF
260 :
261 9840 : imep = imep_sub + igroup*num_pe_sub
262 :
263 9840 : msg_offset = entry_counter(imep)
264 :
265 9840 : block_size = row_size*col_size
266 :
267 : buffer_send(imep)%msg(msg_offset + 1:msg_offset + block_size) = &
268 214022 : RESHAPE(data_block(1:row_size, 1:col_size), (/block_size/))
269 :
270 9840 : entry_counter(imep) = entry_counter(imep) + block_size
271 :
272 9840 : blk_counter(imep) = blk_counter(imep) + 1
273 :
274 9840 : block_offset = blk_counter(imep)
275 :
276 9840 : buffer_send(imep)%indx(block_offset, 1) = row
277 9840 : buffer_send(imep)%indx(block_offset, 2) = col
278 16127 : buffer_send(imep)%indx(block_offset, 3) = msg_offset
279 :
280 : END DO
281 :
282 : END DO
283 :
284 3344 : CALL dbcsr_iterator_stop(iter)
285 :
286 3344 : CALL timestop(handle1)
287 :
288 3344 : CALL timeset("send_data", handle1)
289 :
290 10032 : ALLOCATE (sizes_rec(0:para_env%num_pe - 1))
291 6688 : ALLOCATE (sizes_send(0:para_env%num_pe - 1))
292 :
293 10032 : DO imep = 0, para_env%num_pe - 1
294 6688 : sizes_send(imep) = num_entries_blocks_send(2*imep)
295 10032 : sizes_rec(imep) = num_entries_blocks_rec(2*imep)
296 : END DO
297 :
298 3344 : CALL communicate_buffer(para_env, sizes_rec, sizes_send, buffer_rec, buffer_send)
299 :
300 3344 : CALL timestop(handle1)
301 :
302 3344 : 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 3344 : row_blk_size=row_blk_size)
308 :
309 6688 : ALLOCATE (row_block_from_index(nmo))
310 3344 : row_block_from_index = 0
311 :
312 3344 : DO i_entry = 1, nmo
313 3344 : 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 3344 : CALL timestop(handle1)
326 :
327 3344 : CALL timeset("reserve_blocks", handle1)
328 :
329 3344 : num_blocks = 0
330 :
331 : ! get the number of blocks, which have to be allocated
332 10032 : DO imep = 0, para_env%num_pe - 1
333 10032 : num_blocks = num_blocks + num_entries_blocks_rec(2*imep + 1)
334 : END DO
335 :
336 9398 : ALLOCATE (rows_to_alloc(num_blocks))
337 13184 : rows_to_alloc = 0
338 :
339 6054 : ALLOCATE (cols_to_alloc(num_blocks))
340 13184 : cols_to_alloc = 0
341 :
342 : block_counter = 0
343 :
344 10032 : DO i_mepos = 0, para_env%num_pe - 1
345 :
346 19872 : DO i_block = 1, num_entries_blocks_rec(2*i_mepos + 1)
347 :
348 9840 : block_counter = block_counter + 1
349 :
350 9840 : rows_to_alloc(block_counter) = buffer_rec(i_mepos)%indx(i_block, 1)
351 16528 : cols_to_alloc(block_counter) = buffer_rec(i_mepos)%indx(i_block, 2)
352 :
353 : END DO
354 :
355 : END DO
356 :
357 3344 : CALL dbcsr_set(mat_local, 0.0_dp)
358 3344 : CALL dbcsr_filter(mat_local, 1.0_dp)
359 3344 : CALL dbcsr_reserve_blocks(mat_local, rows=rows_to_alloc(:), cols=cols_to_alloc(:))
360 3344 : CALL dbcsr_finalize(mat_local)
361 3344 : CALL dbcsr_set(mat_local, 0.0_dp)
362 :
363 3344 : CALL timestop(handle1)
364 :
365 3344 : CALL timeset("fill_mat_local", handle1)
366 :
367 3344 : CALL dbcsr_iterator_start(iter, mat_local)
368 :
369 13184 : DO WHILE (dbcsr_iterator_blocks_left(iter))
370 :
371 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
372 9840 : row_size=row_size, col_size=col_size)
373 :
374 32864 : DO imep = 0, para_env%num_pe - 1
375 :
376 79384 : DO i_block = 1, num_entries_blocks_rec(2*imep + 1)
377 :
378 49864 : row_from_buffer = buffer_rec(imep)%indx(i_block, 1)
379 49864 : col_from_buffer = buffer_rec(imep)%indx(i_block, 2)
380 49864 : offset = buffer_rec(imep)%indx(i_block, 3)
381 :
382 69544 : 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 262234 : (/row_size, col_size/))
387 :
388 : END IF
389 :
390 : END DO
391 :
392 : END DO
393 :
394 : END DO ! blocks
395 :
396 3344 : CALL dbcsr_iterator_stop(iter)
397 :
398 3344 : CALL timestop(handle1)
399 :
400 10032 : DO imep = 0, para_env%num_pe - 1
401 6688 : DEALLOCATE (buffer_rec(imep)%msg)
402 6688 : DEALLOCATE (buffer_rec(imep)%indx)
403 6688 : DEALLOCATE (buffer_send(imep)%msg)
404 10032 : DEALLOCATE (buffer_send(imep)%indx)
405 : END DO
406 :
407 3344 : CALL timestop(handle)
408 :
409 36784 : 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 3344 : 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 3344 : TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req
434 :
435 3344 : CALL timeset(routineN, handle)
436 :
437 3344 : NULLIFY (req)
438 53504 : ALLOCATE (req(1:para_env%num_pe, 4))
439 :
440 3344 : my_do_indx = .TRUE.
441 3344 : IF (PRESENT(do_indx)) my_do_indx = do_indx
442 3344 : my_do_msg = .TRUE.
443 3344 : IF (PRESENT(do_msg)) my_do_msg = do_msg
444 :
445 3344 : IF (para_env%num_pe > 1) THEN
446 :
447 3344 : send_counter = 0
448 3344 : rec_counter = 0
449 :
450 10032 : DO imep = 0, para_env%num_pe - 1
451 10032 : IF (num_entries_rec(imep) > 0) THEN
452 3980 : rec_counter = rec_counter + 1
453 3980 : IF (my_do_indx) THEN
454 3980 : CALL para_env%irecv(buffer_rec(imep)%indx, imep, req(rec_counter, 3), tag=4)
455 : END IF
456 3980 : IF (my_do_msg) THEN
457 3980 : 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 10032 : DO imep = 0, para_env%num_pe - 1
463 10032 : IF (num_entries_send(imep) > 0) THEN
464 3980 : send_counter = send_counter + 1
465 3980 : IF (my_do_indx) THEN
466 3980 : CALL para_env%isend(buffer_send(imep)%indx, imep, req(send_counter, 1), tag=4)
467 : END IF
468 3980 : IF (my_do_msg) THEN
469 3980 : 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 3344 : IF (my_do_indx) THEN
475 3344 : CALL mp_waitall(req(1:send_counter, 1))
476 3344 : CALL mp_waitall(req(1:rec_counter, 3))
477 : END IF
478 :
479 3344 : IF (my_do_msg) THEN
480 3344 : CALL mp_waitall(req(1:send_counter, 2))
481 3344 : 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 3344 : DEALLOCATE (req)
492 :
493 3344 : CALL timestop(handle)
494 :
495 3344 : END SUBROUTINE communicate_buffer
496 :
497 : ! **************************************************************************************************
498 : !> \brief ...
499 : !> \param mat_local ...
500 : !> \param mat_global ...
501 : !> \param para_env ...
502 : ! **************************************************************************************************
503 1972 : 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 1972 : INTEGER, ALLOCATABLE, DIMENSION(:) :: block_counter, entry_counter, num_blocks_rec, &
515 1972 : num_blocks_send, num_entries_rec, num_entries_send, sizes_rec, sizes_send
516 1972 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
517 1972 : TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
518 : TYPE(dbcsr_iterator_type) :: iter
519 : TYPE(dbcsr_type) :: mat_global_copy
520 1972 : TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req
521 :
522 1972 : CALL timeset(routineN, handle)
523 :
524 1972 : CALL timeset("get_coord", handle1)
525 :
526 1972 : CALL dbcsr_create(mat_global_copy, template=mat_global)
527 1972 : CALL dbcsr_reserve_all_blocks(mat_global_copy)
528 :
529 1972 : CALL dbcsr_set(mat_global, 0.0_dp)
530 1972 : CALL dbcsr_set(mat_global_copy, 0.0_dp)
531 :
532 11832 : ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
533 9860 : ALLOCATE (buffer_send(0:para_env%num_pe - 1))
534 :
535 5916 : ALLOCATE (num_entries_rec(0:para_env%num_pe - 1))
536 3944 : ALLOCATE (num_blocks_rec(0:para_env%num_pe - 1))
537 3944 : ALLOCATE (num_entries_send(0:para_env%num_pe - 1))
538 3944 : ALLOCATE (num_blocks_send(0:para_env%num_pe - 1))
539 5916 : num_entries_rec = 0
540 5916 : num_blocks_rec = 0
541 5916 : num_entries_send = 0
542 5916 : num_blocks_send = 0
543 :
544 1972 : CALL dbcsr_iterator_start(iter, mat_local)
545 5090 : DO WHILE (dbcsr_iterator_blocks_left(iter))
546 :
547 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
548 3118 : row_size=row_size, col_size=col_size)
549 :
550 3118 : CALL dbcsr_get_stored_coordinates(mat_global, row, col, imep)
551 :
552 3118 : num_entries_send(imep) = num_entries_send(imep) + row_size*col_size
553 3118 : num_blocks_send(imep) = num_blocks_send(imep) + 1
554 :
555 : END DO
556 :
557 1972 : CALL dbcsr_iterator_stop(iter)
558 :
559 1972 : CALL timestop(handle1)
560 :
561 1972 : CALL timeset("comm_size", handle1)
562 :
563 1972 : IF (para_env%num_pe > 1) THEN
564 :
565 5916 : ALLOCATE (sizes_rec(0:2*para_env%num_pe - 1))
566 3944 : ALLOCATE (sizes_send(0:2*para_env%num_pe - 1))
567 :
568 5916 : DO imep = 0, para_env%num_pe - 1
569 :
570 3944 : sizes_send(2*imep) = num_entries_send(imep)
571 5916 : sizes_send(2*imep + 1) = num_blocks_send(imep)
572 :
573 : END DO
574 :
575 1972 : CALL para_env%alltoall(sizes_send, sizes_rec, 2)
576 :
577 5916 : DO imep = 0, para_env%num_pe - 1
578 3944 : num_entries_rec(imep) = sizes_rec(2*imep)
579 5916 : num_blocks_rec(imep) = sizes_rec(2*imep + 1)
580 : END DO
581 :
582 1972 : 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 1972 : CALL timestop(handle1)
592 :
593 1972 : CALL timeset("fill_buffer", handle1)
594 :
595 : ! allocate data message and corresponding indices
596 5916 : DO imep = 0, para_env%num_pe - 1
597 :
598 9448 : ALLOCATE (buffer_rec(imep)%msg(num_entries_rec(imep)))
599 82403 : buffer_rec(imep)%msg = 0.0_dp
600 :
601 9448 : ALLOCATE (buffer_send(imep)%msg(num_entries_send(imep)))
602 82403 : buffer_send(imep)%msg = 0.0_dp
603 :
604 9448 : ALLOCATE (buffer_rec(imep)%indx(num_blocks_rec(imep), 5))
605 39254 : buffer_rec(imep)%indx = 0
606 :
607 9448 : ALLOCATE (buffer_send(imep)%indx(num_blocks_send(imep), 5))
608 41226 : buffer_send(imep)%indx = 0
609 :
610 : END DO
611 :
612 5916 : ALLOCATE (block_counter(0:para_env%num_pe - 1))
613 5916 : block_counter(:) = 0
614 :
615 3944 : ALLOCATE (entry_counter(0:para_env%num_pe - 1))
616 5916 : entry_counter(:) = 0
617 :
618 : ! fill buffer_send
619 1972 : CALL dbcsr_iterator_start(iter, mat_local)
620 5090 : DO WHILE (dbcsr_iterator_blocks_left(iter))
621 :
622 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
623 3118 : row_size=row_size, col_size=col_size)
624 :
625 3118 : CALL dbcsr_get_stored_coordinates(mat_global, row, col, imep)
626 :
627 3118 : block_size = row_size*col_size
628 :
629 3118 : offset = entry_counter(imep)
630 :
631 : buffer_send(imep)%msg(offset + 1:offset + block_size) = &
632 84695 : RESHAPE(data_block(1:row_size, 1:col_size), (/block_size/))
633 :
634 3118 : i_block = block_counter(imep) + 1
635 :
636 3118 : buffer_send(imep)%indx(i_block, 1) = row
637 3118 : buffer_send(imep)%indx(i_block, 2) = col
638 3118 : buffer_send(imep)%indx(i_block, 3) = offset
639 :
640 3118 : entry_counter(imep) = entry_counter(imep) + block_size
641 :
642 3118 : block_counter(imep) = block_counter(imep) + 1
643 :
644 : END DO
645 :
646 1972 : CALL dbcsr_iterator_stop(iter)
647 :
648 1972 : CALL timestop(handle1)
649 :
650 1972 : CALL timeset("comm_data", handle1)
651 :
652 1972 : NULLIFY (req)
653 31552 : ALLOCATE (req(1:para_env%num_pe, 4))
654 :
655 1972 : IF (para_env%num_pe > 1) THEN
656 :
657 1972 : send_counter = 0
658 1972 : rec_counter = 0
659 :
660 5916 : DO imep = 0, para_env%num_pe - 1
661 3944 : IF (num_entries_rec(imep) > 0) THEN
662 1560 : rec_counter = rec_counter + 1
663 1560 : CALL para_env%irecv(buffer_rec(imep)%indx, imep, req(rec_counter, 3), tag=4)
664 : END IF
665 5916 : IF (num_entries_rec(imep) > 0) THEN
666 1560 : CALL para_env%irecv(buffer_rec(imep)%msg, imep, req(rec_counter, 4), tag=7)
667 : END IF
668 : END DO
669 :
670 5916 : DO imep = 0, para_env%num_pe - 1
671 3944 : IF (num_entries_send(imep) > 0) THEN
672 1560 : send_counter = send_counter + 1
673 1560 : CALL para_env%isend(buffer_send(imep)%indx, imep, req(send_counter, 1), tag=4)
674 : END IF
675 5916 : IF (num_entries_send(imep) > 0) THEN
676 1560 : CALL para_env%isend(buffer_send(imep)%msg, imep, req(send_counter, 2), tag=7)
677 : END IF
678 : END DO
679 :
680 1972 : CALL mp_waitall(req(1:send_counter, 1:2))
681 1972 : 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 1972 : CALL timestop(handle1)
691 :
692 1972 : CALL timeset("set_blocks", handle1)
693 :
694 : ! fill mat_global_copy
695 1972 : CALL dbcsr_iterator_start(iter, mat_global_copy)
696 7816 : DO WHILE (dbcsr_iterator_blocks_left(iter))
697 :
698 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
699 5844 : row_size=row_size, col_size=col_size)
700 :
701 19504 : DO imep = 0, para_env%num_pe - 1
702 :
703 29046 : DO i_block = 1, num_blocks_rec(imep)
704 :
705 11514 : IF (row == buffer_rec(imep)%indx(i_block, 1) .AND. &
706 11688 : col == buffer_rec(imep)%indx(i_block, 2)) THEN
707 :
708 3118 : offset = buffer_rec(imep)%indx(i_block, 3)
709 :
710 3118 : r = row_size
711 3118 : c = col_size
712 3118 : o = offset
713 :
714 : data_block(1:r, 1:c) = data_block(1:r, 1:c) + &
715 100301 : 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 1972 : CALL dbcsr_iterator_stop(iter)
726 :
727 1972 : CALL dbcsr_copy(mat_global, mat_global_copy)
728 :
729 1972 : CALL dbcsr_release(mat_global_copy)
730 :
731 : ! remove the blocks which are exactly zero from mat_global
732 1972 : CALL dbcsr_filter(mat_global, 1.0E-30_dp)
733 :
734 5916 : DO imep = 0, para_env%num_pe - 1
735 3944 : DEALLOCATE (buffer_rec(imep)%msg)
736 3944 : DEALLOCATE (buffer_send(imep)%msg)
737 3944 : DEALLOCATE (buffer_rec(imep)%indx)
738 5916 : DEALLOCATE (buffer_send(imep)%indx)
739 : END DO
740 :
741 1972 : DEALLOCATE (buffer_rec, buffer_send)
742 :
743 1972 : DEALLOCATE (block_counter, entry_counter)
744 :
745 1972 : DEALLOCATE (req)
746 :
747 1972 : CALL dbcsr_set(mat_local, 0.0_dp)
748 1972 : CALL dbcsr_filter(mat_local, 1.0_dp)
749 :
750 1972 : CALL timestop(handle1)
751 :
752 1972 : CALL timestop(handle)
753 :
754 15776 : 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 412 : 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 412 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
776 : LOGICAL :: my_add
777 : REAL(KIND=dp) :: my_weight
778 412 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: array_tmp
779 :
780 412 : CALL timeset(routineN, handle)
781 :
782 412 : my_weight = 1.0_dp
783 412 : IF (PRESENT(weight)) my_weight = weight
784 :
785 412 : my_add = .FALSE.
786 412 : IF (PRESENT(add)) my_add = add
787 :
788 412 : n_basis = SIZE(array_S, 1)
789 412 : nimages = SIZE(array_S, 3)
790 :
791 : ! checks
792 412 : CPASSERT(SIZE(array_S, 2) == n_basis)
793 412 : CPASSERT(SIZE(fm_S) == nimages)
794 412 : CPASSERT(LBOUND(array_S, 1) == 1)
795 412 : CPASSERT(LBOUND(array_S, 2) == 1)
796 412 : 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 412 : col_indices=col_indices)
803 :
804 23704 : IF (.NOT. my_add) array_S(:, :, :) = 0.0_dp
805 2060 : ALLOCATE (array_tmp(SIZE(array_S, 1), SIZE(array_S, 2), SIZE(array_S, 3)))
806 135232 : array_tmp(:, :, :) = 0.0_dp
807 :
808 4120 : DO img = 1, nimages
809 14218 : DO i_row_local = 1, nrow_local
810 :
811 10098 : i = row_indices(i_row_local)
812 :
813 69264 : DO j_col_local = 1, ncol_local
814 :
815 55458 : j = col_indices(j_col_local)
816 :
817 65556 : 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 412 : CALL fm_S(1)%matrix_struct%para_env%sync()
824 412 : CALL fm_S(1)%matrix_struct%para_env%sum(array_tmp)
825 412 : CALL fm_S(1)%matrix_struct%para_env%sync()
826 :
827 135232 : array_S(:, :, :) = array_S(:, :, :) + my_weight*array_tmp(:, :, :)
828 :
829 412 : CALL timestop(handle)
830 :
831 1236 : 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 350 : 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 350 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
852 : LOGICAL :: my_add
853 : REAL(KIND=dp) :: my_weight, S_ij
854 :
855 350 : CALL timeset(routineN, handle)
856 :
857 350 : my_weight = 1.0_dp
858 350 : IF (PRESENT(weight)) my_weight = weight
859 :
860 350 : my_add = .FALSE.
861 350 : IF (PRESENT(add)) my_add = add
862 :
863 350 : n_basis = SIZE(array_S, 1)
864 350 : nimages = SIZE(array_S, 3)
865 :
866 : ! checks
867 350 : CPASSERT(SIZE(array_S, 2) == n_basis)
868 350 : CPASSERT(SIZE(fm_S) == nimages)
869 350 : CPASSERT(LBOUND(array_S, 1) == 1)
870 350 : CPASSERT(LBOUND(array_S, 2) == 1)
871 350 : 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 350 : col_indices=col_indices)
878 :
879 3500 : DO img = 1, nimages
880 :
881 12041 : DO i_row_local = 1, nrow_local
882 :
883 8541 : i = row_indices(i_row_local)
884 :
885 58392 : DO j_col_local = 1, ncol_local
886 :
887 46701 : j = col_indices(j_col_local)
888 :
889 46701 : IF (my_add) THEN
890 : S_ij = fm_S(img)%local_data(i_row_local, j_col_local) + &
891 45828 : array_S(i, j, img)*my_weight
892 : ELSE
893 873 : S_ij = array_S(i, j, img)*my_weight
894 : END IF
895 55242 : 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 350 : CALL timestop(handle)
904 :
905 350 : 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 138 : 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 138 : CALL timeset(routineN, handle)
926 :
927 138 : n_images = SIZE(t_R)
928 :
929 138 : CPASSERT(n_images == SIZE(fm_R))
930 :
931 1380 : DO i_cell = 1, n_images
932 1242 : CALL dbcsr_set(mat_global%matrix, 0.0_dp)
933 1242 : 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 1242 : bs_env%para_env)
936 1380 : CALL copy_dbcsr_to_fm(mat_global%matrix, fm_R(i_cell))
937 : END DO
938 :
939 138 : CALL timestop(handle)
940 :
941 138 : END SUBROUTINE local_dbt_to_global_fm
942 :
943 0 : END MODULE gw_communication
|
