Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 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 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_release, &
18 : dbcsr_reserve_all_blocks, dbcsr_reserve_blocks, dbcsr_set, dbcsr_type
19 : USE kinds, ONLY: dp
20 : USE message_passing, ONLY: mp_para_env_type,&
21 : mp_request_type,&
22 : mp_waitall
23 : #include "./base/base_uses.f90"
24 :
25 : IMPLICIT NONE
26 :
27 : PRIVATE
28 :
29 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_communication'
30 :
31 : PUBLIC :: global_matrix_to_local_matrix, local_matrix_to_global_matrix
32 :
33 : TYPE buffer_type
34 : REAL(KIND=dp), DIMENSION(:), POINTER :: msg => NULL()
35 : INTEGER, DIMENSION(:), POINTER :: sizes => NULL()
36 : INTEGER, DIMENSION(:, :), POINTER :: indx => NULL()
37 : INTEGER :: proc = -1
38 : INTEGER :: msg_req = -1
39 : END TYPE
40 :
41 : CONTAINS
42 :
43 : ! **************************************************************************************************
44 : !> \brief ...
45 : !> \param mat_global ...
46 : !> \param mat_local ...
47 : !> \param para_env ...
48 : !> \param num_pe_sub ...
49 : !> \param atom_ranges ...
50 : ! **************************************************************************************************
51 792 : SUBROUTINE global_matrix_to_local_matrix(mat_global, mat_local, para_env, num_pe_sub, atom_ranges)
52 : TYPE(dbcsr_type) :: mat_global, mat_local
53 : TYPE(mp_para_env_type), POINTER :: para_env
54 : INTEGER :: num_pe_sub
55 : INTEGER, DIMENSION(:, :), OPTIONAL :: atom_ranges
56 :
57 : CHARACTER(LEN=*), PARAMETER :: routineN = 'global_matrix_to_local_matrix'
58 :
59 : INTEGER :: block_counter, block_offset, block_size, col, col_from_buffer, col_offset, &
60 : col_size, handle, handle1, i_block, i_entry, i_mepos, igroup, imep, imep_sub, msg_offset, &
61 : nblkrows_total, ngroup, nmo, num_blocks, offset, row, row_from_buffer, row_offset, &
62 : row_size, total_num_entries
63 792 : INTEGER, ALLOCATABLE, DIMENSION(:) :: blk_counter, cols_to_alloc, entry_counter, &
64 792 : num_entries_blocks_rec, num_entries_blocks_send, row_block_from_index, rows_to_alloc, &
65 792 : sizes_rec, sizes_send
66 792 : INTEGER, DIMENSION(:), POINTER :: row_blk_offset, row_blk_size
67 792 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
68 792 : TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
69 : TYPE(dbcsr_iterator_type) :: iter
70 :
71 792 : CALL timeset(routineN, handle)
72 :
73 792 : CALL timeset("get_sizes", handle1)
74 :
75 792 : NULLIFY (data_block)
76 :
77 2376 : ALLOCATE (num_entries_blocks_send(0:2*para_env%num_pe - 1))
78 3960 : num_entries_blocks_send(:) = 0
79 :
80 1584 : ALLOCATE (num_entries_blocks_rec(0:2*para_env%num_pe - 1))
81 3960 : num_entries_blocks_rec(:) = 0
82 :
83 792 : ngroup = para_env%num_pe/num_pe_sub
84 :
85 792 : CALL dbcsr_iterator_start(iter, mat_global)
86 8696 : DO WHILE (dbcsr_iterator_blocks_left(iter))
87 :
88 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
89 : row_size=row_size, col_size=col_size, &
90 7904 : row_offset=row_offset, col_offset=col_offset)
91 :
92 7904 : CALL dbcsr_get_stored_coordinates(mat_local, row, col, imep_sub)
93 :
94 16600 : DO igroup = 0, ngroup - 1
95 :
96 7904 : IF (PRESENT(atom_ranges)) THEN
97 7904 : IF (row < atom_ranges(1, igroup + 1) .OR. row > atom_ranges(2, igroup + 1)) CYCLE
98 : END IF
99 7904 : imep = imep_sub + igroup*num_pe_sub
100 :
101 7904 : num_entries_blocks_send(2*imep) = num_entries_blocks_send(2*imep) + row_size*col_size
102 15808 : num_entries_blocks_send(2*imep + 1) = num_entries_blocks_send(2*imep + 1) + 1
103 :
104 : END DO
105 :
106 : END DO
107 :
108 792 : CALL dbcsr_iterator_stop(iter)
109 :
110 792 : CALL timestop(handle1)
111 :
112 792 : CALL timeset("send_sizes_1", handle1)
113 :
114 3960 : total_num_entries = SUM(num_entries_blocks_send)
115 792 : CALL para_env%sum(total_num_entries)
116 :
117 792 : CALL timestop(handle1)
118 :
119 792 : CALL timeset("send_sizes_2", handle1)
120 :
121 792 : IF (para_env%num_pe > 1) THEN
122 792 : CALL para_env%alltoall(num_entries_blocks_send, num_entries_blocks_rec, 2)
123 : ELSE
124 0 : num_entries_blocks_rec(0:1) = num_entries_blocks_send(0:1)
125 : END IF
126 :
127 792 : CALL timestop(handle1)
128 :
129 792 : CALL timeset("get_data", handle1)
130 :
131 3960 : ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
132 3960 : ALLOCATE (buffer_send(0:para_env%num_pe - 1))
133 :
134 : ! allocate data message and corresponding indices
135 2376 : DO imep = 0, para_env%num_pe - 1
136 :
137 3960 : ALLOCATE (buffer_rec(imep)%msg(num_entries_blocks_rec(2*imep)))
138 148073 : buffer_rec(imep)%msg = 0.0_dp
139 :
140 3960 : ALLOCATE (buffer_send(imep)%msg(num_entries_blocks_send(2*imep)))
141 148073 : buffer_send(imep)%msg = 0.0_dp
142 :
143 3960 : ALLOCATE (buffer_rec(imep)%indx(num_entries_blocks_rec(2*imep + 1), 3))
144 30048 : buffer_rec(imep)%indx = 0
145 :
146 3960 : ALLOCATE (buffer_send(imep)%indx(num_entries_blocks_send(2*imep + 1), 3))
147 30840 : buffer_send(imep)%indx = 0
148 :
149 : END DO
150 :
151 2376 : ALLOCATE (entry_counter(0:para_env%num_pe - 1))
152 2376 : entry_counter(:) = 0
153 :
154 1584 : ALLOCATE (blk_counter(0:para_env%num_pe - 1))
155 2376 : blk_counter = 0
156 :
157 792 : CALL dbcsr_iterator_start(iter, mat_global)
158 8696 : DO WHILE (dbcsr_iterator_blocks_left(iter))
159 :
160 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
161 : row_size=row_size, col_size=col_size, &
162 7904 : row_offset=row_offset, col_offset=col_offset)
163 :
164 7904 : CALL dbcsr_get_stored_coordinates(mat_local, row, col, imep_sub)
165 :
166 16600 : DO igroup = 0, ngroup - 1
167 :
168 7904 : IF (PRESENT(atom_ranges)) THEN
169 7904 : IF (row < atom_ranges(1, igroup + 1) .OR. row > atom_ranges(2, igroup + 1)) CYCLE
170 : END IF
171 :
172 7904 : imep = imep_sub + igroup*num_pe_sub
173 :
174 7904 : msg_offset = entry_counter(imep)
175 :
176 7904 : block_size = row_size*col_size
177 :
178 : buffer_send(imep)%msg(msg_offset + 1:msg_offset + block_size) = &
179 162297 : RESHAPE(data_block(1:row_size, 1:col_size), (/block_size/))
180 :
181 7904 : entry_counter(imep) = entry_counter(imep) + block_size
182 :
183 7904 : blk_counter(imep) = blk_counter(imep) + 1
184 :
185 7904 : block_offset = blk_counter(imep)
186 :
187 7904 : buffer_send(imep)%indx(block_offset, 1) = row
188 7904 : buffer_send(imep)%indx(block_offset, 2) = col
189 15808 : buffer_send(imep)%indx(block_offset, 3) = msg_offset
190 :
191 : END DO
192 :
193 : END DO
194 :
195 792 : CALL dbcsr_iterator_stop(iter)
196 :
197 792 : CALL timestop(handle1)
198 :
199 792 : CALL timeset("send_data", handle1)
200 :
201 2376 : ALLOCATE (sizes_rec(0:para_env%num_pe - 1))
202 1584 : ALLOCATE (sizes_send(0:para_env%num_pe - 1))
203 :
204 2376 : DO imep = 0, para_env%num_pe - 1
205 1584 : sizes_send(imep) = num_entries_blocks_send(2*imep)
206 2376 : sizes_rec(imep) = num_entries_blocks_rec(2*imep)
207 : END DO
208 :
209 792 : CALL communicate_buffer(para_env, sizes_rec, sizes_send, buffer_rec, buffer_send)
210 :
211 792 : CALL timestop(handle1)
212 :
213 792 : CALL timeset("row_block_from_index", handle1)
214 :
215 : CALL dbcsr_get_info(mat_local, &
216 : nblkrows_total=nblkrows_total, &
217 : row_blk_offset=row_blk_offset, &
218 792 : row_blk_size=row_blk_size)
219 :
220 1584 : ALLOCATE (row_block_from_index(nmo))
221 792 : row_block_from_index = 0
222 :
223 792 : DO i_entry = 1, nmo
224 792 : DO i_block = 1, nblkrows_total
225 :
226 0 : IF (i_entry >= row_blk_offset(i_block) .AND. &
227 0 : i_entry <= row_blk_offset(i_block) + row_blk_size(i_block) - 1) THEN
228 :
229 0 : row_block_from_index(i_entry) = i_block
230 :
231 : END IF
232 :
233 : END DO
234 : END DO
235 :
236 792 : CALL timestop(handle1)
237 :
238 792 : CALL timeset("reserve_blocks", handle1)
239 :
240 792 : num_blocks = 0
241 :
242 : ! get the number of blocks, which have to be allocated
243 2376 : DO imep = 0, para_env%num_pe - 1
244 2376 : num_blocks = num_blocks + num_entries_blocks_rec(2*imep + 1)
245 : END DO
246 :
247 2376 : ALLOCATE (rows_to_alloc(num_blocks))
248 8696 : rows_to_alloc = 0
249 :
250 1584 : ALLOCATE (cols_to_alloc(num_blocks))
251 8696 : cols_to_alloc = 0
252 :
253 : block_counter = 0
254 :
255 2376 : DO i_mepos = 0, para_env%num_pe - 1
256 :
257 10280 : DO i_block = 1, num_entries_blocks_rec(2*i_mepos + 1)
258 :
259 7904 : block_counter = block_counter + 1
260 :
261 7904 : rows_to_alloc(block_counter) = buffer_rec(i_mepos)%indx(i_block, 1)
262 9488 : cols_to_alloc(block_counter) = buffer_rec(i_mepos)%indx(i_block, 2)
263 :
264 : END DO
265 :
266 : END DO
267 :
268 792 : CALL dbcsr_set(mat_local, 0.0_dp)
269 792 : CALL dbcsr_filter(mat_local, 1.0_dp)
270 792 : CALL dbcsr_reserve_blocks(mat_local, rows=rows_to_alloc(:), cols=cols_to_alloc(:))
271 792 : CALL dbcsr_finalize(mat_local)
272 792 : CALL dbcsr_set(mat_local, 0.0_dp)
273 :
274 792 : CALL timestop(handle1)
275 :
276 792 : CALL timeset("fill_mat_local", handle1)
277 :
278 792 : CALL dbcsr_iterator_start(iter, mat_local)
279 :
280 8696 : DO WHILE (dbcsr_iterator_blocks_left(iter))
281 :
282 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
283 7904 : row_size=row_size, col_size=col_size)
284 :
285 24504 : DO imep = 0, para_env%num_pe - 1
286 :
287 138686 : DO i_block = 1, num_entries_blocks_rec(2*imep + 1)
288 :
289 114974 : row_from_buffer = buffer_rec(imep)%indx(i_block, 1)
290 114974 : col_from_buffer = buffer_rec(imep)%indx(i_block, 2)
291 114974 : offset = buffer_rec(imep)%indx(i_block, 3)
292 :
293 130782 : IF (row == row_from_buffer .AND. col == col_from_buffer) THEN
294 :
295 : data_block(1:row_size, 1:col_size) = &
296 : RESHAPE(buffer_rec(imep)%msg(offset + 1:offset + row_size*col_size), &
297 203339 : (/row_size, col_size/))
298 :
299 : END IF
300 :
301 : END DO
302 :
303 : END DO
304 :
305 : END DO ! blocks
306 :
307 792 : CALL dbcsr_iterator_stop(iter)
308 :
309 792 : CALL timestop(handle1)
310 :
311 2376 : DO imep = 0, para_env%num_pe - 1
312 1584 : DEALLOCATE (buffer_rec(imep)%msg)
313 1584 : DEALLOCATE (buffer_rec(imep)%indx)
314 1584 : DEALLOCATE (buffer_send(imep)%msg)
315 2376 : DEALLOCATE (buffer_send(imep)%indx)
316 : END DO
317 :
318 792 : CALL timestop(handle)
319 :
320 8712 : END SUBROUTINE global_matrix_to_local_matrix
321 :
322 : ! **************************************************************************************************
323 : !> \brief ...
324 : !> \param para_env ...
325 : !> \param num_entries_rec ...
326 : !> \param num_entries_send ...
327 : !> \param buffer_rec ...
328 : !> \param buffer_send ...
329 : !> \param do_indx ...
330 : !> \param do_msg ...
331 : ! **************************************************************************************************
332 792 : SUBROUTINE communicate_buffer(para_env, num_entries_rec, num_entries_send, &
333 : buffer_rec, buffer_send, do_indx, do_msg)
334 :
335 : TYPE(mp_para_env_type), POINTER :: para_env
336 : INTEGER, ALLOCATABLE, DIMENSION(:) :: num_entries_rec, num_entries_send
337 : TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
338 : LOGICAL, OPTIONAL :: do_indx, do_msg
339 :
340 : CHARACTER(LEN=*), PARAMETER :: routineN = 'communicate_buffer'
341 :
342 : INTEGER :: handle, imep, rec_counter, send_counter
343 : LOGICAL :: my_do_indx, my_do_msg
344 792 : TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req
345 :
346 792 : CALL timeset(routineN, handle)
347 :
348 792 : NULLIFY (req)
349 12672 : ALLOCATE (req(1:para_env%num_pe, 4))
350 :
351 792 : my_do_indx = .TRUE.
352 792 : IF (PRESENT(do_indx)) my_do_indx = do_indx
353 792 : my_do_msg = .TRUE.
354 792 : IF (PRESENT(do_msg)) my_do_msg = do_msg
355 :
356 792 : IF (para_env%num_pe > 1) THEN
357 :
358 792 : send_counter = 0
359 792 : rec_counter = 0
360 :
361 2376 : DO imep = 0, para_env%num_pe - 1
362 2376 : IF (num_entries_rec(imep) > 0) THEN
363 792 : rec_counter = rec_counter + 1
364 792 : IF (my_do_indx) THEN
365 792 : CALL para_env%irecv(buffer_rec(imep)%indx, imep, req(rec_counter, 3), tag=4)
366 : END IF
367 792 : IF (my_do_msg) THEN
368 792 : CALL para_env%irecv(buffer_rec(imep)%msg, imep, req(rec_counter, 4), tag=7)
369 : END IF
370 : END IF
371 : END DO
372 :
373 2376 : DO imep = 0, para_env%num_pe - 1
374 2376 : IF (num_entries_send(imep) > 0) THEN
375 792 : send_counter = send_counter + 1
376 792 : IF (my_do_indx) THEN
377 792 : CALL para_env%isend(buffer_send(imep)%indx, imep, req(send_counter, 1), tag=4)
378 : END IF
379 792 : IF (my_do_msg) THEN
380 792 : CALL para_env%isend(buffer_send(imep)%msg, imep, req(send_counter, 2), tag=7)
381 : END IF
382 : END IF
383 : END DO
384 :
385 792 : IF (my_do_indx) THEN
386 792 : CALL mp_waitall(req(1:send_counter, 1))
387 792 : CALL mp_waitall(req(1:rec_counter, 3))
388 : END IF
389 :
390 792 : IF (my_do_msg) THEN
391 792 : CALL mp_waitall(req(1:send_counter, 2))
392 792 : CALL mp_waitall(req(1:rec_counter, 4))
393 : END IF
394 :
395 : ELSE
396 :
397 0 : buffer_rec(0)%indx = buffer_send(0)%indx
398 0 : buffer_rec(0)%msg = buffer_send(0)%msg
399 :
400 : END IF
401 :
402 792 : DEALLOCATE (req)
403 :
404 792 : CALL timestop(handle)
405 :
406 792 : END SUBROUTINE communicate_buffer
407 :
408 : ! **************************************************************************************************
409 : !> \brief ...
410 : !> \param mat_local ...
411 : !> \param mat_global ...
412 : !> \param para_env ...
413 : ! **************************************************************************************************
414 452 : SUBROUTINE local_matrix_to_global_matrix(mat_local, mat_global, para_env)
415 :
416 : TYPE(dbcsr_type) :: mat_local, mat_global
417 : TYPE(mp_para_env_type), POINTER :: para_env
418 :
419 : CHARACTER(LEN=*), PARAMETER :: routineN = 'local_matrix_to_global_matrix'
420 :
421 : INTEGER :: block_size, c, col, col_size, handle, &
422 : handle1, i_block, imep, o, offset, r, &
423 : rec_counter, row, row_size, &
424 : send_counter
425 452 : INTEGER, ALLOCATABLE, DIMENSION(:) :: block_counter, entry_counter, num_blocks_rec, &
426 452 : num_blocks_send, num_entries_rec, num_entries_send, sizes_rec, sizes_send
427 452 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
428 452 : TYPE(buffer_type), ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send
429 : TYPE(dbcsr_iterator_type) :: iter
430 : TYPE(dbcsr_type) :: mat_global_copy
431 452 : TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req
432 :
433 452 : CALL timeset(routineN, handle)
434 :
435 452 : CALL timeset("get_coord", handle1)
436 :
437 452 : CALL dbcsr_create(mat_global_copy, template=mat_global)
438 452 : CALL dbcsr_reserve_all_blocks(mat_global_copy)
439 :
440 452 : CALL dbcsr_set(mat_global, 0.0_dp)
441 452 : CALL dbcsr_set(mat_global_copy, 0.0_dp)
442 :
443 2260 : ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
444 1808 : ALLOCATE (buffer_send(0:para_env%num_pe - 1))
445 :
446 1356 : ALLOCATE (num_entries_rec(0:para_env%num_pe - 1))
447 904 : ALLOCATE (num_blocks_rec(0:para_env%num_pe - 1))
448 904 : ALLOCATE (num_entries_send(0:para_env%num_pe - 1))
449 904 : ALLOCATE (num_blocks_send(0:para_env%num_pe - 1))
450 1356 : num_entries_rec = 0
451 1356 : num_blocks_rec = 0
452 1356 : num_entries_send = 0
453 1356 : num_blocks_send = 0
454 :
455 452 : CALL dbcsr_iterator_start(iter, mat_local)
456 4550 : DO WHILE (dbcsr_iterator_blocks_left(iter))
457 :
458 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
459 4098 : row_size=row_size, col_size=col_size)
460 :
461 4098 : CALL dbcsr_get_stored_coordinates(mat_global, row, col, imep)
462 :
463 4098 : num_entries_send(imep) = num_entries_send(imep) + row_size*col_size
464 4098 : num_blocks_send(imep) = num_blocks_send(imep) + 1
465 :
466 : END DO
467 :
468 452 : CALL dbcsr_iterator_stop(iter)
469 :
470 452 : CALL timestop(handle1)
471 :
472 452 : CALL timeset("comm_size", handle1)
473 :
474 452 : IF (para_env%num_pe > 1) THEN
475 :
476 1356 : ALLOCATE (sizes_rec(0:2*para_env%num_pe - 1))
477 904 : ALLOCATE (sizes_send(0:2*para_env%num_pe - 1))
478 :
479 1356 : DO imep = 0, para_env%num_pe - 1
480 :
481 904 : sizes_send(2*imep) = num_entries_send(imep)
482 1356 : sizes_send(2*imep + 1) = num_blocks_send(imep)
483 :
484 : END DO
485 :
486 452 : CALL para_env%alltoall(sizes_send, sizes_rec, 2)
487 :
488 1356 : DO imep = 0, para_env%num_pe - 1
489 904 : num_entries_rec(imep) = sizes_rec(2*imep)
490 1356 : num_blocks_rec(imep) = sizes_rec(2*imep + 1)
491 : END DO
492 :
493 452 : DEALLOCATE (sizes_rec, sizes_send)
494 :
495 : ELSE
496 :
497 0 : num_entries_rec(0) = num_entries_send(0)
498 0 : num_blocks_rec(0) = num_blocks_send(0)
499 :
500 : END IF
501 :
502 452 : CALL timestop(handle1)
503 :
504 452 : CALL timeset("fill_buffer", handle1)
505 :
506 : ! allocate data message and corresponding indices
507 1356 : DO imep = 0, para_env%num_pe - 1
508 :
509 2431 : ALLOCATE (buffer_rec(imep)%msg(num_entries_rec(imep)))
510 69256 : buffer_rec(imep)%msg = 0.0_dp
511 :
512 2431 : ALLOCATE (buffer_send(imep)%msg(num_entries_send(imep)))
513 69256 : buffer_send(imep)%msg = 0.0_dp
514 :
515 2431 : ALLOCATE (buffer_rec(imep)%indx(num_blocks_rec(imep), 5))
516 25914 : buffer_rec(imep)%indx = 0
517 :
518 2431 : ALLOCATE (buffer_send(imep)%indx(num_blocks_send(imep), 5))
519 26366 : buffer_send(imep)%indx = 0
520 :
521 : END DO
522 :
523 1356 : ALLOCATE (block_counter(0:para_env%num_pe - 1))
524 1356 : block_counter(:) = 0
525 :
526 904 : ALLOCATE (entry_counter(0:para_env%num_pe - 1))
527 1356 : entry_counter(:) = 0
528 :
529 : ! fill buffer_send
530 452 : CALL dbcsr_iterator_start(iter, mat_local)
531 4550 : DO WHILE (dbcsr_iterator_blocks_left(iter))
532 :
533 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
534 4098 : row_size=row_size, col_size=col_size)
535 :
536 4098 : CALL dbcsr_get_stored_coordinates(mat_global, row, col, imep)
537 :
538 4098 : block_size = row_size*col_size
539 :
540 4098 : offset = entry_counter(imep)
541 :
542 : buffer_send(imep)%msg(offset + 1:offset + block_size) = &
543 76548 : RESHAPE(data_block(1:row_size, 1:col_size), (/block_size/))
544 :
545 4098 : i_block = block_counter(imep) + 1
546 :
547 4098 : buffer_send(imep)%indx(i_block, 1) = row
548 4098 : buffer_send(imep)%indx(i_block, 2) = col
549 4098 : buffer_send(imep)%indx(i_block, 3) = offset
550 :
551 4098 : entry_counter(imep) = entry_counter(imep) + block_size
552 :
553 4098 : block_counter(imep) = block_counter(imep) + 1
554 :
555 : END DO
556 :
557 452 : CALL dbcsr_iterator_stop(iter)
558 :
559 452 : CALL timestop(handle1)
560 :
561 452 : CALL timeset("comm_data", handle1)
562 :
563 452 : NULLIFY (req)
564 6780 : ALLOCATE (req(1:para_env%num_pe, 4))
565 :
566 452 : IF (para_env%num_pe > 1) THEN
567 :
568 452 : send_counter = 0
569 452 : rec_counter = 0
570 :
571 1356 : DO imep = 0, para_env%num_pe - 1
572 904 : IF (num_entries_rec(imep) > 0) THEN
573 623 : rec_counter = rec_counter + 1
574 623 : CALL para_env%irecv(buffer_rec(imep)%indx, imep, req(rec_counter, 3), tag=4)
575 : END IF
576 1356 : IF (num_entries_rec(imep) > 0) THEN
577 623 : CALL para_env%irecv(buffer_rec(imep)%msg, imep, req(rec_counter, 4), tag=7)
578 : END IF
579 : END DO
580 :
581 1356 : DO imep = 0, para_env%num_pe - 1
582 904 : IF (num_entries_send(imep) > 0) THEN
583 623 : send_counter = send_counter + 1
584 623 : CALL para_env%isend(buffer_send(imep)%indx, imep, req(send_counter, 1), tag=4)
585 : END IF
586 1356 : IF (num_entries_send(imep) > 0) THEN
587 623 : CALL para_env%isend(buffer_send(imep)%msg, imep, req(send_counter, 2), tag=7)
588 : END IF
589 : END DO
590 :
591 452 : CALL mp_waitall(req(1:send_counter, 1:2))
592 452 : CALL mp_waitall(req(1:rec_counter, 3:4))
593 :
594 : ELSE
595 :
596 0 : buffer_rec(0)%indx = buffer_send(0)%indx
597 0 : buffer_rec(0)%msg = buffer_send(0)%msg
598 :
599 : END IF
600 :
601 452 : CALL timestop(handle1)
602 :
603 452 : CALL timeset("set_blocks", handle1)
604 :
605 : ! fill mat_global_copy
606 452 : CALL dbcsr_iterator_start(iter, mat_global_copy)
607 5051 : DO WHILE (dbcsr_iterator_blocks_left(iter))
608 :
609 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
610 4599 : row_size=row_size, col_size=col_size)
611 :
612 14249 : DO imep = 0, para_env%num_pe - 1
613 :
614 74382 : DO i_block = 1, num_blocks_rec(imep)
615 :
616 60585 : IF (row == buffer_rec(imep)%indx(i_block, 1) .AND. &
617 9198 : col == buffer_rec(imep)%indx(i_block, 2)) THEN
618 :
619 4098 : offset = buffer_rec(imep)%indx(i_block, 3)
620 :
621 4098 : r = row_size
622 4098 : c = col_size
623 4098 : o = offset
624 :
625 : data_block(1:r, 1:c) = data_block(1:r, 1:c) + &
626 96723 : RESHAPE(buffer_rec(imep)%msg(o + 1:o + r*c), (/r, c/))
627 :
628 : END IF
629 :
630 : END DO
631 :
632 : END DO
633 :
634 : END DO
635 :
636 452 : CALL dbcsr_iterator_stop(iter)
637 :
638 452 : CALL dbcsr_copy(mat_global, mat_global_copy)
639 :
640 452 : CALL dbcsr_release(mat_global_copy)
641 :
642 : ! remove the blocks which are exactly zero from mat_global
643 452 : CALL dbcsr_filter(mat_global, 1.0E-30_dp)
644 :
645 1356 : DO imep = 0, para_env%num_pe - 1
646 904 : DEALLOCATE (buffer_rec(imep)%msg)
647 904 : DEALLOCATE (buffer_send(imep)%msg)
648 904 : DEALLOCATE (buffer_rec(imep)%indx)
649 1356 : DEALLOCATE (buffer_send(imep)%indx)
650 : END DO
651 :
652 452 : DEALLOCATE (buffer_rec, buffer_send)
653 :
654 452 : DEALLOCATE (block_counter, entry_counter)
655 :
656 452 : DEALLOCATE (req)
657 :
658 452 : CALL dbcsr_set(mat_local, 0.0_dp)
659 452 : CALL dbcsr_filter(mat_local, 1.0_dp)
660 :
661 452 : CALL timestop(handle1)
662 :
663 452 : CALL timestop(handle)
664 :
665 3616 : END SUBROUTINE local_matrix_to_global_matrix
666 :
667 0 : END MODULE gw_communication
|
