(git:374b731)
Loading...
Searching...
No Matches
qs_fb_com_tasks_types.F
Go to the documentation of this file.
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
8MODULE qs_fb_com_tasks_types
9
10 USE dbcsr_api, ONLY: dbcsr_get_block_p,&
11 dbcsr_get_info,&
12 dbcsr_put_block,&
13 dbcsr_type
14 USE kinds, ONLY: dp,&
15 int_4,&
16 int_8
17 USE memory_utilities, ONLY: reallocate
18 USE message_passing, ONLY: mp_para_env_type
19 USE qs_fb_matrix_data_types, ONLY: fb_matrix_data_add,&
20 fb_matrix_data_get,&
21 fb_matrix_data_has_data,&
22 fb_matrix_data_obj
23 USE util, ONLY: sort
24#include "./base/base_uses.f90"
25
26 IMPLICIT NONE
27
28 PRIVATE
29
30! public parameters:
31 PUBLIC :: task_n_records, &
32 task_dest, &
33 task_src, &
34 task_pair, &
35 task_cost
36
37! public types
38 PUBLIC :: fb_com_tasks_obj, &
39 fb_com_atom_pairs_obj
40
41! public methods
42!API
43 PUBLIC :: fb_com_tasks_release, &
44 fb_com_tasks_nullify, &
45 fb_com_tasks_create, &
46 fb_com_tasks_get, &
47 fb_com_tasks_set, &
48 fb_com_tasks_transpose_dest_src, &
49 fb_com_tasks_build_atom_pairs, &
50 fb_com_tasks_encode_pair, &
51 fb_com_tasks_decode_pair, &
52 fb_com_atom_pairs_release, &
53 fb_com_atom_pairs_nullify, &
54 fb_com_atom_pairs_has_data, &
55 fb_com_atom_pairs_create, &
56 fb_com_atom_pairs_init, &
57 fb_com_atom_pairs_get, &
58 fb_com_atom_pairs_decode, &
59 fb_com_atom_pairs_calc_buffer_sizes, &
60 fb_com_atom_pairs_gather_blks, &
61 fb_com_atom_pairs_distribute_blks
62
63 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_fb_com_tasks_types'
64
65! **********************************************************************
66! explanation on format of task lists (same for tasks_recv and tasks_send):
67! tasks_recv has dimension (4, ntasks_recv), and stores information on
68! the block to be copied or transferred
69! - tasks_recv(TASK_DEST,itask) = destination MPI rank of itask-th task
70! - tasks_recv(TASK_SRC,itask) = source MPI rank of itask-th task
71! - tasks_recv(TASK_PAIR,itask) = compressed pair indices of the block of itask-th task
72! - tasks_recv(TASK_COST,itask) = the cost of itask-th task
73!
74! number of record slots in each task in the task lists
75 INTEGER, PARAMETER :: task_n_records = 4
76! the indices for the records (1:TASK_DIM) in a task
77 INTEGER, PARAMETER :: task_dest = 1, &
78 task_src = 2, &
79 task_pair = 3, &
80 task_cost = 4
81! **********************************************************************
82
83! **********************************************************************
84!> \brief data content for communication tasks used for send and receive
85!> matrix blocks
86!> \param tasks : the list of communication tasks, which is
87!> represented by a 2D array, first dim stores
88!> info for the communication: src and desc procs
89!> and the atomic pair indexing the matrix block
90!> to be communicated, etc.
91!> \param task_dim : the size of the first dimension of tasks
92!> \param ntasks : total number of local tasks
93!> \param nencode : the total number of atoms used for encoding
94!> the block coordinates (iatom, jatom)
95!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
96! **********************************************************************
97 TYPE fb_com_tasks_data
98 ! use pure integer arrays to facilitate easier MPI coms
99 INTEGER(KIND=int_8), DIMENSION(:, :), POINTER :: tasks
100 INTEGER :: task_dim
101 INTEGER :: ntasks
102 INTEGER :: nencode
103 END TYPE fb_com_tasks_data
104
105!**********************************************************************
106!> \brief defines a fb_com_tasks object
107!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
108!**********************************************************************
109 TYPE fb_com_tasks_obj
110 TYPE(fb_com_tasks_data), POINTER, PRIVATE :: obj
111 END TYPE fb_com_tasks_obj
112
113! **********************************************************************
114!> \brief data content for the list of block coordinates with the
115!> associated src/dest proc id for communication. These will be
116!> generated from the fb_com_tasks object
117!> \param pairs : the list of communication tasks, which is
118!> represented by a 2D array, first dim stores
119!> info for the communication: src and desc procs
120!> and the atomic pair indexing the matrix block
121!> to be communicated, etc.
122!> \param npairs : number of blks to be communicated in the atom
123!> pair list
124!> \param natoms_encode : the total number of atoms used for encoding
125!> the proc + block coordinates (pe, iatom, jatom)
126!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
127! **********************************************************************
128 TYPE fb_com_atom_pairs_data
129 INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs
130 INTEGER :: npairs
131 INTEGER :: natoms_encode
132 END TYPE fb_com_atom_pairs_data
133
134! **********************************************************************
135!> \brief defines a fb_com_atom_pairs object
136!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
137! **********************************************************************
138 TYPE fb_com_atom_pairs_obj
139 TYPE(fb_com_atom_pairs_data), POINTER, PRIVATE :: obj
140 END TYPE fb_com_atom_pairs_obj
141
142CONTAINS
143
144! **********************************************************************
145!> \brief Releases an fb_com_tasks object
146!> \param com_tasks the fb_com_tasks object, its content must not be
147!> UNDEFINED, and the subroutine does nothing if the
148!> content points to NULL
149!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
150! **************************************************************************************************
151 SUBROUTINE fb_com_tasks_release(com_tasks)
152 TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks
153
154 IF (ASSOCIATED(com_tasks%obj)) THEN
155 IF (ASSOCIATED(com_tasks%obj%tasks)) THEN
156 DEALLOCATE (com_tasks%obj%tasks)
157 END IF
158 DEALLOCATE (com_tasks%obj)
159 ELSE
160 NULLIFY (com_tasks%obj)
161 END IF
162 END SUBROUTINE fb_com_tasks_release
163
164! **********************************************************************
165!> \brief Releases an fb_com_atom_pairs object
166!> \param atom_pairs the fb_com_atom_pairs object, its content must not
167!> be UNDEFINED, and the subroutine does nothing if
168!> the content points to NULL
169!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
170! **************************************************************************************************
171 SUBROUTINE fb_com_atom_pairs_release(atom_pairs)
172 TYPE(fb_com_atom_pairs_obj), INTENT(INOUT) :: atom_pairs
173
174 IF (ASSOCIATED(atom_pairs%obj)) THEN
175 IF (ASSOCIATED(atom_pairs%obj%pairs)) THEN
176 DEALLOCATE (atom_pairs%obj%pairs)
177 END IF
178 DEALLOCATE (atom_pairs%obj)
179 ELSE
180 NULLIFY (atom_pairs%obj)
181 END IF
182 END SUBROUTINE fb_com_atom_pairs_release
183
184! **********************************************************************
185!> \brief Nullifies a fb_com_tasks object, note that it does not release
186!> the original object. This procedure is used to nullify the
187!> pointer contained in the object which is used to associate to
188!> the actual object content
189!> \param com_tasks the com_tasks object
190!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
191! **************************************************************************************************
192 SUBROUTINE fb_com_tasks_nullify(com_tasks)
193 TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks
194
195 NULLIFY (com_tasks%obj)
196 END SUBROUTINE fb_com_tasks_nullify
197
198! **********************************************************************
199!> \brief Nullifies a fb_com_atom_pairs object, note that it does not
200!> release the original object. This procedure is used to nullify
201!> the pointer contained in the object which is used to associate
202!> to the actual object content
203!> \param atom_pairs the fb_com_atom_pairs object
204!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
205! **************************************************************************************************
206 SUBROUTINE fb_com_atom_pairs_nullify(atom_pairs)
207 TYPE(fb_com_atom_pairs_obj), INTENT(INOUT) :: atom_pairs
208
209 NULLIFY (atom_pairs%obj)
210 END SUBROUTINE fb_com_atom_pairs_nullify
211
212! **********************************************************************
213!> \brief Associates one fb_com_tasks object to another
214!> \param a the fb_com_tasks object to be associated
215!> \param b the fb_com_tasks object that a is to be associated to
216!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
217! **************************************************************************************************
218 SUBROUTINE fb_com_tasks_associate(a, b)
219 TYPE(fb_com_tasks_obj), INTENT(OUT) :: a
220 TYPE(fb_com_tasks_obj), INTENT(IN) :: b
221
222 a%obj => b%obj
223 END SUBROUTINE fb_com_tasks_associate
224
225! **********************************************************************
226!> \brief Associates one fb_com_atom_pairs object to another
227!> \param a the fb_com_atom_pairs object to be associated
228!> \param b the fb_com_atom_pairs object that a is to be associated to
229!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
230! **************************************************************************************************
231 SUBROUTINE fb_com_atom_pairs_associate(a, b)
232 TYPE(fb_com_atom_pairs_obj), INTENT(OUT) :: a
233 TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: b
234
235 a%obj => b%obj
236 END SUBROUTINE fb_com_atom_pairs_associate
237
238! **********************************************************************
239!> \brief Checks if a fb_com_tasks object is associated with an actual
240!> data content or not
241!> \param com_tasks the fb_com_tasks object
242!> \return ...
243!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
244! **************************************************************************************************
245 FUNCTION fb_com_tasks_has_data(com_tasks) RESULT(res)
246 TYPE(fb_com_tasks_obj), INTENT(IN) :: com_tasks
247 LOGICAL :: res
248
249 res = ASSOCIATED(com_tasks%obj)
250 END FUNCTION fb_com_tasks_has_data
251
252! **********************************************************************
253!> \brief Checks if a fb_com_atom_pairs object is associated with an actual
254!> data content or not
255!> \param atom_pairs the fb_com_atom_pairs object
256!> \return ...
257!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
258! **************************************************************************************************
259 FUNCTION fb_com_atom_pairs_has_data(atom_pairs) RESULT(res)
260 TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs
261 LOGICAL :: res
262
263 res = ASSOCIATED(atom_pairs%obj)
264 END FUNCTION fb_com_atom_pairs_has_data
265
266! **********************************************************************
267!> \brief Creates and initialises an empty fb_com_tasks object
268!> \param com_tasks the fb_com_tasks object, its content must be NULL
269!> and cannot be UNDEFINED
270!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
271! **************************************************************************************************
272 SUBROUTINE fb_com_tasks_create(com_tasks)
273 TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks
274
275 cpassert(.NOT. ASSOCIATED(com_tasks%obj))
276 ALLOCATE (com_tasks%obj)
277 com_tasks%obj%task_dim = task_n_records
278 com_tasks%obj%ntasks = 0
279 com_tasks%obj%nencode = 0
280 NULLIFY (com_tasks%obj%tasks)
281 END SUBROUTINE fb_com_tasks_create
282
283! **********************************************************************
284!> \brief Creates and initialises an empty fb_com_atom_pairs object
285!> \param atom_pairs the fb_com_atom_pairs object, its content must be
286!> NULL and cannot be UNDEFINED
287!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
288! **************************************************************************************************
289 SUBROUTINE fb_com_atom_pairs_create(atom_pairs)
290 TYPE(fb_com_atom_pairs_obj), INTENT(INOUT) :: atom_pairs
291
292 cpassert(.NOT. ASSOCIATED(atom_pairs%obj))
293 ALLOCATE (atom_pairs%obj)
294 atom_pairs%obj%npairs = 0
295 atom_pairs%obj%natoms_encode = 0
296 NULLIFY (atom_pairs%obj%pairs)
297 END SUBROUTINE fb_com_atom_pairs_create
298
299! **********************************************************************
300!> \brief Initialises an fb_com_tasks object, and makes it empty
301!> \param com_tasks the fb_com_tasks object, its content must not be
302!> NULL or UNDEFINED
303!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
304! **************************************************************************************************
305 SUBROUTINE fb_com_tasks_init(com_tasks)
306 TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks
307
308 cpassert(ASSOCIATED(com_tasks%obj))
309 IF (ASSOCIATED(com_tasks%obj%tasks)) THEN
310 DEALLOCATE (com_tasks%obj%tasks)
311 END IF
312 com_tasks%obj%task_dim = task_n_records
313 com_tasks%obj%ntasks = 0
314 com_tasks%obj%nencode = 0
315 END SUBROUTINE fb_com_tasks_init
316
317! **********************************************************************
318!> \brief Initialises an fb_com_atom_pairs object, and makes it empty
319!> \param atom_pairs the fb_com_atom_pairs object, its content must not
320!> be NULL or UNDEFINED
321!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
322! **************************************************************************************************
323 SUBROUTINE fb_com_atom_pairs_init(atom_pairs)
324 TYPE(fb_com_atom_pairs_obj), INTENT(INOUT) :: atom_pairs
325
326 cpassert(ASSOCIATED(atom_pairs%obj))
327 IF (ASSOCIATED(atom_pairs%obj%pairs)) THEN
328 DEALLOCATE (atom_pairs%obj%pairs)
329 END IF
330 atom_pairs%obj%npairs = 0
331 atom_pairs%obj%natoms_encode = 0
332 END SUBROUTINE fb_com_atom_pairs_init
333
334! **********************************************************************
335!> \brief Gets attributes from a fb_com_tasks object, one should only
336!> access the data content in a fb_com_tasks object outside this
337!> module via this procedure.
338!> \param com_tasks the fb_com_tasks object, its content must not be
339!> NULL or UNDEFINED
340!> \param task_dim [OPTIONAL]: if present, outputs com_tasks%obj%task_dim
341!> \param ntasks [OPTIONAL]: if present, outputs com_tasks%obj%ntasks
342!> \param nencode [OPTIONAL]: if present, outputs com_tasks%obj%nencode
343!> \param tasks [OPTIONAL]: if present, outputs pointer com_tasks%obj%tasks
344!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
345! **************************************************************************************************
346 SUBROUTINE fb_com_tasks_get(com_tasks, &
347 task_dim, &
348 ntasks, &
349 nencode, &
350 tasks)
351 TYPE(fb_com_tasks_obj), INTENT(IN) :: com_tasks
352 INTEGER, INTENT(OUT), OPTIONAL :: task_dim, ntasks, nencode
353 INTEGER(KIND=int_8), DIMENSION(:, :), OPTIONAL, &
354 POINTER :: tasks
355
356 cpassert(ASSOCIATED(com_tasks%obj))
357 IF (PRESENT(task_dim)) task_dim = com_tasks%obj%task_dim
358 IF (PRESENT(ntasks)) ntasks = com_tasks%obj%ntasks
359 IF (PRESENT(nencode)) nencode = com_tasks%obj%nencode
360 IF (PRESENT(tasks)) tasks => com_tasks%obj%tasks
361 END SUBROUTINE fb_com_tasks_get
362
363! **********************************************************************
364!> \brief Gets attributes from a fb_com_atom_pairs object, one should
365!> only access the data content in a fb_com_atom_pairs object
366!> outside this module via this procedure.
367!> \param atom_pairs the fb_com_atom_pairs object, its content must not
368!> be NULL or UNDEFINED
369!> \param npairs [OPTIONAL]: if present, outputs atom_pairs%obj%npairs
370!> \param natoms_encode [OPTIONAL]: if present, outputs atom_pairs%obj%natoms_encode
371!> \param pairs [OPTIONAL]: if present, outputs pointer atom_pairs%obj%pairs
372!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
373! **************************************************************************************************
374 SUBROUTINE fb_com_atom_pairs_get(atom_pairs, &
375 npairs, &
376 natoms_encode, &
377 pairs)
378 TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs
379 INTEGER, INTENT(OUT), OPTIONAL :: npairs, natoms_encode
380 INTEGER(KIND=int_8), DIMENSION(:), OPTIONAL, &
381 POINTER :: pairs
382
383 cpassert(ASSOCIATED(atom_pairs%obj))
384 IF (PRESENT(npairs)) npairs = atom_pairs%obj%npairs
385 IF (PRESENT(natoms_encode)) natoms_encode = atom_pairs%obj%natoms_encode
386 IF (PRESENT(pairs)) pairs => atom_pairs%obj%pairs
387 END SUBROUTINE fb_com_atom_pairs_get
388
389! **********************************************************************
390!> \brief Sets attributes in a fb_com_tasks object, one should only
391!> access the data content in a fb_com_tasks object outside this
392!> module via this procedure.
393!> \param com_tasks the fb_com_tasks object, its content must not be
394!> NULL or UNDEFINED
395!> \param task_dim [OPTIONAL]: if present, sets com_tasks%obj%task_dim
396!> \param ntasks [OPTIONAL]: if present, sets com_tasks%obj%ntasks
397!> \param nencode [OPTIONAL]: if present, sets com_tasks%obj%nencode
398!> \param tasks [OPTIONAL]: if present, associates pointer com_tasks%obj%tasks
399!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
400! **************************************************************************************************
401 SUBROUTINE fb_com_tasks_set(com_tasks, &
402 task_dim, &
403 ntasks, &
404 nencode, &
405 tasks)
406 TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks
407 INTEGER, INTENT(IN), OPTIONAL :: task_dim, ntasks, nencode
408 INTEGER(KIND=int_8), DIMENSION(:, :), OPTIONAL, &
409 POINTER :: tasks
410
411 cpassert(ASSOCIATED(com_tasks%obj))
412 IF (PRESENT(task_dim)) com_tasks%obj%task_dim = task_dim
413 IF (PRESENT(ntasks)) com_tasks%obj%ntasks = ntasks
414 IF (PRESENT(nencode)) com_tasks%obj%nencode = nencode
415 IF (PRESENT(tasks)) THEN
416 IF (ASSOCIATED(com_tasks%obj%tasks)) THEN
417 DEALLOCATE (com_tasks%obj%tasks)
418 END IF
419 com_tasks%obj%tasks => tasks
420 END IF
421 END SUBROUTINE fb_com_tasks_set
422
423! **********************************************************************
424!> \brief Sets attributes in a fb_com_atom_pairs object, one should only
425!> access the data content in a fb_com_atom_pairs object outside
426!> this module via this procedure.
427!> \param atom_pairs the fb_com_atom_pairs object, its content must not
428!> be NULL or UNDEFINED
429!> \param npairs [OPTIONAL]: if present, sets atom_pairs%obj%npairs
430!> \param natoms_encode [OPTIONAL]: if present, sets atom_pairs%obj%natoms_encode
431!> \param pairs [OPTIONAL]: if present, associates pointer atom_pairs%obj%pairs
432!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
433! **************************************************************************************************
434 SUBROUTINE fb_com_atom_pairs_set(atom_pairs, &
435 npairs, &
436 natoms_encode, &
437 pairs)
438 TYPE(fb_com_atom_pairs_obj), INTENT(INOUT) :: atom_pairs
439 INTEGER, INTENT(IN), OPTIONAL :: npairs, natoms_encode
440 INTEGER(KIND=int_8), DIMENSION(:), OPTIONAL, &
441 POINTER :: pairs
442
443 cpassert(ASSOCIATED(atom_pairs%obj))
444 IF (PRESENT(npairs)) atom_pairs%obj%npairs = npairs
445 IF (PRESENT(natoms_encode)) atom_pairs%obj%natoms_encode = natoms_encode
446 IF (PRESENT(pairs)) THEN
447 IF (ASSOCIATED(atom_pairs%obj%pairs)) THEN
448 DEALLOCATE (atom_pairs%obj%pairs)
449 END IF
450 atom_pairs%obj%pairs => pairs
451 END IF
452 END SUBROUTINE fb_com_atom_pairs_set
453
454! **********************************************************************
455!> \brief Start from a local set of tasks that has desc/src process equal
456!> to the local MPI rank, communicate with other processes so
457!> that a new local set of tasks is constructed with src/desc
458!> process equal to the local MPI rank
459!> \param tasks_dest_is_me the local com_task object with all tasks
460!> having the desc process id equal to my_id
461!> \param direction direction of operation:
462!> ">" means from tasks_dest_is_me construct tasks_src_is_me
463!> "<" means from tasks_src_is_me construct tasks_dest_is_me
464!> \param tasks_src_is_me the local com_task object with all tasks
465!> having the src process id equal to my_id
466!> \param para_env CP2K parallel environment object that stores MPI related
467!> information of the current run
468!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
469! **************************************************************************************************
470 SUBROUTINE fb_com_tasks_transpose_dest_src(tasks_dest_is_me, &
471 direction, &
472 tasks_src_is_me, &
473 para_env)
474 TYPE(fb_com_tasks_obj), INTENT(INOUT) :: tasks_dest_is_me
475 CHARACTER, INTENT(IN) :: direction
476 TYPE(fb_com_tasks_obj), INTENT(INOUT) :: tasks_src_is_me
477 TYPE(mp_para_env_type), POINTER :: para_env
478
479 CHARACTER(LEN=*), PARAMETER :: routinen = 'fb_com_tasks_transpose_dest_src'
480
481 INTEGER :: handle, ii, ind, ipe, itask, jj, &
482 nencode, ntasks_in, ntasks_out, rank, &
483 rank_pos, task_dim
484 INTEGER(KIND=int_8), DIMENSION(:, :), POINTER :: tasks_in, tasks_out
485 INTEGER, ALLOCATABLE, DIMENSION(:) :: recv_buf, recv_disps, recv_sizes, &
486 send_buf, send_disps, send_sizes
487
488 CALL timeset(routinen, handle)
489
490 NULLIFY (tasks_in, tasks_out)
491
492 IF (direction == "<") THEN
493 CALL fb_com_tasks_get(com_tasks=tasks_src_is_me, &
494 task_dim=task_dim, &
495 ntasks=ntasks_in, &
496 tasks=tasks_in, &
497 nencode=nencode)
498 rank_pos = task_dest
499 ELSE
500 CALL fb_com_tasks_get(com_tasks=tasks_dest_is_me, &
501 task_dim=task_dim, &
502 ntasks=ntasks_in, &
503 tasks=tasks_in, &
504 nencode=nencode)
505 rank_pos = task_src
506 END IF
507
508 ! allocate local arrays
509 ALLOCATE (send_sizes(para_env%num_pe))
510 ALLOCATE (send_disps(para_env%num_pe))
511 ALLOCATE (send_buf(para_env%num_pe))
512
513 ALLOCATE (recv_sizes(para_env%num_pe))
514 ALLOCATE (recv_disps(para_env%num_pe))
515 ALLOCATE (recv_buf(para_env%num_pe))
516
517 ! first count how many local recv/send tasks need to be sent to
518 ! other processes, and share this information with the other
519 ! processes. using send_buf as a temporary array for counting
520 send_buf = 0
521 ! looping over local task list
522 DO itask = 1, ntasks_in
523 rank = int(tasks_in(rank_pos, itask)) + 1
524 send_buf(rank) = send_buf(rank) + 1
525 END DO
526
527 CALL para_env%alltoall(send_buf, recv_buf, 1)
528
529 ! now that we know how many recv/send tasks to send, pack the
530 ! tasks, and send them around, so that the recv/send tasks are
531 ! sent to the correct src/dest processes, and these then are
532 ! collected into the send/recv tasks list on each of the src/dest
533 ! processes
534
535 send_sizes = 0
536 send_disps = 0
537 recv_sizes = 0
538 recv_disps = 0
539
540 ! work out the sizes of send and recv buffers and allocate them
541 send_sizes(1) = send_buf(1)*task_dim
542 recv_sizes(1) = recv_buf(1)*task_dim
543 DO ipe = 2, para_env%num_pe
544 send_sizes(ipe) = send_buf(ipe)*task_dim
545 send_disps(ipe) = send_disps(ipe - 1) + send_sizes(ipe - 1)
546 recv_sizes(ipe) = recv_buf(ipe)*task_dim
547 recv_disps(ipe) = recv_disps(ipe - 1) + recv_sizes(ipe - 1)
548 END DO
549
550 ! reallocate send and recv buffers to the correct sizes for
551 ! transferring the actual tasks
552 DEALLOCATE (send_buf)
553 DEALLOCATE (recv_buf)
554 ALLOCATE (send_buf(sum(send_sizes)))
555 ALLOCATE (recv_buf(sum(recv_sizes)))
556
557 ! now that the send buffer is of correct size, do packing
558 ! send_buf and recv_buf may be zero sized
559 IF (SIZE(send_buf) > 0) send_buf = 0
560 IF (SIZE(recv_buf) > 0) recv_buf = 0
561 send_sizes = 0
562 DO itask = 1, ntasks_in
563 rank = int(tasks_in(rank_pos, itask)) + 1
564 DO ii = 1, task_dim
565 ind = send_disps(rank) + send_sizes(rank) + ii
566 send_buf(ind) = int(tasks_in(ii, itask))
567 END DO
568 send_sizes(rank) = send_sizes(rank) + task_dim
569 END DO
570 ! do communication
571 CALL para_env%alltoall(send_buf, send_sizes, send_disps, &
572 recv_buf, recv_sizes, recv_disps)
573
574 ! deallocate send buffers
575 DEALLOCATE (send_buf)
576 DEALLOCATE (send_sizes)
577 DEALLOCATE (send_disps)
578
579 ! allocate the output task list
580 ntasks_out = sum(recv_sizes)/task_dim
581 ! this will not be deallocated in this subroutine
582 ALLOCATE (tasks_out(task_dim, ntasks_out))
583
584 ! do unpacking
585 itask = 0
586 DO ipe = 1, para_env%num_pe
587 DO ii = 0, recv_sizes(ipe)/task_dim - 1
588 itask = itask + 1
589 DO jj = 1, task_dim
590 ind = recv_disps(ipe) + ii*task_dim + jj
591 tasks_out(jj, itask) = recv_buf(ind)
592 END DO
593 END DO
594 END DO
595
596 ! set output tasks
597 IF (direction == "<") THEN
598 CALL fb_com_tasks_set(com_tasks=tasks_dest_is_me, &
599 task_dim=task_dim, &
600 ntasks=ntasks_out, &
601 tasks=tasks_out, &
602 nencode=nencode)
603 ELSE
604 CALL fb_com_tasks_set(com_tasks=tasks_src_is_me, &
605 task_dim=task_dim, &
606 ntasks=ntasks_out, &
607 tasks=tasks_out, &
608 nencode=nencode)
609 END IF
610
611 ! deallocate recv buffers
612 DEALLOCATE (recv_buf)
613 DEALLOCATE (recv_sizes)
614 DEALLOCATE (recv_disps)
615
616 CALL timestop(handle)
617
618 END SUBROUTINE fb_com_tasks_transpose_dest_src
619
620! **********************************************************************
621!> \brief Generate send or receive atom_pair lists from a com_tasks
622!> object. atom_pair list is used as a condensed index for the
623!> local/remote matrix blocks to be sent/received.
624!> \param com_tasks the com_tasks object
625!> \param atom_pairs fb_com_atom_pairs_obj containing list of encoded
626!> atomic pair indices and the dest/src proc id for
627!> the matrix block to be sent/received.
628!> \param natoms_encode the total number of atoms the atomic pair indices
629!> corresponds to, and it is used for encode the
630!> atom_pairs values
631!> \param send_or_recv whether the atom_pair to be generated is for
632!> the local matrix blocks to be sent or the
633!> remote matrix blocks to be received for this MPI
634!> process
635!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
636! **************************************************************************************************
637 SUBROUTINE fb_com_tasks_build_atom_pairs(com_tasks, &
638 atom_pairs, &
639 natoms_encode, &
640 send_or_recv)
641 TYPE(fb_com_tasks_obj), INTENT(IN) :: com_tasks
642 TYPE(fb_com_atom_pairs_obj), INTENT(INOUT) :: atom_pairs
643 INTEGER, INTENT(IN) :: natoms_encode
644 CHARACTER(len=*), INTENT(IN) :: send_or_recv
645
646 CHARACTER(LEN=*), PARAMETER :: routinen = 'fb_com_tasks_build_atom_pairs'
647
648 INTEGER :: handle, iatom, ii, itask, jatom, npairs, &
649 ntasks, rank, rank_pos
650 INTEGER(KIND=int_8) :: pair
651 INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs
652 INTEGER(KIND=int_8), DIMENSION(:, :), POINTER :: tasks
653 INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_index
654 LOGICAL :: check_ok
655
656 CALL timeset(routinen, handle)
657
658 NULLIFY (pairs, tasks)
659
660 check_ok = fb_com_atom_pairs_has_data(atom_pairs)
661 cpassert(check_ok)
662
663 ! initialise atom_pairs
664 CALL fb_com_atom_pairs_init(atom_pairs)
665
666 IF (trim(send_or_recv) == "send") THEN
667 rank_pos = task_dest
668 ELSE
669 rank_pos = task_src
670 END IF
671
672 CALL fb_com_tasks_get(com_tasks=com_tasks, &
673 ntasks=ntasks, &
674 tasks=tasks)
675
676 ALLOCATE (pairs(ntasks))
677 ! we can have cases where ntasks == 0
678 IF (SIZE(pairs) > 0) pairs = 0
679 npairs = ntasks
680
681 DO itask = 1, ntasks
682 pair = tasks(task_pair, itask)
683 CALL fb_com_tasks_decode_pair(pair, iatom, jatom, natoms_encode)
684 rank = int(tasks(rank_pos, itask))
685 CALL fb_com_atom_pairs_encode(pairs(itask), &
686 rank, iatom, jatom, natoms_encode)
687 END DO
688
689 ! sort atom_pairs so that the pairs are ordered process blocks and
690 ! that possible duplicates may be found (we don't want to send or
691 ! receive same information to the same destination or source more
692 ! than once)
693 IF (npairs > 0) THEN
694 ALLOCATE (tmp_index(npairs))
695 ! only sort the actual pairs recorded in the send list
696 CALL sort(pairs, npairs, tmp_index)
697 DEALLOCATE (tmp_index)
698 END IF
699
700 ! remove duplicates
701 IF (npairs > 1) THEN
702 npairs = 1
703 ! first atom pair must be allowed
704 DO ii = 2, ntasks
705 IF (pairs(ii) > pairs(ii - 1)) THEN
706 npairs = npairs + 1
707 pairs(npairs) = pairs(ii)
708 END IF
709 END DO
710 ! reallocate the pairs list
711 CALL reallocate(pairs, 1, npairs)
712 END IF
713
714 CALL fb_com_atom_pairs_set(atom_pairs=atom_pairs, &
715 pairs=pairs, &
716 npairs=npairs, &
717 natoms_encode=natoms_encode)
718
719 CALL timestop(handle)
720
721 END SUBROUTINE fb_com_tasks_build_atom_pairs
722
723! **********************************************************************
724!> \brief Encodes (iatom, jatom) pair index of a block into a single
725!> integer
726!> \param ind encoded integer
727!> \param iatom the first index of the (iatom, jatom) block index
728!> \param jatom the second index of the (iatom, jatom) block index
729!> \param natoms the total number of atoms iatom and jatom indexes
730!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
731! **************************************************************************************************
732 SUBROUTINE fb_com_tasks_encode_pair(ind, iatom, jatom, natoms)
733 INTEGER(KIND=int_8), INTENT(OUT) :: ind
734 INTEGER, INTENT(IN) :: iatom, jatom, natoms
735
736 INTEGER(KIND=int_8) :: iatom8, jatom8, natoms8
737
738 natoms8 = int(natoms, int_8)
739 iatom8 = int(iatom, int_8)
740 jatom8 = int(jatom, int_8)
741
742 ind = (iatom8 - 1_int_8)*natoms8 + (jatom8 - 1_int_8)
743 END SUBROUTINE fb_com_tasks_encode_pair
744
745! **********************************************************************
746!> \brief Dncodes a single integer into (iatom, jatom) pair index of
747!> a block into a single
748!> \param ind encoded integer
749!> \param iatom the first index of the (iatom, jatom) block index
750!> \param jatom the second index of the (iatom, jatom) block index
751!> \param natoms the total number of atoms iatom and jatom indexes
752!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
753! **************************************************************************************************
754 SUBROUTINE fb_com_tasks_decode_pair(ind, iatom, jatom, natoms)
755 INTEGER(KIND=int_8), INTENT(IN) :: ind
756 INTEGER, INTENT(OUT) :: iatom, jatom
757 INTEGER, INTENT(IN) :: natoms
758
759 INTEGER(KIND=int_8) :: iatom8, jatom8, natoms8
760
761 natoms8 = int(natoms, int_8)
762 iatom8 = ind/natoms8 + 1_int_8
763 jatom8 = mod(ind, natoms8) + 1_int_8
764 iatom = int(iatom8, int_4)
765 jatom = int(jatom8, int_4)
766 END SUBROUTINE fb_com_tasks_decode_pair
767
768! **********************************************************************
769!> \brief Encodes (rank, iatom, jatom) index of a communication task---to
770!> send/receive a block to/from a process---into a single integer
771!> \param ind encoded integer
772!> \param pe the rank of the process the block to be send to or receive
773!> from
774!> \param iatom the first index of the (iatom, jatom) block index
775!> \param jatom the second index of the (iatom, jatom) block index
776!> \param natoms the total number of atoms iatom and jatom indexes
777!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
778! **************************************************************************************************
779 SUBROUTINE fb_com_atom_pairs_encode(ind, pe, iatom, jatom, natoms)
780 INTEGER(KIND=int_8), INTENT(OUT) :: ind
781 INTEGER, INTENT(IN) :: pe, iatom, jatom, natoms
782
783 INTEGER(KIND=int_8) :: natoms8, pair
784
785! pe must start count from 0 (i.e same as MPI convension)
786
787 natoms8 = int(natoms, int_8)
788 CALL fb_com_tasks_encode_pair(pair, iatom, jatom, natoms)
789 ind = int(pe, int_8)*natoms8*natoms8 + pair
790 END SUBROUTINE fb_com_atom_pairs_encode
791
792! **********************************************************************
793!> \brief Decodes a single integer into the (rank, iatom, jatom) index
794!> of a communication task to send/receive a block to/from a
795!> process
796!> \param ind : encoded integer
797!> \param pe : the rank of the process the block to be send to or receive
798!> from
799!> \param iatom : the first index of the (iatom, jatom) block index
800!> \param jatom : the second index of the (iatom, jatom) block index
801!> \param natoms : the total number of atoms iatom and jatom indexes
802!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
803! **************************************************************************************************
804 SUBROUTINE fb_com_atom_pairs_decode(ind, pe, iatom, jatom, natoms)
805 INTEGER(KIND=int_8), INTENT(IN) :: ind
806 INTEGER, INTENT(OUT) :: pe, iatom, jatom
807 INTEGER, INTENT(IN) :: natoms
808
809 INTEGER(KIND=int_8) :: natoms8, pair
810
811! pe start count from 0 (i.e same as MPI convension)
812
813 natoms8 = int(natoms, int_8)
814 pe = int(ind/(natoms8*natoms8), int_4)
815 pair = mod(ind, natoms8*natoms8)
816 CALL fb_com_tasks_decode_pair(pair, iatom, jatom, natoms)
817 END SUBROUTINE fb_com_atom_pairs_decode
818
819! **********************************************************************
820!> \brief Calculate the MPI send or recv buffer sizes according to the
821!> communication pairs (atom_pairs) and DBCSR matrix data.
822!> Each atom_pair corresponds to one DBCSR matrix block that
823!> needs to be sent or recerived.
824!> \param atom_pairs : the communication pair object for either sending
825!> or receiving
826!> \param nprocs : total number of MPI processes in communicator
827!> \param row_blk_sizes : row_blk_sizes(iblkrow) = number of element rows
828!> in each block in the iblkrow-th block row of
829!> the DBCSR matrix
830!> \param col_blk_sizes : col_blk_sizes(iblkcol) = number of element cols
831!> in each block in the iblkcol-th block col of
832!> the DBCSR matrix
833!> \param sendrecv_sizes : size required for the send of recv buffer
834!> for each dest/src process
835!> \param sendrecv_disps : sendrecv_disps(ipe) + 1 = starting location
836!> in send/recv buffer for data destined for
837!> process ipe
838!> \param sendrecv_pair_counts : sendrecv_pair_counts(ipe) = number of
839!> pairs (blocks) to be sent to or recv
840!> from process ipe
841!> \param sendrecv_pair_disps send_recv_pair_disps(ipe) + 1 = start
842!> location in atom_pairs array for
843!> all the pairs to be sent to or recv
844!> from process ipe
845!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
846! **************************************************************************************************
847 SUBROUTINE fb_com_atom_pairs_calc_buffer_sizes(atom_pairs, &
848 nprocs, &
849 row_blk_sizes, &
850 col_blk_sizes, &
851 sendrecv_sizes, &
852 sendrecv_disps, &
853 sendrecv_pair_counts, &
854 sendrecv_pair_disps)
855 TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs
856 INTEGER, INTENT(IN) :: nprocs
857 INTEGER, DIMENSION(:), INTENT(IN) :: row_blk_sizes, col_blk_sizes
858 INTEGER, DIMENSION(:), INTENT(OUT) :: sendrecv_sizes, sendrecv_disps, &
859 sendrecv_pair_counts, &
860 sendrecv_pair_disps
861
862 INTEGER :: iatom, ipair, ipe, jatom, natoms_encode, &
863 ncols_blk, npairs, nrows_blk, pe
864 INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs
865 LOGICAL :: check_ok
866
867 NULLIFY (pairs)
868
869 check_ok = SIZE(sendrecv_sizes) == nprocs .AND. &
870 SIZE(sendrecv_disps) == nprocs .AND. &
871 SIZE(sendrecv_pair_counts) == nprocs .AND. &
872 SIZE(sendrecv_pair_disps) == nprocs
873 cpassert(check_ok)
874
875 check_ok = fb_com_atom_pairs_has_data(atom_pairs)
876 cpassert(check_ok)
877
878 CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs, &
879 pairs=pairs, &
880 npairs=npairs, &
881 natoms_encode=natoms_encode)
882
883 sendrecv_sizes = 0
884 sendrecv_pair_counts = 0
885 DO ipair = 1, npairs
886 ! decode processor and (iatom, jatom) information
887 CALL fb_com_atom_pairs_decode(pairs(ipair), &
888 pe, iatom, jatom, natoms_encode)
889 pe = pe + 1 ! we need proc to count from 1
890 nrows_blk = row_blk_sizes(iatom)
891 ncols_blk = col_blk_sizes(jatom)
892 sendrecv_sizes(pe) = sendrecv_sizes(pe) + nrows_blk*ncols_blk
893 sendrecv_pair_counts(pe) = sendrecv_pair_counts(pe) + 1
894 END DO
895 ! calculate displacements of the data of each destibation pe in
896 ! send buffer and in the list of pairs to be sent
897 sendrecv_disps = 0
898 sendrecv_pair_disps = 0
899 DO ipe = 2, nprocs
900 sendrecv_disps(ipe) = sendrecv_disps(ipe - 1) + sendrecv_sizes(ipe - 1)
901 sendrecv_pair_disps(ipe) = sendrecv_pair_disps(ipe - 1) + sendrecv_pair_counts(ipe - 1)
902 END DO
903
904 END SUBROUTINE fb_com_atom_pairs_calc_buffer_sizes
905
906! ****************************************************************************
907!> \brief Given send and recv fb_com_atom_pair object, gather all the
908!> relevant DBCSR matrix blocks together, and add them to
909!> a fb_matrix_data object for storage
910!> \param dbcsr_mat : the DBCSR matrix where the matrix blocks will be
911!> obtained from
912!> \param atom_pairs_send : prescription on exactly which DBCSR blocks
913!> are to be sent to where
914!> \param atom_pairs_recv : prescription on exactly which DBCSR blocks
915!> are to be received from where
916!> \param para_env : CP2K parallel environment
917!> \param matrix_storage : the fb_matrix_data object to store the
918!> received DBCSR matrix blocks
919!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
920! **************************************************************************************************
921 SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, &
922 atom_pairs_send, &
923 atom_pairs_recv, &
924 para_env, &
925 matrix_storage)
926 TYPE(dbcsr_type), POINTER :: dbcsr_mat
927 TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs_send, atom_pairs_recv
928 TYPE(mp_para_env_type), POINTER :: para_env
929 TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_storage
930
931 CHARACTER(LEN=*), PARAMETER :: routinen = 'fb_com_atom_pairs_gather_blks'
932
933 INTEGER :: handle, iatom, ii, ind, ipair, ipe, jatom, jj, ncols_blk, ncols_blk_max, &
934 npairs_recv, npairs_send, nrows_blk, nrows_blk_max, numprocs, pe, recv_encode, send_encode
935 INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs_recv, pairs_send
936 INTEGER, ALLOCATABLE, DIMENSION(:) :: recv_disps, recv_pair_count, recv_pair_disps, &
937 recv_sizes, send_disps, send_pair_count, send_pair_disps, send_sizes
938 INTEGER, DIMENSION(:), POINTER :: col_block_size_data, row_block_size_data
939 LOGICAL :: check_ok, found
940 REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: recv_buf, send_buf
941 REAL(kind=dp), DIMENSION(:, :), POINTER :: mat_block
942
943 CALL timeset(routinen, handle)
944
945 NULLIFY (pairs_send, pairs_recv, mat_block, &
946 row_block_size_data, col_block_size_data)
947
948 check_ok = fb_com_atom_pairs_has_data(atom_pairs_send)
949 cpassert(check_ok)
950 check_ok = fb_com_atom_pairs_has_data(atom_pairs_send)
951 cpassert(check_ok)
952 check_ok = fb_matrix_data_has_data(matrix_storage)
953 cpassert(check_ok)
954
955 ! get com pair informations
956 CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_send, &
957 pairs=pairs_send, &
958 npairs=npairs_send, &
959 natoms_encode=send_encode)
960 CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_recv, &
961 pairs=pairs_recv, &
962 npairs=npairs_recv, &
963 natoms_encode=recv_encode)
964 ! get para_env info
965 numprocs = para_env%num_pe
966
967 ! get dbcsr row and col block sizes
968 CALL dbcsr_get_info(dbcsr_mat, row_blk_size=row_block_size_data, col_blk_size=col_block_size_data)
969
970 ! allocate temporary arrays for send
971 ALLOCATE (send_sizes(numprocs))
972 ALLOCATE (send_disps(numprocs))
973 ALLOCATE (send_pair_count(numprocs))
974 ALLOCATE (send_pair_disps(numprocs))
975
976 ! setup send buffer sizes
977 CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_send, &
978 numprocs, &
979 row_block_size_data, &
980 col_block_size_data, &
981 send_sizes, &
982 send_disps, &
983 send_pair_count, &
984 send_pair_disps)
985
986 ! allocate send buffer
987 ALLOCATE (send_buf(sum(send_sizes)))
988
989 ! allocate temporary arrays for recv
990 ALLOCATE (recv_sizes(numprocs))
991 ALLOCATE (recv_disps(numprocs))
992 ALLOCATE (recv_pair_count(numprocs))
993 ALLOCATE (recv_pair_disps(numprocs))
994
995 ! setup recv buffer sizes
996 CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_recv, &
997 numprocs, &
998 row_block_size_data, &
999 col_block_size_data, &
1000 recv_sizes, &
1001 recv_disps, &
1002 recv_pair_count, &
1003 recv_pair_disps)
1004
1005 ! allocate recv buffer
1006 ALLOCATE (recv_buf(sum(recv_sizes)))
1007
1008 ! do packing
1009 DO ipe = 1, numprocs
1010 ! need to reuse send_sizes as an accumulative displacement, so recalculate
1011 send_sizes(ipe) = 0
1012 DO ipair = 1, send_pair_count(ipe)
1013 CALL fb_com_atom_pairs_decode(pairs_send(send_pair_disps(ipe) + ipair), &
1014 pe, iatom, jatom, send_encode)
1015 nrows_blk = row_block_size_data(iatom)
1016 ncols_blk = col_block_size_data(jatom)
1017 CALL dbcsr_get_block_p(matrix=dbcsr_mat, &
1018 row=iatom, col=jatom, block=mat_block, &
1019 found=found)
1020 IF (.NOT. found) THEN
1021 cpabort("Matrix block not found")
1022 ELSE
1023 ! we have found the matrix block
1024 DO jj = 1, ncols_blk
1025 DO ii = 1, nrows_blk
1026 ! column major format in blocks
1027 ind = send_disps(ipe) + send_sizes(ipe) + ii + (jj - 1)*nrows_blk
1028 send_buf(ind) = mat_block(ii, jj)
1029 END DO ! ii
1030 END DO ! jj
1031 send_sizes(ipe) = send_sizes(ipe) + nrows_blk*ncols_blk
1032 END IF
1033 END DO ! ipair
1034 END DO ! ipe
1035
1036 ! do communication
1037 CALL para_env%alltoall(send_buf, send_sizes, send_disps, &
1038 recv_buf, recv_sizes, recv_disps)
1039
1040 ! cleanup temporary arrays no longer needed
1041 DEALLOCATE (send_buf)
1042 DEALLOCATE (send_sizes)
1043 DEALLOCATE (send_disps)
1044 DEALLOCATE (send_pair_count)
1045 DEALLOCATE (send_pair_disps)
1046
1047 ! unpack into matrix_data object
1048 NULLIFY (mat_block)
1049 nrows_blk_max = maxval(row_block_size_data)
1050 ncols_blk_max = maxval(col_block_size_data)
1051 ALLOCATE (mat_block(nrows_blk_max, ncols_blk_max))
1052 DO ipe = 1, numprocs
1053 recv_sizes(ipe) = 0
1054 DO ipair = 1, recv_pair_count(ipe)
1055 CALL fb_com_atom_pairs_decode(pairs_recv(recv_pair_disps(ipe) + ipair), &
1056 pe, iatom, jatom, recv_encode)
1057 nrows_blk = row_block_size_data(iatom)
1058 ncols_blk = col_block_size_data(jatom)
1059 ! ALLOCATE(mat_block(nrows_blk,ncols_blk), STAT=stat)
1060 ! CPPostcondition(stat==0, cp_failure_level, routineP,failure)
1061 mat_block(:, :) = 0.0_dp
1062 DO jj = 1, ncols_blk
1063 DO ii = 1, nrows_blk
1064 ! column major format in blocks
1065 ind = recv_disps(ipe) + recv_sizes(ipe) + ii + (jj - 1)*nrows_blk
1066 mat_block(ii, jj) = recv_buf(ind)
1067 END DO ! ii
1068 END DO ! jj
1069 CALL fb_matrix_data_add(matrix_storage, &
1070 iatom, jatom, &
1071 mat_block(1:nrows_blk, 1:ncols_blk))
1072 recv_sizes(ipe) = recv_sizes(ipe) + nrows_blk*ncols_blk
1073 ! DEALLOCATE(mat_block, STAT=stat)
1074 ! CPPostcondition(stat==0, cp_failure_level, routineP,failure)
1075 END DO ! ipair
1076 END DO ! ipe
1077 DEALLOCATE (mat_block)
1078
1079 ! cleanup rest of the temporary arrays
1080 DEALLOCATE (recv_buf)
1081 DEALLOCATE (recv_sizes)
1082 DEALLOCATE (recv_disps)
1083 DEALLOCATE (recv_pair_count)
1084 DEALLOCATE (recv_pair_disps)
1085
1086 CALL timestop(handle)
1087
1088 END SUBROUTINE fb_com_atom_pairs_gather_blks
1089
1090! ****************************************************************************
1091!> \brief Given send and recv fb_com_atom_pair object, distribute the matrix
1092!> blocks stored in a fb_matrix_data object to a computable DBCSR
1093!> matrix. It is assumed in this subroutine that the sizes of each
1094!> block stored in fb_matrix_data object is consistent with the
1095!> pre-defined block sizes in the DBCSR matrix.
1096!> \param matrix_storage : the fb_matrix_data object
1097!> \param atom_pairs_send : prescription on exactly which DBCSR blocks
1098!> are to be sent to where
1099!> \param atom_pairs_recv : prescription on exactly which DBCSR blocks
1100!> are to be received from where
1101!> \param para_env : CP2K parallel environment
1102!> \param dbcsr_mat : the DBCSR matrix where the matrix blocks will be
1103!> distributed to
1104!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
1105! **************************************************************************************************
1106 SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, &
1107 atom_pairs_send, &
1108 atom_pairs_recv, &
1109 para_env, &
1110 dbcsr_mat)
1111 TYPE(fb_matrix_data_obj), INTENT(IN) :: matrix_storage
1112 TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs_send, atom_pairs_recv
1113 TYPE(mp_para_env_type), POINTER :: para_env
1114 TYPE(dbcsr_type), POINTER :: dbcsr_mat
1115
1116 CHARACTER(LEN=*), PARAMETER :: routinen = 'fb_com_atom_pairs_distribute_blks'
1117
1118 INTEGER :: handle, iatom, ii, ind, ipair, ipe, jatom, jj, ncols_blk, npairs_recv, &
1119 npairs_send, nrows_blk, numprocs, pe, recv_encode, send_encode
1120 INTEGER(KIND=int_8), DIMENSION(:), POINTER :: pairs_recv, pairs_send
1121 INTEGER, ALLOCATABLE, DIMENSION(:) :: recv_disps, recv_pair_count, recv_pair_disps, &
1122 recv_sizes, send_disps, send_pair_count, send_pair_disps, send_sizes
1123 INTEGER, DIMENSION(:), POINTER :: col_block_size_data, row_block_size_data
1124 LOGICAL :: check_ok, found
1125 REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: recv_buf, send_buf
1126 REAL(kind=dp), DIMENSION(:, :), POINTER :: mat_block
1127
1128 CALL timeset(routinen, handle)
1129
1130 NULLIFY (pairs_send, pairs_recv, mat_block, &
1131 row_block_size_data, col_block_size_data)
1132
1133 check_ok = fb_com_atom_pairs_has_data(atom_pairs_send)
1134 cpassert(check_ok)
1135 check_ok = fb_com_atom_pairs_has_data(atom_pairs_send)
1136 cpassert(check_ok)
1137 check_ok = fb_matrix_data_has_data(matrix_storage)
1138 cpassert(check_ok)
1139
1140 ! get com pair informations
1141 CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_send, &
1142 pairs=pairs_send, &
1143 npairs=npairs_send, &
1144 natoms_encode=send_encode)
1145 CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_recv, &
1146 pairs=pairs_recv, &
1147 npairs=npairs_recv, &
1148 natoms_encode=recv_encode)
1149 ! get para_env info
1150 numprocs = para_env%num_pe
1151
1152 ! get dbcsr row and col block sizes
1153 CALL dbcsr_get_info(dbcsr_mat, row_blk_size=row_block_size_data, col_blk_size=col_block_size_data)
1154
1155 ! allocate temporary arrays for send
1156 ALLOCATE (send_sizes(numprocs))
1157 ALLOCATE (send_disps(numprocs))
1158 ALLOCATE (send_pair_count(numprocs))
1159 ALLOCATE (send_pair_disps(numprocs))
1160
1161 ! setup send buffer sizes
1162 CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_send, &
1163 numprocs, &
1164 row_block_size_data, &
1165 col_block_size_data, &
1166 send_sizes, &
1167 send_disps, &
1168 send_pair_count, &
1169 send_pair_disps)
1170
1171 ! allocate send buffer
1172 ALLOCATE (send_buf(sum(send_sizes)))
1173
1174 ! allocate temporary arrays for recv
1175 ALLOCATE (recv_sizes(numprocs))
1176 ALLOCATE (recv_disps(numprocs))
1177 ALLOCATE (recv_pair_count(numprocs))
1178 ALLOCATE (recv_pair_disps(numprocs))
1179
1180 ! setup recv buffer sizes
1181 CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_recv, &
1182 numprocs, &
1183 row_block_size_data, &
1184 col_block_size_data, &
1185 recv_sizes, &
1186 recv_disps, &
1187 recv_pair_count, &
1188 recv_pair_disps)
1189
1190 ! allocate recv buffer
1191 ALLOCATE (recv_buf(sum(recv_sizes)))
1192
1193 ! do packing
1194 DO ipe = 1, numprocs
1195 ! need to reuse send_sizes as an accumulative displacement, so recalculate
1196 send_sizes(ipe) = 0
1197 DO ipair = 1, send_pair_count(ipe)
1198 CALL fb_com_atom_pairs_decode(pairs_send(send_pair_disps(ipe) + ipair), &
1199 pe, iatom, jatom, send_encode)
1200 CALL fb_matrix_data_get(matrix_storage, &
1201 iatom, jatom, &
1202 mat_block, found)
1203 IF (.NOT. found) THEN
1204 cpabort("Matrix block not found")
1205 ELSE
1206 nrows_blk = row_block_size_data(iatom)
1207 ncols_blk = col_block_size_data(jatom)
1208 DO jj = 1, ncols_blk
1209 DO ii = 1, nrows_blk
1210 ! column major format in blocks
1211 ind = send_disps(ipe) + send_sizes(ipe) + ii + (jj - 1)*nrows_blk
1212 send_buf(ind) = mat_block(ii, jj)
1213 END DO ! ii
1214 END DO ! jj
1215 send_sizes(ipe) = send_sizes(ipe) + nrows_blk*ncols_blk
1216 END IF
1217 END DO ! ipair
1218 END DO ! ipe
1219
1220 ! do communication
1221 CALL para_env%alltoall(send_buf, send_sizes, send_disps, &
1222 recv_buf, recv_sizes, recv_disps)
1223
1224 ! cleanup temporary arrays no longer needed
1225 DEALLOCATE (send_buf)
1226 DEALLOCATE (send_sizes)
1227 DEALLOCATE (send_disps)
1228 DEALLOCATE (send_pair_count)
1229 DEALLOCATE (send_pair_disps)
1230
1231 ! unpack into DBCSR matrix
1232 DO ipe = 1, numprocs
1233 recv_sizes(ipe) = 0
1234 DO ipair = 1, recv_pair_count(ipe)
1235 CALL fb_com_atom_pairs_decode(pairs_recv(recv_pair_disps(ipe) + ipair), &
1236 pe, iatom, jatom, recv_encode)
1237 nrows_blk = row_block_size_data(iatom)
1238 ncols_blk = col_block_size_data(jatom)
1239 ind = recv_disps(ipe) + recv_sizes(ipe)
1240 CALL dbcsr_put_block(dbcsr_mat, &
1241 iatom, jatom, &
1242 recv_buf((ind + 1):(ind + nrows_blk*ncols_blk)))
1243 recv_sizes(ipe) = recv_sizes(ipe) + nrows_blk*ncols_blk
1244 END DO ! ipair
1245 END DO ! ipe
1246
1247 ! cleanup rest of the temporary arrays
1248 DEALLOCATE (recv_buf)
1249 DEALLOCATE (recv_sizes)
1250 DEALLOCATE (recv_disps)
1251 DEALLOCATE (recv_pair_count)
1252 DEALLOCATE (recv_pair_disps)
1253
1254 ! dbcsr matrix is not finalised in this subroutine
1255
1256 CALL timestop(handle)
1257
1258 END SUBROUTINE fb_com_atom_pairs_distribute_blks
1259
1260END MODULE qs_fb_com_tasks_types
memory_utilities::reallocate
Definition memory_utilities.F:27
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::int_8
integer, parameter, public int_8
Definition kinds.F:54
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
kinds::int_4
integer, parameter, public int_4
Definition kinds.F:51
memory_utilities
Utility routines for the memory handling.
Definition memory_utilities.F:14
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:23
qs_fb_com_tasks_types
Definition qs_fb_com_tasks_types.F:8
qs_fb_com_tasks_types::fb_com_atom_pairs_init
subroutine, public fb_com_atom_pairs_init(atom_pairs)
Initialises an fb_com_atom_pairs object, and makes it empty.
Definition qs_fb_com_tasks_types.F:324
qs_fb_com_tasks_types::task_pair
integer, parameter, public task_pair
Definition qs_fb_com_tasks_types.F:77
qs_fb_com_tasks_types::fb_com_atom_pairs_decode
subroutine, public fb_com_atom_pairs_decode(ind, pe, iatom, jatom, natoms)
Decodes a single integer into the (rank, iatom, jatom) index of a communication task to send/receive ...
Definition qs_fb_com_tasks_types.F:805
qs_fb_com_tasks_types::task_src
integer, parameter, public task_src
Definition qs_fb_com_tasks_types.F:77
qs_fb_com_tasks_types::fb_com_tasks_nullify
subroutine, public fb_com_tasks_nullify(com_tasks)
Nullifies a fb_com_tasks object, note that it does not release the original object....
Definition qs_fb_com_tasks_types.F:193
qs_fb_com_tasks_types::fb_com_tasks_encode_pair
subroutine, public fb_com_tasks_encode_pair(ind, iatom, jatom, natoms)
Encodes (iatom, jatom) pair index of a block into a single integer.
Definition qs_fb_com_tasks_types.F:733
qs_fb_com_tasks_types::fb_com_tasks_decode_pair
subroutine, public fb_com_tasks_decode_pair(ind, iatom, jatom, natoms)
Dncodes a single integer into (iatom, jatom) pair index of a block into a single.
Definition qs_fb_com_tasks_types.F:755
qs_fb_com_tasks_types::fb_com_tasks_get
subroutine, public fb_com_tasks_get(com_tasks, task_dim, ntasks, nencode, tasks)
Gets attributes from a fb_com_tasks object, one should only access the data content in a fb_com_tasks...
Definition qs_fb_com_tasks_types.F:351
qs_fb_com_tasks_types::fb_com_atom_pairs_distribute_blks
subroutine, public fb_com_atom_pairs_distribute_blks(matrix_storage, atom_pairs_send, atom_pairs_recv, para_env, dbcsr_mat)
Given send and recv fb_com_atom_pair object, distribute the matrix blocks stored in a fb_matrix_data ...
Definition qs_fb_com_tasks_types.F:1111
qs_fb_com_tasks_types::fb_com_tasks_build_atom_pairs
subroutine, public fb_com_tasks_build_atom_pairs(com_tasks, atom_pairs, natoms_encode, send_or_recv)
Generate send or receive atom_pair lists from a com_tasks object. atom_pair list is used as a condens...
Definition qs_fb_com_tasks_types.F:641
qs_fb_com_tasks_types::fb_com_atom_pairs_create
subroutine, public fb_com_atom_pairs_create(atom_pairs)
Creates and initialises an empty fb_com_atom_pairs object.
Definition qs_fb_com_tasks_types.F:290
qs_fb_com_tasks_types::fb_com_tasks_transpose_dest_src
subroutine, public fb_com_tasks_transpose_dest_src(tasks_dest_is_me, direction, tasks_src_is_me, para_env)
Start from a local set of tasks that has desc/src process equal to the local MPI rank,...
Definition qs_fb_com_tasks_types.F:474
qs_fb_com_tasks_types::fb_com_atom_pairs_has_data
logical function, public fb_com_atom_pairs_has_data(atom_pairs)
Checks if a fb_com_atom_pairs object is associated with an actual data content or not.
Definition qs_fb_com_tasks_types.F:260
qs_fb_com_tasks_types::fb_com_atom_pairs_get
subroutine, public fb_com_atom_pairs_get(atom_pairs, npairs, natoms_encode, pairs)
Gets attributes from a fb_com_atom_pairs object, one should only access the data content in a fb_com_...
Definition qs_fb_com_tasks_types.F:378
qs_fb_com_tasks_types::fb_com_atom_pairs_nullify
subroutine, public fb_com_atom_pairs_nullify(atom_pairs)
Nullifies a fb_com_atom_pairs object, note that it does not release the original object....
Definition qs_fb_com_tasks_types.F:207
qs_fb_com_tasks_types::fb_com_atom_pairs_release
subroutine, public fb_com_atom_pairs_release(atom_pairs)
Releases an fb_com_atom_pairs object.
Definition qs_fb_com_tasks_types.F:172
qs_fb_com_tasks_types::fb_com_tasks_create
subroutine, public fb_com_tasks_create(com_tasks)
Creates and initialises an empty fb_com_tasks object.
Definition qs_fb_com_tasks_types.F:273
qs_fb_com_tasks_types::task_cost
integer, parameter, public task_cost
Definition qs_fb_com_tasks_types.F:77
qs_fb_com_tasks_types::fb_com_tasks_release
subroutine, public fb_com_tasks_release(com_tasks)
Releases an fb_com_tasks object.
Definition qs_fb_com_tasks_types.F:152
qs_fb_com_tasks_types::fb_com_atom_pairs_gather_blks
subroutine, public fb_com_atom_pairs_gather_blks(dbcsr_mat, atom_pairs_send, atom_pairs_recv, para_env, matrix_storage)
Given send and recv fb_com_atom_pair object, gather all the relevant DBCSR matrix blocks together,...
Definition qs_fb_com_tasks_types.F:926
qs_fb_com_tasks_types::fb_com_tasks_set
subroutine, public fb_com_tasks_set(com_tasks, task_dim, ntasks, nencode, tasks)
Sets attributes in a fb_com_tasks object, one should only access the data content in a fb_com_tasks o...
Definition qs_fb_com_tasks_types.F:406
qs_fb_com_tasks_types::task_dest
integer, parameter, public task_dest
Definition qs_fb_com_tasks_types.F:77
qs_fb_com_tasks_types::task_n_records
integer, parameter, public task_n_records
Definition qs_fb_com_tasks_types.F:75
qs_fb_com_tasks_types::fb_com_atom_pairs_calc_buffer_sizes
subroutine, public fb_com_atom_pairs_calc_buffer_sizes(atom_pairs, nprocs, row_blk_sizes, col_blk_sizes, sendrecv_sizes, sendrecv_disps, sendrecv_pair_counts, sendrecv_pair_disps)
Calculate the MPI send or recv buffer sizes according to the communication pairs (atom_pairs) and DBC...
Definition qs_fb_com_tasks_types.F:855
qs_fb_matrix_data_types
Definition qs_fb_matrix_data_types.F:8
qs_fb_matrix_data_types::fb_matrix_data_has_data
pure logical function, public fb_matrix_data_has_data(matrix_data)
check if the object has data associated to it
Definition qs_fb_matrix_data_types.F:211
qs_fb_matrix_data_types::fb_matrix_data_add
subroutine, public fb_matrix_data_add(matrix_data, row, col, blk)
Add a matrix block to a fb_matrix_data object.
Definition qs_fb_matrix_data_types.F:92
qs_fb_matrix_data_types::fb_matrix_data_get
subroutine, public fb_matrix_data_get(matrix_data, row, col, blk_p, found)
retrieve a matrix block from a matrix_data object
Definition qs_fb_matrix_data_types.F:181
util
All kind of helpful little routines.
Definition util.F:14
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:763
qs_fb_com_tasks_types::fb_com_atom_pairs_obj
defines a fb_com_atom_pairs object
Definition qs_fb_com_tasks_types.F:138
qs_fb_com_tasks_types::fb_com_tasks_obj
defines a fb_com_tasks object
Definition qs_fb_com_tasks_types.F:109
qs_fb_matrix_data_types::fb_matrix_data_obj
the object container which allows for the creation of an array of pointers to fb_matrix_data objects
Definition qs_fb_matrix_data_types.F:77