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