LCOV - code coverage report
Current view: top level - src - rpa_communication.F (source / functions) Hit Total Coverage
Test: CP2K Regtests (git:0de0cc2) Lines: 174 232 75.0 %
Date: 2024-03-28 07:31:50 Functions: 2 4 50.0 %

          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 Auxiliary routines necessary to redistribute an fm_matrix from a
      10             : !>        given blacs_env to another
      11             : !> \par History
      12             : !>      12.2012 created [Mauro Del Ben]
      13             : ! **************************************************************************************************
      14             : MODULE rpa_communication
      15             :    USE cp_blacs_env,                    ONLY: cp_blacs_env_create,&
      16             :                                               cp_blacs_env_release,&
      17             :                                               cp_blacs_env_type
      18             :    USE cp_dbcsr_operations,             ONLY: copy_fm_to_dbcsr,&
      19             :                                               cp_dbcsr_m_by_n_from_template,&
      20             :                                               dbcsr_allocate_matrix_set
      21             :    USE cp_fm_struct,                    ONLY: cp_fm_struct_create,&
      22             :                                               cp_fm_struct_release,&
      23             :                                               cp_fm_struct_type
      24             :    USE cp_fm_types,                     ONLY: cp_fm_create,&
      25             :                                               cp_fm_get_info,&
      26             :                                               cp_fm_indxg2l,&
      27             :                                               cp_fm_indxg2p,&
      28             :                                               cp_fm_release,&
      29             :                                               cp_fm_set_all,&
      30             :                                               cp_fm_type
      31             :    USE dbcsr_api,                       ONLY: dbcsr_p_type,&
      32             :                                               dbcsr_type,&
      33             :                                               dbcsr_type_no_symmetry
      34             :    USE group_dist_types,                ONLY: create_group_dist,&
      35             :                                               get_group_dist,&
      36             :                                               group_dist_d1_type,&
      37             :                                               release_group_dist
      38             :    USE kinds,                           ONLY: dp
      39             :    USE message_passing,                 ONLY: mp_para_env_type,&
      40             :                                               mp_request_null,&
      41             :                                               mp_request_type,&
      42             :                                               mp_waitall
      43             :    USE mp2_ri_grad_util,                ONLY: fm2array,&
      44             :                                               prepare_redistribution
      45             :    USE mp2_types,                       ONLY: integ_mat_buffer_type
      46             :    USE util,                            ONLY: get_limit
      47             : #include "./base/base_uses.f90"
      48             : 
      49             :    IMPLICIT NONE
      50             : 
      51             :    PRIVATE
      52             : 
      53             :    TYPE index_map
      54             :       INTEGER, DIMENSION(:, :), ALLOCATABLE :: map
      55             :    END TYPE
      56             : 
      57             :    CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'rpa_communication'
      58             : 
      59             :    PUBLIC :: gamma_fm_to_dbcsr, &
      60             :              communicate_buffer
      61             : 
      62             : CONTAINS
      63             : 
      64             : ! **************************************************************************************************
      65             : !> \brief Redistribute RPA-AXK Gamma_3 density matrices: from fm to dbcsr
      66             : !> \param fm_mat_Gamma_3 ... ia*dime_RI sized density matrix (fm type on para_env_RPA)
      67             : !> \param dbcsr_Gamma_3 ...  redistributed Gamma_3 (dbcsr array): dimen_RI of i*a: i*a on subgroup, L distributed in RPA_group
      68             : !> \param para_env_RPA ...
      69             : !> \param para_env_sub ...
      70             : !> \param homo ...
      71             : !> \param virtual ...
      72             : !> \param mo_coeff_o ...   dbcsr on a subgroup
      73             : !> \param ngroup ...
      74             : !> \param my_group_L_start ...
      75             : !> \param my_group_L_end ...
      76             : !> \param my_group_L_size ...
      77             : !> \author Vladimir Rybkin, 07/2016
      78             : ! **************************************************************************************************
      79          14 :    SUBROUTINE gamma_fm_to_dbcsr(fm_mat_Gamma_3, dbcsr_Gamma_3, para_env_RPA, para_env_sub, &
      80             :                                 homo, virtual, mo_coeff_o, ngroup, my_group_L_start, my_group_L_end, &
      81             :                                 my_group_L_size)
      82             :       TYPE(cp_fm_type), INTENT(INOUT)                    :: fm_mat_Gamma_3
      83             :       TYPE(dbcsr_p_type), DIMENSION(:), POINTER          :: dbcsr_Gamma_3
      84             :       TYPE(mp_para_env_type), INTENT(IN)                 :: para_env_RPA
      85             :       TYPE(mp_para_env_type), INTENT(IN), POINTER        :: para_env_sub
      86             :       INTEGER, INTENT(IN)                                :: homo, virtual
      87             :       TYPE(dbcsr_type), POINTER                          :: mo_coeff_o
      88             :       INTEGER, INTENT(IN)                                :: ngroup, my_group_L_start, &
      89             :                                                             my_group_L_end, my_group_L_size
      90             : 
      91             :       CHARACTER(LEN=*), PARAMETER                        :: routineN = 'gamma_fm_to_dbcsr'
      92             : 
      93             :       INTEGER :: dimen_ia, dummy_proc, handle, i_global, i_local, iaia, iib, iii, itmp(2), &
      94             :          j_global, j_local, jjb, jjj, kkb, my_ia_end, my_ia_size, my_ia_start, mypcol, myprow, &
      95             :          ncol_block, ncol_local, npcol, nprow, nrow_block, nrow_local, number_of_rec, &
      96             :          number_of_send, proc_receive, proc_send, proc_shift, rec_counter, rec_iaia_end, &
      97             :          rec_iaia_size, rec_iaia_start, rec_pcol, rec_prow, ref_send_pcol, ref_send_prow, &
      98             :          send_counter, send_pcol, send_prow, size_rec_buffer, size_send_buffer
      99          14 :       INTEGER, ALLOCATABLE, DIMENSION(:)                 :: iii_vet, map_rec_size, map_send_size
     100          14 :       INTEGER, ALLOCATABLE, DIMENSION(:, :)              :: grid_2_mepos, grid_ref_2_send_pos, &
     101          14 :                                                             group_grid_2_mepos, indices_map_my, &
     102          14 :                                                             mepos_2_grid, mepos_2_grid_group
     103          14 :       INTEGER, DIMENSION(:), POINTER                     :: col_indices, row_indices
     104             :       REAL(KIND=dp)                                      :: part_ia
     105          14 :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :)        :: Gamma_2D
     106             :       TYPE(cp_blacs_env_type), POINTER                   :: blacs_env
     107             :       TYPE(cp_fm_struct_type), POINTER                   :: fm_struct
     108             :       TYPE(cp_fm_type)                                   :: fm_ia
     109          14 :       TYPE(group_dist_d1_type)                           :: gd_ia
     110          14 :       TYPE(index_map), ALLOCATABLE, DIMENSION(:)         :: indices_rec
     111             :       TYPE(integ_mat_buffer_type), ALLOCATABLE, &
     112          14 :          DIMENSION(:)                                    :: buffer_rec, buffer_send
     113          14 :       TYPE(mp_request_type), ALLOCATABLE, DIMENSION(:)   :: req_send
     114             : 
     115          14 :       CALL timeset(routineN, handle)
     116             : 
     117          14 :       dimen_ia = virtual*homo
     118             : 
     119             :       ! Prepare sizes for a 2D array
     120          14 :       CALL create_group_dist(gd_ia, para_env_sub%num_pe, dimen_ia)
     121          14 :       CALL get_group_dist(gd_ia, para_env_sub%mepos, my_ia_start, my_ia_end, my_ia_size)
     122             : 
     123             :       ! Make a 2D array intermediate
     124             : 
     125             :       CALL prepare_redistribution(para_env_RPA, para_env_sub, ngroup, &
     126             :                                   group_grid_2_mepos, mepos_2_grid_group)
     127             : 
     128             :       ! fm_mat_Gamma_3 is released here
     129             :       CALL fm2array(Gamma_2D, my_ia_size, my_ia_start, my_ia_end, &
     130             :                     my_group_L_size, my_group_L_start, my_group_L_end, &
     131             :                     group_grid_2_mepos, mepos_2_grid_group, &
     132             :                     para_env_sub%num_pe, ngroup, &
     133          14 :                     fm_mat_Gamma_3)
     134             : 
     135             :       ! create sub blacs env
     136          14 :       NULLIFY (blacs_env)
     137          14 :       CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env_sub)
     138             : 
     139             :       ! create the fm_ia buffer matrix
     140          14 :       NULLIFY (fm_struct)
     141             :       CALL cp_fm_struct_create(fm_struct, context=blacs_env, nrow_global=homo, &
     142          14 :                                ncol_global=virtual, para_env=para_env_sub)
     143          14 :       CALL cp_fm_create(fm_ia, fm_struct, name="fm_ia")
     144             : 
     145             :       ! release structure
     146          14 :       CALL cp_fm_struct_release(fm_struct)
     147             :       ! release blacs_env
     148          14 :       CALL cp_blacs_env_release(blacs_env)
     149             : 
     150             :       ! get array information
     151             :       CALL cp_fm_get_info(matrix=fm_ia, &
     152             :                           nrow_local=nrow_local, &
     153             :                           ncol_local=ncol_local, &
     154             :                           row_indices=row_indices, &
     155             :                           col_indices=col_indices, &
     156             :                           nrow_block=nrow_block, &
     157          14 :                           ncol_block=ncol_block)
     158          14 :       myprow = fm_ia%matrix_struct%context%mepos(1)
     159          14 :       mypcol = fm_ia%matrix_struct%context%mepos(2)
     160          14 :       nprow = fm_ia%matrix_struct%context%num_pe(1)
     161          14 :       npcol = fm_ia%matrix_struct%context%num_pe(2)
     162             : 
     163             :       ! 0) create array containing the processes position and supporting infos
     164          56 :       ALLOCATE (grid_2_mepos(0:nprow - 1, 0:npcol - 1))
     165          42 :       grid_2_mepos = 0
     166          42 :       ALLOCATE (mepos_2_grid(2, 0:para_env_sub%num_pe - 1))
     167             :       ! fill the info array
     168          14 :       grid_2_mepos(myprow, mypcol) = para_env_sub%mepos
     169             :       ! sum infos
     170          14 :       CALL para_env_sub%sum(grid_2_mepos)
     171          42 :       CALL para_env_sub%allgather([myprow, mypcol], mepos_2_grid)
     172             : 
     173             :       ! loop over local index range and define the sending map
     174          42 :       ALLOCATE (map_send_size(0:para_env_sub%num_pe - 1))
     175          28 :       map_send_size = 0
     176          14 :       dummy_proc = 0
     177        1078 :       DO iaia = my_ia_start, my_ia_end
     178        1064 :          i_global = (iaia - 1)/virtual + 1
     179        1064 :          j_global = MOD(iaia - 1, virtual) + 1
     180             :          send_prow = cp_fm_indxg2p(i_global, nrow_block, dummy_proc, &
     181        1064 :                                    fm_ia%matrix_struct%first_p_pos(1), nprow)
     182             :          send_pcol = cp_fm_indxg2p(j_global, ncol_block, dummy_proc, &
     183        1064 :                                    fm_ia%matrix_struct%first_p_pos(2), npcol)
     184        1064 :          proc_send = grid_2_mepos(send_prow, send_pcol)
     185        1078 :          map_send_size(proc_send) = map_send_size(proc_send) + 1
     186             :       END DO
     187             : 
     188             :       ! loop over local data of fm_ia and define the receiving map
     189          42 :       ALLOCATE (map_rec_size(0:para_env_sub%num_pe - 1))
     190          28 :       map_rec_size = 0
     191          14 :       part_ia = REAL(dimen_ia, KIND=dp)/REAL(para_env_sub%num_pe, KIND=dp)
     192             : 
     193          70 :       DO iiB = 1, nrow_local
     194          56 :          i_global = row_indices(iiB)
     195        1134 :          DO jjB = 1, ncol_local
     196        1064 :             j_global = col_indices(jjB)
     197        1064 :             iaia = (i_global - 1)*virtual + j_global
     198        1064 :             proc_receive = INT(REAL(iaia - 1, KIND=dp)/part_ia)
     199        1064 :             proc_receive = MAX(0, proc_receive)
     200        1064 :             proc_receive = MIN(proc_receive, para_env_sub%num_pe - 1)
     201             :             DO
     202        1064 :                itmp = get_limit(dimen_ia, para_env_sub%num_pe, proc_receive)
     203        1064 :                IF (iaia >= itmp(1) .AND. iaia <= itmp(2)) EXIT
     204           0 :                IF (iaia < itmp(1)) proc_receive = proc_receive - 1
     205           0 :                IF (iaia > itmp(2)) proc_receive = proc_receive + 1
     206             :             END DO
     207        1120 :             map_rec_size(proc_receive) = map_rec_size(proc_receive) + 1
     208             :          END DO
     209             :       END DO
     210             : 
     211             :       ! allocate the buffer for sending data
     212          14 :       number_of_send = 0
     213          14 :       DO proc_shift = 1, para_env_sub%num_pe - 1
     214           0 :          proc_send = MODULO(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
     215          14 :          IF (map_send_size(proc_send) > 0) THEN
     216           0 :             number_of_send = number_of_send + 1
     217             :          END IF
     218             :       END DO
     219             :       ! allocate the structure that will hold the messages to be sent
     220          28 :       ALLOCATE (buffer_send(number_of_send))
     221             :       ! and the map from the grid of processess to the message position
     222          56 :       ALLOCATE (grid_ref_2_send_pos(0:nprow - 1, 0:npcol - 1))
     223          42 :       grid_ref_2_send_pos = 0
     224             :       ! finally allocate each message
     225          14 :       send_counter = 0
     226          14 :       DO proc_shift = 1, para_env_sub%num_pe - 1
     227           0 :          proc_send = MODULO(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
     228           0 :          size_send_buffer = map_send_size(proc_send)
     229          14 :          IF (map_send_size(proc_send) > 0) THEN
     230           0 :             send_counter = send_counter + 1
     231             :             ! allocate the sending buffer (msg)
     232           0 :             ALLOCATE (buffer_send(send_counter)%msg(size_send_buffer))
     233           0 :             buffer_send(send_counter)%proc = proc_send
     234             :             ! get the pointer to prow, pcol of the process that has
     235             :             ! to receive this message
     236           0 :             ref_send_prow = mepos_2_grid(1, proc_send)
     237           0 :             ref_send_pcol = mepos_2_grid(2, proc_send)
     238             :             ! save the rank of the process that has to receive this message
     239           0 :             grid_ref_2_send_pos(ref_send_prow, ref_send_pcol) = send_counter
     240             :          END IF
     241             :       END DO
     242             : 
     243             :       ! allocate the buffer for receiving data
     244             :       number_of_rec = 0
     245          14 :       DO proc_shift = 1, para_env_sub%num_pe - 1
     246           0 :          proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
     247          14 :          IF (map_rec_size(proc_receive) > 0) THEN
     248           0 :             number_of_rec = number_of_rec + 1
     249             :          END IF
     250             :       END DO
     251             : 
     252             :       ! allocate the structure that will hold the messages to be received
     253             :       ! and relative indeces
     254          28 :       ALLOCATE (buffer_rec(number_of_rec))
     255          28 :       ALLOCATE (indices_rec(number_of_rec))
     256             :       ! finally allocate each message and fill the array of indeces
     257          14 :       rec_counter = 0
     258          14 :       DO proc_shift = 1, para_env_sub%num_pe - 1
     259           0 :          proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
     260           0 :          size_rec_buffer = map_rec_size(proc_receive)
     261          14 :          IF (map_rec_size(proc_receive) > 0) THEN
     262           0 :             rec_counter = rec_counter + 1
     263             :             ! prepare the buffer for receive
     264           0 :             ALLOCATE (buffer_rec(rec_counter)%msg(size_rec_buffer))
     265           0 :             buffer_rec(rec_counter)%proc = proc_receive
     266             :             ! create the indices array
     267           0 :             ALLOCATE (indices_rec(rec_counter)%map(2, size_rec_buffer))
     268           0 :             indices_rec(rec_counter)%map = 0
     269           0 :             CALL get_group_dist(gd_ia, proc_receive, rec_iaia_start, rec_iaia_end, rec_iaia_size)
     270           0 :             iii = 0
     271           0 :             DO iaia = rec_iaia_start, rec_iaia_end
     272           0 :                i_global = (iaia - 1)/virtual + 1
     273           0 :                j_global = MOD(iaia - 1, virtual) + 1
     274             :                rec_prow = cp_fm_indxg2p(i_global, nrow_block, dummy_proc, &
     275           0 :                                         fm_ia%matrix_struct%first_p_pos(1), nprow)
     276             :                rec_pcol = cp_fm_indxg2p(j_global, ncol_block, dummy_proc, &
     277           0 :                                         fm_ia%matrix_struct%first_p_pos(2), npcol)
     278           0 :                IF (grid_2_mepos(rec_prow, rec_pcol) /= para_env_sub%mepos) CYCLE
     279           0 :                iii = iii + 1
     280             :                i_local = cp_fm_indxg2l(i_global, nrow_block, dummy_proc, &
     281           0 :                                        fm_ia%matrix_struct%first_p_pos(1), nprow)
     282             :                j_local = cp_fm_indxg2l(j_global, ncol_block, dummy_proc, &
     283           0 :                                        fm_ia%matrix_struct%first_p_pos(2), npcol)
     284           0 :                indices_rec(rec_counter)%map(1, iii) = i_local
     285           0 :                indices_rec(rec_counter)%map(2, iii) = j_local
     286             :             END DO
     287             :          END IF
     288             :       END DO
     289             : 
     290             :       ! and create the index map for my local data
     291          14 :       IF (map_rec_size(para_env_sub%mepos) > 0) THEN
     292          14 :          size_rec_buffer = map_rec_size(para_env_sub%mepos)
     293          42 :          ALLOCATE (indices_map_my(2, size_rec_buffer))
     294        3206 :          indices_map_my = 0
     295             :          iii = 0
     296        1078 :          DO iaia = my_ia_start, my_ia_end
     297        1064 :             i_global = (iaia - 1)/virtual + 1
     298        1064 :             j_global = MOD(iaia - 1, virtual) + 1
     299             :             rec_prow = cp_fm_indxg2p(i_global, nrow_block, dummy_proc, &
     300        1064 :                                      fm_ia%matrix_struct%first_p_pos(1), nprow)
     301             :             rec_pcol = cp_fm_indxg2p(j_global, ncol_block, dummy_proc, &
     302        1064 :                                      fm_ia%matrix_struct%first_p_pos(2), npcol)
     303        1064 :             IF (grid_2_mepos(rec_prow, rec_pcol) /= para_env_sub%mepos) CYCLE
     304        1064 :             iii = iii + 1
     305             :             i_local = cp_fm_indxg2l(i_global, nrow_block, dummy_proc, &
     306        1064 :                                     fm_ia%matrix_struct%first_p_pos(1), nprow)
     307             :             j_local = cp_fm_indxg2l(j_global, ncol_block, dummy_proc, &
     308        1064 :                                     fm_ia%matrix_struct%first_p_pos(2), npcol)
     309        1064 :             indices_map_my(1, iii) = i_local
     310        1078 :             indices_map_my(2, iii) = j_local
     311             :          END DO
     312             :       END IF
     313             : 
     314             :       ! Allocate dbcsr_Gamma_3
     315          14 :       NULLIFY (dbcsr_Gamma_3)
     316             : 
     317             :       !CALL dbcsr_allocate_matrix_set(dbcsr_Gamma_3, ncol_local)
     318          14 :       CALL dbcsr_allocate_matrix_set(dbcsr_Gamma_3, my_group_L_size)
     319             : 
     320             :       ! auxiliary vector of indices for the send buffer
     321          28 :       ALLOCATE (iii_vet(number_of_send))
     322             :       ! vector for the send requests
     323          42 :       ALLOCATE (req_send(number_of_send))
     324             :       ! loop over auxiliary basis function and redistribute into a fm
     325             :       ! and then compy the fm into a dbcsr matrix
     326             : 
     327             :       !DO kkB = 1, ncol_local
     328         470 :       DO kkB = 1, my_group_L_size
     329             :          ! zero the matries of the buffers and post the messages to be received
     330         456 :          CALL cp_fm_set_all(matrix=fm_ia, alpha=0.0_dp)
     331         456 :          rec_counter = 0
     332         456 :          DO proc_shift = 1, para_env_sub%num_pe - 1
     333           0 :             proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
     334         456 :             IF (map_rec_size(proc_receive) > 0) THEN
     335           0 :                rec_counter = rec_counter + 1
     336           0 :                buffer_rec(rec_counter)%msg = 0.0_dp
     337             :                CALL para_env_sub%irecv(buffer_rec(rec_counter)%msg, proc_receive, &
     338           0 :                                        buffer_rec(rec_counter)%msg_req)
     339             :             END IF
     340             :          END DO
     341             :          ! fill the sending buffer and send the messages
     342         456 :          DO send_counter = 1, number_of_send
     343         456 :             buffer_send(send_counter)%msg = 0.0_dp
     344             :          END DO
     345         456 :          iii_vet = 0
     346             :          jjj = 0
     347       35112 :          DO iaia = my_ia_start, my_ia_end
     348       34656 :             i_global = (iaia - 1)/virtual + 1
     349       34656 :             j_global = MOD(iaia - 1, virtual) + 1
     350             :             send_prow = cp_fm_indxg2p(i_global, nrow_block, dummy_proc, &
     351       34656 :                                       fm_ia%matrix_struct%first_p_pos(1), nprow)
     352             :             send_pcol = cp_fm_indxg2p(j_global, ncol_block, dummy_proc, &
     353       34656 :                                       fm_ia%matrix_struct%first_p_pos(2), npcol)
     354       34656 :             proc_send = grid_2_mepos(send_prow, send_pcol)
     355             :             ! we don't need to send to ourselves
     356       35112 :             IF (grid_2_mepos(send_prow, send_pcol) == para_env_sub%mepos) THEN
     357             :                ! filling fm_ia with local data
     358       34656 :                jjj = jjj + 1
     359       34656 :                i_local = indices_map_my(1, jjj)
     360       34656 :                j_local = indices_map_my(2, jjj)
     361             :                fm_ia%local_data(i_local, j_local) = &
     362       34656 :                   Gamma_2D(iaia - my_ia_start + 1, kkB)
     363             : 
     364             :             ELSE
     365           0 :                send_counter = grid_ref_2_send_pos(send_prow, send_pcol)
     366           0 :                iii_vet(send_counter) = iii_vet(send_counter) + 1
     367           0 :                iii = iii_vet(send_counter)
     368             :                buffer_send(send_counter)%msg(iii) = &
     369           0 :                   Gamma_2D(iaia - my_ia_start + 1, kkB)
     370             :             END IF
     371             :          END DO
     372         456 :          req_send = mp_request_null
     373         456 :          send_counter = 0
     374         456 :          DO proc_shift = 1, para_env_sub%num_pe - 1
     375           0 :             proc_send = MODULO(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
     376         456 :             IF (map_send_size(proc_send) > 0) THEN
     377           0 :                send_counter = send_counter + 1
     378             :                CALL para_env_sub%isend(buffer_send(send_counter)%msg, proc_send, &
     379           0 :                                        buffer_send(send_counter)%msg_req)
     380           0 :                req_send(send_counter) = buffer_send(send_counter)%msg_req
     381             :             END IF
     382             :          END DO
     383             : 
     384             :          ! receive the messages and fill the fm_ia
     385         456 :          rec_counter = 0
     386         456 :          DO proc_shift = 1, para_env_sub%num_pe - 1
     387           0 :             proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
     388           0 :             size_rec_buffer = map_rec_size(proc_receive)
     389         456 :             IF (map_rec_size(proc_receive) > 0) THEN
     390           0 :                rec_counter = rec_counter + 1
     391             :                ! wait for the message
     392           0 :                CALL buffer_rec(rec_counter)%msg_req%wait()
     393           0 :                DO iii = 1, size_rec_buffer
     394           0 :                   i_local = indices_rec(rec_counter)%map(1, iii)
     395           0 :                   j_local = indices_rec(rec_counter)%map(2, iii)
     396           0 :                   fm_ia%local_data(i_local, j_local) = buffer_rec(rec_counter)%msg(iii)
     397             :                END DO
     398             :             END IF
     399             :          END DO
     400             : 
     401             :          ! wait all
     402         456 :          CALL mp_waitall(req_send(:))
     403             : 
     404             :          ! now create the DBCSR matrix and copy fm_ia into it
     405         456 :          ALLOCATE (dbcsr_Gamma_3(kkB)%matrix)
     406             :          CALL cp_dbcsr_m_by_n_from_template(dbcsr_Gamma_3(kkB)%matrix, &
     407             :                                             template=mo_coeff_o, &
     408         456 :                                             m=homo, n=virtual, sym=dbcsr_type_no_symmetry)
     409         470 :          CALL copy_fm_to_dbcsr(fm_ia, dbcsr_Gamma_3(kkB)%matrix, keep_sparsity=.FALSE.)
     410             : 
     411             :       END DO
     412             : 
     413             :       ! Deallocate memory
     414             : 
     415          14 :       DEALLOCATE (Gamma_2d)
     416          14 :       DEALLOCATE (iii_vet)
     417          14 :       DEALLOCATE (req_send)
     418          14 :       IF (map_rec_size(para_env_sub%mepos) > 0) THEN
     419          14 :          DEALLOCATE (indices_map_my)
     420             :       END IF
     421          14 :       DO rec_counter = 1, number_of_rec
     422           0 :          DEALLOCATE (indices_rec(rec_counter)%map)
     423          14 :          DEALLOCATE (buffer_rec(rec_counter)%msg)
     424             :       END DO
     425          14 :       DEALLOCATE (indices_rec)
     426          14 :       DEALLOCATE (buffer_rec)
     427          14 :       DO send_counter = 1, number_of_send
     428          14 :          DEALLOCATE (buffer_send(send_counter)%msg)
     429             :       END DO
     430          14 :       DEALLOCATE (buffer_send)
     431          14 :       DEALLOCATE (map_send_size)
     432          14 :       DEALLOCATE (map_rec_size)
     433          14 :       DEALLOCATE (grid_2_mepos)
     434          14 :       DEALLOCATE (mepos_2_grid)
     435          14 :       CALL release_group_dist(gd_ia)
     436             : 
     437             :       ! release buffer matrix
     438          14 :       CALL cp_fm_release(fm_ia)
     439             : 
     440          14 :       CALL timestop(handle)
     441             : 
     442          56 :    END SUBROUTINE gamma_fm_to_dbcsr
     443             : 
     444             : ! **************************************************************************************************
     445             : !> \brief ...
     446             : !> \param para_env ...
     447             : !> \param num_entries_rec ...
     448             : !> \param num_entries_send ...
     449             : !> \param buffer_rec ...
     450             : !> \param buffer_send ...
     451             : !> \param req_array ...
     452             : !> \param do_indx ...
     453             : !> \param do_msg ...
     454             : ! **************************************************************************************************
     455         154 :    SUBROUTINE communicate_buffer(para_env, num_entries_rec, num_entries_send, buffer_rec, buffer_send, &
     456             :                                  req_array, do_indx, do_msg)
     457             : 
     458             :       TYPE(mp_para_env_type), INTENT(IN)                 :: para_env
     459             :       INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(IN)     :: num_entries_rec, num_entries_send
     460             :       TYPE(integ_mat_buffer_type), ALLOCATABLE, &
     461             :          DIMENSION(:), INTENT(INOUT)                     :: buffer_rec, buffer_send
     462             :       TYPE(mp_request_type), DIMENSION(:, :), POINTER    :: req_array
     463             :       LOGICAL, INTENT(IN), OPTIONAL                      :: do_indx, do_msg
     464             : 
     465             :       CHARACTER(LEN=*), PARAMETER :: routineN = 'communicate_buffer'
     466             : 
     467             :       INTEGER                                            :: handle, imepos, rec_counter, send_counter
     468             :       LOGICAL                                            :: my_do_indx, my_do_msg
     469             : 
     470         154 :       CALL timeset(routineN, handle)
     471             : 
     472         154 :       my_do_indx = .TRUE.
     473         154 :       IF (PRESENT(do_indx)) my_do_indx = do_indx
     474         154 :       my_do_msg = .TRUE.
     475         154 :       IF (PRESENT(do_msg)) my_do_msg = do_msg
     476             : 
     477         154 :       IF (para_env%num_pe > 1) THEN
     478             : 
     479         154 :          send_counter = 0
     480         154 :          rec_counter = 0
     481             : 
     482         462 :          DO imepos = 0, para_env%num_pe - 1
     483         462 :             IF (num_entries_rec(imepos) > 0) THEN
     484         292 :                rec_counter = rec_counter + 1
     485         292 :                IF (my_do_indx) THEN
     486         292 :                   CALL para_env%irecv(buffer_rec(imepos)%indx, imepos, req_array(rec_counter, 3), tag=4)
     487             :                END IF
     488         292 :                IF (my_do_msg) THEN
     489         292 :                   CALL para_env%irecv(buffer_rec(imepos)%msg, imepos, req_array(rec_counter, 4), tag=7)
     490             :                END IF
     491             :             END IF
     492             :          END DO
     493             : 
     494         462 :          DO imepos = 0, para_env%num_pe - 1
     495         462 :             IF (num_entries_send(imepos) > 0) THEN
     496         292 :                send_counter = send_counter + 1
     497         292 :                IF (my_do_indx) THEN
     498         292 :                   CALL para_env%isend(buffer_send(imepos)%indx, imepos, req_array(send_counter, 1), tag=4)
     499             :                END IF
     500         292 :                IF (my_do_msg) THEN
     501         292 :                   CALL para_env%isend(buffer_send(imepos)%msg, imepos, req_array(send_counter, 2), tag=7)
     502             :                END IF
     503             :             END IF
     504             :          END DO
     505             : 
     506         154 :          IF (my_do_indx) THEN
     507         154 :             CALL mp_waitall(req_array(1:send_counter, 1))
     508         154 :             CALL mp_waitall(req_array(1:rec_counter, 3))
     509             :          END IF
     510             : 
     511         154 :          IF (my_do_msg) THEN
     512         154 :             CALL mp_waitall(req_array(1:send_counter, 2))
     513         154 :             CALL mp_waitall(req_array(1:rec_counter, 4))
     514             :          END IF
     515             : 
     516             :       ELSE
     517             : 
     518           0 :          buffer_rec(0)%indx(:, :) = buffer_send(0)%indx
     519           0 :          buffer_rec(0)%msg(:) = buffer_send(0)%msg
     520             : 
     521             :       END IF
     522             : 
     523         154 :       CALL timestop(handle)
     524             : 
     525         154 :    END SUBROUTINE communicate_buffer
     526             : 
     527           0 : END MODULE rpa_communication

Generated by: LCOV version 1.15