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