LCOV - code coverage report
Current view: top level - src - rpa_communication.F (source / functions) Coverage Total Hit
Test: CP2K Regtests (git:42dac4a) Lines: 75.2 % 230 173
Test Date: 2025-07-25 12:55:17 Functions: 50.0 % 4 2

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

Generated by: LCOV version 2.0-1