(git:ed6f26b)
Loading...
Searching...
No Matches
gw_communication.F
Go to the documentation of this file.
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! **************************************************************************************************
13MODULE 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
55CONTAINS
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 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 TYPE(dbt_type) :: tensor_tmp
78
79 CALL timeset(routinen, handle)
80
81 CALL dbt_clear(tensor)
82 CALL copy_fm_to_dbcsr(fm_global, mat_global, keep_sparsity=.false.)
83 CALL dbcsr_filter(mat_global, bs_env%eps_filter)
84 IF (PRESENT(atom_ranges)) THEN
85 CALL global_matrix_to_local_matrix(mat_global, mat_local, bs_env%para_env, &
86 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 bs_env%para_env_tensor%num_pe)
90 END IF
91 CALL dbt_create(mat_local, tensor_tmp)
92 CALL dbt_copy_matrix_to_tensor(mat_local, tensor_tmp)
93 CALL dbt_copy(tensor_tmp, tensor, move_data=.true.)
94 CALL dbt_destroy(tensor_tmp)
95 CALL dbcsr_set(mat_local, 0.0_dp)
96 CALL dbcsr_filter(mat_local, 1.0_dp)
97
98 CALL timestop(handle)
99
100 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 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 CALL timeset(routinen, handle)
120
121 CALL dbt_copy_tensor_to_matrix(tensor, mat_tensor)
122 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 CALL para_env%sync()
126 CALL local_matrix_to_global_matrix(mat_tensor, mat_global, para_env)
127
128 CALL timestop(handle)
129
130 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: blk_counter, cols_to_alloc, entry_counter, &
153 num_entries_blocks_rec, num_entries_blocks_send, row_block_from_index, rows_to_alloc, &
154 sizes_rec, sizes_send
155 INTEGER, DIMENSION(:), POINTER :: row_blk_offset, row_blk_size
156 REAL(kind=dp), DIMENSION(:, :), POINTER :: data_block
157 TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
158 TYPE(dbcsr_iterator_type) :: iter
159
160 CALL timeset(routinen, handle)
161
162 CALL timeset("get_sizes", handle1)
163
164 NULLIFY (data_block)
165
166 ALLOCATE (num_entries_blocks_send(0:2*para_env%num_pe - 1))
167 num_entries_blocks_send(:) = 0
168
169 ALLOCATE (num_entries_blocks_rec(0:2*para_env%num_pe - 1))
170 num_entries_blocks_rec(:) = 0
171
172 ngroup = para_env%num_pe/num_pe_sub
173
174 CALL dbcsr_iterator_start(iter, mat_global)
175 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 row_offset=row_offset, col_offset=col_offset)
180
181 CALL dbcsr_get_stored_coordinates(mat_local, row, col, imep_sub)
182
183 DO igroup = 0, ngroup - 1
184
185 IF (PRESENT(atom_ranges)) THEN
186 IF (row < atom_ranges(1, igroup + 1) .OR. row > atom_ranges(2, igroup + 1)) cycle
187 END IF
188 imep = imep_sub + igroup*num_pe_sub
189
190 num_entries_blocks_send(2*imep) = num_entries_blocks_send(2*imep) + row_size*col_size
191 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 CALL dbcsr_iterator_stop(iter)
198
199 CALL timestop(handle1)
200
201 CALL timeset("send_sizes_1", handle1)
202
203 total_num_entries = sum(num_entries_blocks_send)
204 CALL para_env%sum(total_num_entries)
205
206 CALL timestop(handle1)
207
208 CALL timeset("send_sizes_2", handle1)
209
210 IF (para_env%num_pe > 1) THEN
211 CALL para_env%alltoall(num_entries_blocks_send, num_entries_blocks_rec, 2)
212 ELSE
213 num_entries_blocks_rec(0:1) = num_entries_blocks_send(0:1)
214 END IF
215
216 CALL timestop(handle1)
217
218 CALL timeset("get_data", handle1)
219
220 ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
221 ALLOCATE (buffer_send(0:para_env%num_pe - 1))
222
223 ! allocate data message and corresponding indices
224 DO imep = 0, para_env%num_pe - 1
225
226 ALLOCATE (buffer_rec(imep)%msg(num_entries_blocks_rec(2*imep)))
227 buffer_rec(imep)%msg = 0.0_dp
228
229 ALLOCATE (buffer_send(imep)%msg(num_entries_blocks_send(2*imep)))
230 buffer_send(imep)%msg = 0.0_dp
231
232 ALLOCATE (buffer_rec(imep)%indx(num_entries_blocks_rec(2*imep + 1), 3))
233 buffer_rec(imep)%indx = 0
234
235 ALLOCATE (buffer_send(imep)%indx(num_entries_blocks_send(2*imep + 1), 3))
236 buffer_send(imep)%indx = 0
237
238 END DO
239
240 ALLOCATE (entry_counter(0:para_env%num_pe - 1))
241 entry_counter(:) = 0
242
243 ALLOCATE (blk_counter(0:para_env%num_pe - 1))
244 blk_counter = 0
245
246 CALL dbcsr_iterator_start(iter, mat_global)
247 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 row_offset=row_offset, col_offset=col_offset)
252
253 CALL dbcsr_get_stored_coordinates(mat_local, row, col, imep_sub)
254
255 DO igroup = 0, ngroup - 1
256
257 IF (PRESENT(atom_ranges)) THEN
258 IF (row < atom_ranges(1, igroup + 1) .OR. row > atom_ranges(2, igroup + 1)) cycle
259 END IF
260
261 imep = imep_sub + igroup*num_pe_sub
262
263 msg_offset = entry_counter(imep)
264
265 block_size = row_size*col_size
266
267 buffer_send(imep)%msg(msg_offset + 1:msg_offset + block_size) = &
268 reshape(data_block(1:row_size, 1:col_size), (/block_size/))
269
270 entry_counter(imep) = entry_counter(imep) + block_size
271
272 blk_counter(imep) = blk_counter(imep) + 1
273
274 block_offset = blk_counter(imep)
275
276 buffer_send(imep)%indx(block_offset, 1) = row
277 buffer_send(imep)%indx(block_offset, 2) = col
278 buffer_send(imep)%indx(block_offset, 3) = msg_offset
279
280 END DO
281
282 END DO
283
284 CALL dbcsr_iterator_stop(iter)
285
286 CALL timestop(handle1)
287
288 CALL timeset("send_data", handle1)
289
290 ALLOCATE (sizes_rec(0:para_env%num_pe - 1))
291 ALLOCATE (sizes_send(0:para_env%num_pe - 1))
292
293 DO imep = 0, para_env%num_pe - 1
294 sizes_send(imep) = num_entries_blocks_send(2*imep)
295 sizes_rec(imep) = num_entries_blocks_rec(2*imep)
296 END DO
297
298 CALL communicate_buffer(para_env, sizes_rec, sizes_send, buffer_rec, buffer_send)
299
300 CALL timestop(handle1)
301
302 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 row_blk_size=row_blk_size)
308
309 ALLOCATE (row_block_from_index(nmo))
310 row_block_from_index = 0
311
312 DO i_entry = 1, nmo
313 DO i_block = 1, nblkrows_total
314
315 IF (i_entry >= row_blk_offset(i_block) .AND. &
316 i_entry <= row_blk_offset(i_block) + row_blk_size(i_block) - 1) THEN
317
318 row_block_from_index(i_entry) = i_block
319
320 END IF
321
322 END DO
323 END DO
324
325 CALL timestop(handle1)
326
327 CALL timeset("reserve_blocks", handle1)
328
329 num_blocks = 0
330
331 ! get the number of blocks, which have to be allocated
332 DO imep = 0, para_env%num_pe - 1
333 num_blocks = num_blocks + num_entries_blocks_rec(2*imep + 1)
334 END DO
335
336 ALLOCATE (rows_to_alloc(num_blocks))
337 rows_to_alloc = 0
338
339 ALLOCATE (cols_to_alloc(num_blocks))
340 cols_to_alloc = 0
341
342 block_counter = 0
343
344 DO i_mepos = 0, para_env%num_pe - 1
345
346 DO i_block = 1, num_entries_blocks_rec(2*i_mepos + 1)
347
348 block_counter = block_counter + 1
349
350 rows_to_alloc(block_counter) = buffer_rec(i_mepos)%indx(i_block, 1)
351 cols_to_alloc(block_counter) = buffer_rec(i_mepos)%indx(i_block, 2)
352
353 END DO
354
355 END DO
356
357 CALL dbcsr_set(mat_local, 0.0_dp)
358 CALL dbcsr_filter(mat_local, 1.0_dp)
359 CALL dbcsr_reserve_blocks(mat_local, rows=rows_to_alloc(:), cols=cols_to_alloc(:))
360 CALL dbcsr_finalize(mat_local)
361 CALL dbcsr_set(mat_local, 0.0_dp)
362
363 CALL timestop(handle1)
364
365 CALL timeset("fill_mat_local", handle1)
366
367 CALL dbcsr_iterator_start(iter, mat_local)
368
369 DO WHILE (dbcsr_iterator_blocks_left(iter))
370
371 CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
372 row_size=row_size, col_size=col_size)
373
374 DO imep = 0, para_env%num_pe - 1
375
376 DO i_block = 1, num_entries_blocks_rec(2*imep + 1)
377
378 row_from_buffer = buffer_rec(imep)%indx(i_block, 1)
379 col_from_buffer = buffer_rec(imep)%indx(i_block, 2)
380 offset = buffer_rec(imep)%indx(i_block, 3)
381
382 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 (/row_size, col_size/))
387
388 END IF
389
390 END DO
391
392 END DO
393
394 END DO ! blocks
395
396 CALL dbcsr_iterator_stop(iter)
397
398 CALL timestop(handle1)
399
400 DO imep = 0, para_env%num_pe - 1
401 DEALLOCATE (buffer_rec(imep)%msg)
402 DEALLOCATE (buffer_rec(imep)%indx)
403 DEALLOCATE (buffer_send(imep)%msg)
404 DEALLOCATE (buffer_send(imep)%indx)
405 END DO
406
407 CALL timestop(handle)
408
409 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 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 TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req
434
435 CALL timeset(routinen, handle)
436
437 NULLIFY (req)
438 ALLOCATE (req(1:para_env%num_pe, 4))
439
440 my_do_indx = .true.
441 IF (PRESENT(do_indx)) my_do_indx = do_indx
442 my_do_msg = .true.
443 IF (PRESENT(do_msg)) my_do_msg = do_msg
444
445 IF (para_env%num_pe > 1) THEN
446
447 send_counter = 0
448 rec_counter = 0
449
450 DO imep = 0, para_env%num_pe - 1
451 IF (num_entries_rec(imep) > 0) THEN
452 rec_counter = rec_counter + 1
453 IF (my_do_indx) THEN
454 CALL para_env%irecv(buffer_rec(imep)%indx, imep, req(rec_counter, 3), tag=4)
455 END IF
456 IF (my_do_msg) THEN
457 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 DO imep = 0, para_env%num_pe - 1
463 IF (num_entries_send(imep) > 0) THEN
464 send_counter = send_counter + 1
465 IF (my_do_indx) THEN
466 CALL para_env%isend(buffer_send(imep)%indx, imep, req(send_counter, 1), tag=4)
467 END IF
468 IF (my_do_msg) THEN
469 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 IF (my_do_indx) THEN
475 CALL mp_waitall(req(1:send_counter, 1))
476 CALL mp_waitall(req(1:rec_counter, 3))
477 END IF
478
479 IF (my_do_msg) THEN
480 CALL mp_waitall(req(1:send_counter, 2))
481 CALL mp_waitall(req(1:rec_counter, 4))
482 END IF
483
484 ELSE
485
486 buffer_rec(0)%indx = buffer_send(0)%indx
487 buffer_rec(0)%msg = buffer_send(0)%msg
488
489 END IF
490
491 DEALLOCATE (req)
492
493 CALL timestop(handle)
494
495 END SUBROUTINE communicate_buffer
496
497! **************************************************************************************************
498!> \brief ...
499!> \param mat_local ...
500!> \param mat_global ...
501!> \param para_env ...
502! **************************************************************************************************
503 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: block_counter, entry_counter, num_blocks_rec, &
515 num_blocks_send, num_entries_rec, num_entries_send, sizes_rec, sizes_send
516 REAL(kind=dp), DIMENSION(:, :), POINTER :: data_block
517 TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
518 TYPE(dbcsr_iterator_type) :: iter
519 TYPE(dbcsr_type) :: mat_global_copy
520 TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req
521
522 CALL timeset(routinen, handle)
523
524 CALL timeset("get_coord", handle1)
525
526 CALL dbcsr_create(mat_global_copy, template=mat_global)
527 CALL dbcsr_reserve_all_blocks(mat_global_copy)
528
529 CALL dbcsr_set(mat_global, 0.0_dp)
530 CALL dbcsr_set(mat_global_copy, 0.0_dp)
531
532 ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
533 ALLOCATE (buffer_send(0:para_env%num_pe - 1))
534
535 ALLOCATE (num_entries_rec(0:para_env%num_pe - 1))
536 ALLOCATE (num_blocks_rec(0:para_env%num_pe - 1))
537 ALLOCATE (num_entries_send(0:para_env%num_pe - 1))
538 ALLOCATE (num_blocks_send(0:para_env%num_pe - 1))
539 num_entries_rec = 0
540 num_blocks_rec = 0
541 num_entries_send = 0
542 num_blocks_send = 0
543
544 CALL dbcsr_iterator_start(iter, mat_local)
545 DO WHILE (dbcsr_iterator_blocks_left(iter))
546
547 CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
548 row_size=row_size, col_size=col_size)
549
550 CALL dbcsr_get_stored_coordinates(mat_global, row, col, imep)
551
552 num_entries_send(imep) = num_entries_send(imep) + row_size*col_size
553 num_blocks_send(imep) = num_blocks_send(imep) + 1
554
555 END DO
556
557 CALL dbcsr_iterator_stop(iter)
558
559 CALL timestop(handle1)
560
561 CALL timeset("comm_size", handle1)
562
563 IF (para_env%num_pe > 1) THEN
564
565 ALLOCATE (sizes_rec(0:2*para_env%num_pe - 1))
566 ALLOCATE (sizes_send(0:2*para_env%num_pe - 1))
567
568 DO imep = 0, para_env%num_pe - 1
569
570 sizes_send(2*imep) = num_entries_send(imep)
571 sizes_send(2*imep + 1) = num_blocks_send(imep)
572
573 END DO
574
575 CALL para_env%alltoall(sizes_send, sizes_rec, 2)
576
577 DO imep = 0, para_env%num_pe - 1
578 num_entries_rec(imep) = sizes_rec(2*imep)
579 num_blocks_rec(imep) = sizes_rec(2*imep + 1)
580 END DO
581
582 DEALLOCATE (sizes_rec, sizes_send)
583
584 ELSE
585
586 num_entries_rec(0) = num_entries_send(0)
587 num_blocks_rec(0) = num_blocks_send(0)
588
589 END IF
590
591 CALL timestop(handle1)
592
593 CALL timeset("fill_buffer", handle1)
594
595 ! allocate data message and corresponding indices
596 DO imep = 0, para_env%num_pe - 1
597
598 ALLOCATE (buffer_rec(imep)%msg(num_entries_rec(imep)))
599 buffer_rec(imep)%msg = 0.0_dp
600
601 ALLOCATE (buffer_send(imep)%msg(num_entries_send(imep)))
602 buffer_send(imep)%msg = 0.0_dp
603
604 ALLOCATE (buffer_rec(imep)%indx(num_blocks_rec(imep), 5))
605 buffer_rec(imep)%indx = 0
606
607 ALLOCATE (buffer_send(imep)%indx(num_blocks_send(imep), 5))
608 buffer_send(imep)%indx = 0
609
610 END DO
611
612 ALLOCATE (block_counter(0:para_env%num_pe - 1))
613 block_counter(:) = 0
614
615 ALLOCATE (entry_counter(0:para_env%num_pe - 1))
616 entry_counter(:) = 0
617
618 ! fill buffer_send
619 CALL dbcsr_iterator_start(iter, mat_local)
620 DO WHILE (dbcsr_iterator_blocks_left(iter))
621
622 CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
623 row_size=row_size, col_size=col_size)
624
625 CALL dbcsr_get_stored_coordinates(mat_global, row, col, imep)
626
627 block_size = row_size*col_size
628
629 offset = entry_counter(imep)
630
631 buffer_send(imep)%msg(offset + 1:offset + block_size) = &
632 reshape(data_block(1:row_size, 1:col_size), (/block_size/))
633
634 i_block = block_counter(imep) + 1
635
636 buffer_send(imep)%indx(i_block, 1) = row
637 buffer_send(imep)%indx(i_block, 2) = col
638 buffer_send(imep)%indx(i_block, 3) = offset
639
640 entry_counter(imep) = entry_counter(imep) + block_size
641
642 block_counter(imep) = block_counter(imep) + 1
643
644 END DO
645
646 CALL dbcsr_iterator_stop(iter)
647
648 CALL timestop(handle1)
649
650 CALL timeset("comm_data", handle1)
651
652 NULLIFY (req)
653 ALLOCATE (req(1:para_env%num_pe, 4))
654
655 IF (para_env%num_pe > 1) THEN
656
657 send_counter = 0
658 rec_counter = 0
659
660 DO imep = 0, para_env%num_pe - 1
661 IF (num_entries_rec(imep) > 0) THEN
662 rec_counter = rec_counter + 1
663 CALL para_env%irecv(buffer_rec(imep)%indx, imep, req(rec_counter, 3), tag=4)
664 END IF
665 IF (num_entries_rec(imep) > 0) THEN
666 CALL para_env%irecv(buffer_rec(imep)%msg, imep, req(rec_counter, 4), tag=7)
667 END IF
668 END DO
669
670 DO imep = 0, para_env%num_pe - 1
671 IF (num_entries_send(imep) > 0) THEN
672 send_counter = send_counter + 1
673 CALL para_env%isend(buffer_send(imep)%indx, imep, req(send_counter, 1), tag=4)
674 END IF
675 IF (num_entries_send(imep) > 0) THEN
676 CALL para_env%isend(buffer_send(imep)%msg, imep, req(send_counter, 2), tag=7)
677 END IF
678 END DO
679
680 CALL mp_waitall(req(1:send_counter, 1:2))
681 CALL mp_waitall(req(1:rec_counter, 3:4))
682
683 ELSE
684
685 buffer_rec(0)%indx = buffer_send(0)%indx
686 buffer_rec(0)%msg = buffer_send(0)%msg
687
688 END IF
689
690 CALL timestop(handle1)
691
692 CALL timeset("set_blocks", handle1)
693
694 ! fill mat_global_copy
695 CALL dbcsr_iterator_start(iter, mat_global_copy)
696 DO WHILE (dbcsr_iterator_blocks_left(iter))
697
698 CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
699 row_size=row_size, col_size=col_size)
700
701 DO imep = 0, para_env%num_pe - 1
702
703 DO i_block = 1, num_blocks_rec(imep)
704
705 IF (row == buffer_rec(imep)%indx(i_block, 1) .AND. &
706 col == buffer_rec(imep)%indx(i_block, 2)) THEN
707
708 offset = buffer_rec(imep)%indx(i_block, 3)
709
710 r = row_size
711 c = col_size
712 o = offset
713
714 data_block(1:r, 1:c) = data_block(1:r, 1:c) + &
715 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 CALL dbcsr_iterator_stop(iter)
726
727 CALL dbcsr_copy(mat_global, mat_global_copy)
728
729 CALL dbcsr_release(mat_global_copy)
730
731 ! remove the blocks which are exactly zero from mat_global
732 CALL dbcsr_filter(mat_global, 1.0e-30_dp)
733
734 DO imep = 0, para_env%num_pe - 1
735 DEALLOCATE (buffer_rec(imep)%msg)
736 DEALLOCATE (buffer_send(imep)%msg)
737 DEALLOCATE (buffer_rec(imep)%indx)
738 DEALLOCATE (buffer_send(imep)%indx)
739 END DO
740
741 DEALLOCATE (buffer_rec, buffer_send)
742
743 DEALLOCATE (block_counter, entry_counter)
744
745 DEALLOCATE (req)
746
747 CALL dbcsr_set(mat_local, 0.0_dp)
748 CALL dbcsr_filter(mat_local, 1.0_dp)
749
750 CALL timestop(handle1)
751
752 CALL timestop(handle)
753
754 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 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 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 CALL timeset(routinen, handle)
781
782 my_weight = 1.0_dp
783 IF (PRESENT(weight)) my_weight = weight
784
785 my_add = .false.
786 IF (PRESENT(add)) my_add = add
787
788 n_basis = SIZE(array_s, 1)
789 nimages = SIZE(array_s, 3)
790
791 ! checks
792 cpassert(SIZE(array_s, 2) == n_basis)
793 cpassert(SIZE(fm_s) == nimages)
794 cpassert(lbound(array_s, 1) == 1)
795 cpassert(lbound(array_s, 2) == 1)
796 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 col_indices=col_indices)
803
804 IF (.NOT. my_add) array_s(:, :, :) = 0.0_dp
805 ALLOCATE (array_tmp(SIZE(array_s, 1), SIZE(array_s, 2), SIZE(array_s, 3)))
806 array_tmp(:, :, :) = 0.0_dp
807
808 DO img = 1, nimages
809 DO i_row_local = 1, nrow_local
810
811 i = row_indices(i_row_local)
812
813 DO j_col_local = 1, ncol_local
814
815 j = col_indices(j_col_local)
816
817 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 CALL fm_s(1)%matrix_struct%para_env%sync()
824 CALL fm_s(1)%matrix_struct%para_env%sum(array_tmp)
825 CALL fm_s(1)%matrix_struct%para_env%sync()
826
827 array_s(:, :, :) = array_s(:, :, :) + my_weight*array_tmp(:, :, :)
828
829 CALL timestop(handle)
830
831 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 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 INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
852 LOGICAL :: my_add
853 REAL(kind=dp) :: my_weight, s_ij
854
855 CALL timeset(routinen, handle)
856
857 my_weight = 1.0_dp
858 IF (PRESENT(weight)) my_weight = weight
859
860 my_add = .false.
861 IF (PRESENT(add)) my_add = add
862
863 n_basis = SIZE(array_s, 1)
864 nimages = SIZE(array_s, 3)
865
866 ! checks
867 cpassert(SIZE(array_s, 2) == n_basis)
868 cpassert(SIZE(fm_s) == nimages)
869 cpassert(lbound(array_s, 1) == 1)
870 cpassert(lbound(array_s, 2) == 1)
871 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 col_indices=col_indices)
878
879 DO img = 1, nimages
880
881 DO i_row_local = 1, nrow_local
882
883 i = row_indices(i_row_local)
884
885 DO j_col_local = 1, ncol_local
886
887 j = col_indices(j_col_local)
888
889 IF (my_add) THEN
890 s_ij = fm_s(img)%local_data(i_row_local, j_col_local) + &
891 array_s(i, j, img)*my_weight
892 ELSE
893 s_ij = array_s(i, j, img)*my_weight
894 END IF
895 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 CALL timestop(handle)
904
905 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 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 CALL timeset(routinen, handle)
926
927 n_images = SIZE(t_r)
928
929 cpassert(n_images == SIZE(fm_r))
930
931 DO i_cell = 1, n_images
932 CALL dbcsr_set(mat_global%matrix, 0.0_dp)
933 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 bs_env%para_env)
936 CALL copy_dbcsr_to_fm(mat_global%matrix, fm_r(i_cell))
937 END DO
938
939 CALL timestop(handle)
940
941 END SUBROUTINE local_dbt_to_global_fm
942
943END MODULE gw_communication
tensor
struct tensor_ tensor
cp_dbcsr_api::dbcsr_create
Definition cp_dbcsr_api.F:192
message_passing::mp_waitall
Definition message_passing.F:871
cp_dbcsr_api
Definition cp_dbcsr_api.F:8
cp_dbcsr_api::dbcsr_iterator_next_block
subroutine, public dbcsr_iterator_next_block(iterator, row, column, block, block_number_argument_has_been_removed, row_size, col_size, row_offset, col_offset)
...
Definition cp_dbcsr_api.F:956
cp_dbcsr_api::dbcsr_iterator_blocks_left
logical function, public dbcsr_iterator_blocks_left(iterator)
...
Definition cp_dbcsr_api.F:930
cp_dbcsr_api::dbcsr_iterator_stop
subroutine, public dbcsr_iterator_stop(iterator)
...
Definition cp_dbcsr_api.F:1027
cp_dbcsr_api::dbcsr_copy
subroutine, public dbcsr_copy(matrix_b, matrix_a, name, keep_sparsity, keep_imaginary)
...
Definition cp_dbcsr_api.F:368
cp_dbcsr_api::dbcsr_get_info
subroutine, public dbcsr_get_info(matrix, nblkrows_total, nblkcols_total, nfullrows_total, nfullcols_total, nblkrows_local, nblkcols_local, nfullrows_local, nfullcols_local, my_prow, my_pcol, local_rows, local_cols, proc_row_dist, proc_col_dist, row_blk_size, col_blk_size, row_blk_offset, col_blk_offset, distribution, name, matrix_type, group)
...
Definition cp_dbcsr_api.F:794
cp_dbcsr_api::dbcsr_reserve_blocks
subroutine, public dbcsr_reserve_blocks(matrix, rows, cols)
...
Definition cp_dbcsr_api.F:1149
cp_dbcsr_api::dbcsr_get_stored_coordinates
subroutine, public dbcsr_get_stored_coordinates(matrix, row, column, processor)
...
Definition cp_dbcsr_api.F:897
cp_dbcsr_api::dbcsr_filter
subroutine, public dbcsr_filter(matrix, eps)
...
Definition cp_dbcsr_api.F:644
cp_dbcsr_api::dbcsr_finalize
subroutine, public dbcsr_finalize(matrix)
...
Definition cp_dbcsr_api.F:659
cp_dbcsr_api::dbcsr_iterator_start
subroutine, public dbcsr_iterator_start(iterator, matrix, shared, dynamic, dynamic_byrows)
...
Definition cp_dbcsr_api.F:989
cp_dbcsr_api::dbcsr_set
subroutine, public dbcsr_set(matrix, alpha)
...
Definition cp_dbcsr_api.F:1181
cp_dbcsr_api::dbcsr_release
subroutine, public dbcsr_release(matrix)
...
Definition cp_dbcsr_api.F:1119
cp_dbcsr_contrib
Definition cp_dbcsr_contrib.F:8
cp_dbcsr_contrib::dbcsr_reserve_all_blocks
subroutine, public dbcsr_reserve_all_blocks(matrix)
Reserves all blocks.
Definition cp_dbcsr_contrib.F:295
cp_dbcsr_operations
DBCSR operations in CP2K.
Definition cp_dbcsr_operations.F:18
cp_dbcsr_operations::copy_dbcsr_to_fm
subroutine, public copy_dbcsr_to_fm(matrix, fm)
Copy a DBCSR matrix to a BLACS matrix.
Definition cp_dbcsr_operations.F:214
cp_dbcsr_operations::copy_fm_to_dbcsr
subroutine, public copy_fm_to_dbcsr(fm, matrix, keep_sparsity)
Copy a BLACS matrix to a dbcsr matrix.
Definition cp_dbcsr_operations.F:111
cp_fm_types
represent a full matrix distributed on many processors
Definition cp_fm_types.F:15
cp_fm_types::cp_fm_get_info
subroutine, public cp_fm_get_info(matrix, name, nrow_global, ncol_global, nrow_block, ncol_block, nrow_local, ncol_local, row_indices, col_indices, local_data, context, nrow_locals, ncol_locals, matrix_struct, para_env)
returns all kind of information about the full matrix
Definition cp_fm_types.F:1009
dbt_api
This is the start of a dbt_api, all publically needed functions are exported here....
Definition dbt_api.F:17
gw_communication
Definition gw_communication.F:13
gw_communication::fm_to_local_tensor
subroutine, public fm_to_local_tensor(fm_global, mat_global, mat_local, tensor, bs_env, atom_ranges)
...
Definition gw_communication.F:67
gw_communication::local_dbt_to_global_mat
subroutine, public local_dbt_to_global_mat(tensor, mat_tensor, mat_global, para_env)
...
Definition gw_communication.F:110
gw_communication::local_dbt_to_global_fm
subroutine, public local_dbt_to_global_fm(t_r, fm_r, mat_global, mat_local, bs_env)
...
Definition gw_communication.F:916
gw_communication::local_array_to_fm
subroutine, public local_array_to_fm(array_s, fm_s, weight, add)
...
Definition gw_communication.F:841
gw_communication::fm_to_local_array
subroutine, public fm_to_local_array(fm_s, array_s, weight, add)
...
Definition gw_communication.F:764
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:23
post_scf_bandstructure_types
Definition post_scf_bandstructure_types.F:13
cp_dbcsr_api::dbcsr_iterator_type
Definition cp_dbcsr_api.F:186
cp_dbcsr_api::dbcsr_p_type
Definition cp_dbcsr_api.F:170
cp_dbcsr_api::dbcsr_type
Definition cp_dbcsr_api.F:174
cp_fm_types::cp_fm_type
represent a full matrix
Definition cp_fm_types.F:113
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:763
message_passing::mp_request_type
Definition message_passing.F:623
post_scf_bandstructure_types::post_scf_bandstructure_type
Definition post_scf_bandstructure_types.F:58