LCOV - code coverage report
Current view: top level - src - mp2_ri_grad_util.F (source / functions) Coverage Total Hit
Test: CP2K Regtests (git:9ccafda) Lines: 98.5 % 131 129
Test Date: 2026-10-15 00:55:44 Functions: 100.0 % 3 3

            Line data    Source code
       1              : !--------------------------------------------------------------------------------------------------!
       2              : !   CP2K: A general program to perform molecular dynamics simulations                              !
       3              : !   Copyright 2000-2026 CP2K developers group <https://cp2k.org>                                   !
       4              : !                                                                                                  !
       5              : !   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
       6              : !--------------------------------------------------------------------------------------------------!
       7              : 
       8              : ! **************************************************************************************************
       9              : !> \brief Routines for calculating RI-MP2 gradients
      10              : !> \par History
      11              : !>      10.2013 created [Mauro Del Ben]
      12              : ! **************************************************************************************************
      13              : MODULE mp2_ri_grad_util
      14              : !
      15              :    USE cp_blacs_env,                    ONLY: cp_blacs_env_create,&
      16              :                                               cp_blacs_env_release,&
      17              :                                               cp_blacs_env_type
      18              :    USE cp_dbcsr_redistribution,         ONLY: cp_array_to_dbcsr_slices
      19              :    USE cp_fm_basic_linalg,              ONLY: cp_fm_geadd
      20              :    USE cp_fm_redistribution,            ONLY: cp_array_to_fm,&
      21              :                                               cp_fm_to_array
      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_release,&
      27              :                                               cp_fm_to_fm,&
      28              :                                               cp_fm_type
      29              :    USE group_dist_types,                ONLY: create_group_dist,&
      30              :                                               get_group_dist,&
      31              :                                               group_dist_d1_type,&
      32              :                                               release_group_dist
      33              :    USE kinds,                           ONLY: dp
      34              :    USE libint_2c_3c,                    ONLY: compare_potential_types
      35              :    USE message_passing,                 ONLY: mp_para_env_type
      36              :    USE mp2_types,                       ONLY: mp2_type
      37              :    USE parallel_gemm_api,               ONLY: parallel_gemm
      38              : #include "./base/base_uses.f90"
      39              : 
      40              :    IMPLICIT NONE
      41              : 
      42              :    PRIVATE
      43              : 
      44              :    CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mp2_ri_grad_util'
      45              : 
      46              :    PUBLIC :: complete_gamma
      47              : 
      48              : CONTAINS
      49              : 
      50              : ! **************************************************************************************************
      51              : !> \brief complete the calculation of the Gamma matrices
      52              : !> \param mp2_env ...
      53              : !> \param B_ia_Q ...
      54              : !> \param dimen_RI ...
      55              : !> \param homo ...
      56              : !> \param virtual ...
      57              : !> \param para_env ...
      58              : !> \param para_env_sub ...
      59              : !> \param my_group_L_size ...
      60              : !> \param my_group_L_start ...
      61              : !> \param my_group_L_end ...
      62              : !> \param my_B_size ...
      63              : !> \param my_B_virtual_start ...
      64              : !> \param gd_B_virtual ...
      65              : !> \param kspin ...
      66              : !> \author Mauro Del Ben
      67              : ! **************************************************************************************************
      68          306 :    SUBROUTINE complete_gamma(mp2_env, B_ia_Q, dimen_RI, homo, virtual, para_env, para_env_sub, my_group_L_size, &
      69              :                              my_group_L_start, my_group_L_end, my_B_size, my_B_virtual_start, gd_B_virtual, kspin)
      70              : 
      71              :       TYPE(mp2_type)                                     :: mp2_env
      72              :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
      73              :          INTENT(INOUT)                                   :: B_ia_Q
      74              :       INTEGER, INTENT(IN)                                :: dimen_RI, homo, virtual
      75              :       TYPE(mp_para_env_type), INTENT(IN), POINTER        :: para_env, para_env_sub
      76              :       INTEGER, INTENT(IN)                                :: my_group_L_size, my_group_L_start, &
      77              :                                                             my_group_L_end, my_B_size, &
      78              :                                                             my_B_virtual_start
      79              :       TYPE(group_dist_d1_type), INTENT(IN)               :: gd_B_virtual
      80              :       INTEGER, INTENT(IN)                                :: kspin
      81              : 
      82              :       CHARACTER(LEN=*), PARAMETER                        :: routineN = 'complete_gamma'
      83              : 
      84              :       INTEGER                                            :: dimen_ia, handle, ispin, kkB, my_ia_end, &
      85              :                                                             my_ia_size, my_ia_start, my_P_end, &
      86              :                                                             my_P_size, my_P_start, nspins
      87          306 :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :)        :: BIb_C_2D, Gamma_2D, Gamma_PQ
      88              :       TYPE(cp_blacs_env_type), POINTER                   :: blacs_env
      89              :       TYPE(cp_fm_struct_type), POINTER                   :: fm_struct_ia, fm_struct_RI
      90              :       TYPE(cp_fm_type) :: fm_Gamma, fm_Gamma_PQ, fm_Gamma_PQ_2, fm_Gamma_PQ_temp, &
      91              :          fm_Gamma_PQ_temp_2, fm_ia_P, fm_Y, operator_half, PQ_half
      92          306 :       TYPE(group_dist_d1_type)                           :: gd_ia, gd_P
      93              : 
      94          306 :       CALL timeset(routineN, handle)
      95              : 
      96              :       ! reshape the data into a 2D array
      97              :       ! reorder the local data in such a way to help the next stage of matrix creation
      98              :       ! now the data inside the group are divided into a ia x K matrix
      99          306 :       dimen_ia = homo*virtual
     100          306 :       CALL create_group_dist(gd_ia, para_env_sub%num_pe, dimen_ia)
     101          306 :       CALL get_group_dist(gd_ia, para_env_sub%mepos, my_ia_start, my_ia_end, my_ia_size)
     102              : 
     103              :       CALL mat_3d_to_2d(B_ia_Q, BIb_C_2D, homo, my_B_size, virtual, my_B_virtual_start, &
     104          306 :                         my_ia_start, my_ia_end, my_ia_size, my_group_L_size, para_env_sub, gd_B_virtual)
     105              : 
     106              :       CALL mat_3d_to_2d_gamma(mp2_env%ri_grad%Gamma_P_ia(kspin)%array, Gamma_2D, homo, my_B_size, virtual, my_B_virtual_start, &
     107          306 :                               my_ia_start, my_ia_end, my_ia_size, my_group_L_size, para_env_sub, gd_B_virtual)
     108              : 
     109          306 :       CALL create_group_dist(gd_P, para_env_sub%num_pe, dimen_RI)
     110          306 :       CALL get_group_dist(gd_P, para_env_sub%mepos, my_P_start, my_P_end, my_P_size)
     111              : 
     112              :       ! create the blacs env
     113          306 :       NULLIFY (blacs_env)
     114          306 :       CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env)
     115              : 
     116          306 :       NULLIFY (fm_struct_ia)
     117              :       CALL cp_fm_struct_create(fm_struct_ia, context=blacs_env, nrow_global=dimen_ia, &
     118          306 :                                ncol_global=dimen_RI, para_env=para_env)
     119              : 
     120              :       ! create the fm matrix Gamma
     121              :       CALL cp_array_to_fm(Gamma_2D, fm_struct_ia, my_ia_start, my_ia_end, my_group_L_start, my_group_L_end, &
     122          306 :                           fm_Y)
     123              :       ! create the fm matrix B_ia_P
     124              :       CALL cp_array_to_fm(BIb_C_2D, fm_struct_ia, my_ia_start, my_ia_end, my_group_L_start, my_group_L_end, &
     125          306 :                           fm_ia_P)
     126              : 
     127          306 :       NULLIFY (fm_struct_RI)
     128              :       CALL cp_fm_struct_create(fm_struct_RI, context=blacs_env, nrow_global=dimen_RI, &
     129          306 :                                ncol_global=dimen_RI, para_env=para_env)
     130              : 
     131              :       ! since we will need (P|Q)^(-1/2) in the future, make a copy
     132              :       CALL cp_array_to_fm(mp2_env%ri_grad%PQ_half, fm_struct_RI, my_P_start, my_P_end, my_group_L_start, &
     133          306 :                           my_group_L_end, PQ_half, do_release_mat=.FALSE.)
     134              : 
     135          306 :       IF (.NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) THEN
     136              :          CALL cp_array_to_fm(mp2_env%ri_grad%operator_half, fm_struct_RI, my_P_start, my_P_end, &
     137            8 :                              my_group_L_start, my_group_L_end, operator_half, do_release_mat=.FALSE.)
     138              :       END IF
     139              : 
     140              :       ! complete the gamma matrix Gamma_ia^P = sum_Q (Y_ia^Q * (Q|P)^(-1/2))
     141          306 :       IF (compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) THEN
     142          298 :          CALL cp_fm_create(fm_Gamma, fm_struct_ia, name="fm_Gamma")
     143          298 :          CALL cp_fm_struct_release(fm_struct_ia)
     144              :          ! perform the matrix multiplication
     145              :          CALL parallel_gemm(transa="N", transb="T", m=dimen_ia, n=dimen_RI, k=dimen_RI, alpha=1.0_dp, &
     146              :                             matrix_a=fm_Y, matrix_b=PQ_half, beta=0.0_dp, &
     147          298 :                             matrix_c=fm_Gamma)
     148              :          ! release the Y matrix
     149          298 :          CALL cp_fm_release(fm_Y)
     150              : 
     151              :          ! complete gamma small (fm_Gamma_PQ)
     152              :          ! create temp matrix
     153          298 :          CALL cp_fm_create(fm_Gamma_PQ_temp, fm_struct_RI, name="fm_Gamma_PQ_temp")
     154              :          CALL parallel_gemm(transa="T", transb="N", m=dimen_RI, n=dimen_RI, k=dimen_ia, alpha=1.0_dp, &
     155              :                             matrix_a=fm_Gamma, matrix_b=fm_ia_P, beta=0.0_dp, &
     156          298 :                             matrix_c=fm_Gamma_PQ_temp)
     157          298 :          CALL cp_fm_release(fm_ia_P)
     158              :          ! create fm_Gamma_PQ matrix
     159          298 :          CALL cp_fm_create(fm_Gamma_PQ, fm_struct_RI, name="fm_Gamma_PQ")
     160          298 :          CALL cp_fm_struct_release(fm_struct_RI)
     161              :          ! perform matrix multiplication
     162              :          CALL parallel_gemm(transa="N", transb="T", m=dimen_RI, n=dimen_RI, k=dimen_RI, alpha=1.0_dp, &
     163              :                             matrix_a=fm_Gamma_PQ_temp, matrix_b=PQ_half, beta=0.0_dp, &
     164          298 :                             matrix_c=fm_Gamma_PQ)
     165          298 :          CALL cp_fm_release(fm_Gamma_PQ_temp)
     166          298 :          CALL cp_fm_release(PQ_half)
     167              : 
     168              :       ELSE
     169              :          ! create temp matrix
     170            8 :          CALL cp_fm_create(fm_Gamma_PQ_temp, fm_struct_RI, name="fm_Gamma_PQ_temp")
     171              :          CALL parallel_gemm(transa="T", transb="N", m=dimen_RI, n=dimen_RI, k=dimen_ia, alpha=1.0_dp, &
     172              :                             matrix_a=fm_Y, matrix_b=fm_ia_P, beta=0.0_dp, &
     173            8 :                             matrix_c=fm_Gamma_PQ_temp)
     174            8 :          CALL cp_fm_release(fm_ia_P)
     175              : 
     176            8 :          CALL cp_fm_create(fm_Gamma, fm_struct_ia, name="fm_Gamma")
     177            8 :          CALL cp_fm_struct_release(fm_struct_ia)
     178              :          ! perform the matrix multiplication
     179              :          CALL parallel_gemm(transa="N", transb="T", m=dimen_ia, n=dimen_RI, k=dimen_RI, alpha=1.0_dp, &
     180              :                             matrix_a=fm_Y, matrix_b=PQ_half, beta=0.0_dp, &
     181            8 :                             matrix_c=fm_Gamma)
     182            8 :          CALL cp_fm_release(fm_Y)
     183              : 
     184            8 :          CALL cp_fm_create(fm_Gamma_PQ_temp_2, fm_struct_RI, name="fm_Gamma_PQ_temp_2")
     185              :          CALL parallel_gemm(transa="N", transb="T", m=dimen_RI, n=dimen_RI, k=dimen_RI, alpha=1.0_dp, &
     186              :                             matrix_a=fm_Gamma_PQ_temp, matrix_b=operator_half, beta=0.0_dp, &
     187            8 :                             matrix_c=fm_Gamma_PQ_temp_2)
     188              : 
     189            8 :          CALL cp_fm_create(fm_Gamma_PQ_2, fm_struct_RI, name="fm_Gamma_PQ_2")
     190              :          CALL parallel_gemm(transa="N", transb="N", m=dimen_RI, n=dimen_RI, k=dimen_RI, alpha=1.0_dp, &
     191              :                             matrix_a=PQ_half, matrix_b=fm_Gamma_PQ_temp_2, beta=0.0_dp, &
     192            8 :                             matrix_c=fm_Gamma_PQ_temp)
     193            8 :          CALL cp_fm_to_fm(fm_Gamma_PQ_temp, fm_Gamma_PQ_2)
     194            8 :          CALL cp_fm_geadd(1.0_dp, "T", fm_Gamma_PQ_temp, 1.0_dp, fm_Gamma_PQ_2)
     195            8 :          CALL cp_fm_release(fm_Gamma_PQ_temp)
     196            8 :          CALL cp_fm_release(PQ_half)
     197              : 
     198            8 :          CALL cp_fm_create(fm_Gamma_PQ, fm_struct_RI)
     199            8 :          CALL cp_fm_struct_release(fm_struct_RI)
     200              :          CALL parallel_gemm(transa="N", transb="N", m=dimen_RI, n=dimen_RI, k=dimen_RI, alpha=-1.0_dp, &
     201              :                             matrix_a=operator_half, matrix_b=fm_Gamma_PQ_temp_2, beta=0.0_dp, &
     202            8 :                             matrix_c=fm_Gamma_PQ)
     203            8 :          CALL cp_fm_release(operator_half)
     204            8 :          CALL cp_fm_release(fm_Gamma_PQ_temp_2)
     205              :       END IF
     206              : 
     207              :       ! now redistribute the data, in this case we go back
     208              :       ! to the original way the integrals were distributed
     209          306 :       CALL cp_fm_to_array(Gamma_2D, my_ia_start, my_ia_end, my_group_L_start, my_group_L_end, fm_Gamma)
     210              : 
     211          306 :       CALL cp_fm_to_array(Gamma_PQ, my_P_start, my_P_end, my_group_L_start, my_group_L_end, fm_Gamma_PQ)
     212          306 :       IF (.NOT. ALLOCATED(mp2_env%ri_grad%Gamma_PQ)) THEN
     213          228 :          CALL MOVE_ALLOC(Gamma_PQ, mp2_env%ri_grad%Gamma_PQ)
     214              :       ELSE
     215       313178 :          mp2_env%ri_grad%Gamma_PQ(:, :) = mp2_env%ri_grad%Gamma_PQ + Gamma_PQ
     216           78 :          DEALLOCATE (Gamma_PQ)
     217              :       END IF
     218              : 
     219          306 :       IF (.NOT. compare_potential_types(mp2_env%ri_metric, mp2_env%potential_parameter)) THEN
     220            8 :          CALL cp_fm_to_array(Gamma_PQ, my_P_start, my_P_end, my_group_L_start, my_group_L_end, fm_Gamma_PQ_2)
     221            8 :          IF (.NOT. ALLOCATED(mp2_env%ri_grad%Gamma_PQ_2)) THEN
     222            8 :             CALL MOVE_ALLOC(Gamma_PQ, mp2_env%ri_grad%Gamma_PQ_2)
     223              :          ELSE
     224            0 :             mp2_env%ri_grad%Gamma_PQ_2(:, :) = mp2_env%ri_grad%Gamma_PQ_2 + Gamma_PQ
     225            0 :             DEALLOCATE (Gamma_PQ)
     226              :          END IF
     227              :       END IF
     228              : 
     229              :       ! allocate G_P_ia (DBCSR)
     230          306 :       IF (.NOT. ALLOCATED(mp2_env%ri_grad%G_P_ia)) THEN
     231          228 :          nspins = SIZE(mp2_env%ri_grad%mo_coeff_o)
     232        14456 :          ALLOCATE (mp2_env%ri_grad%G_P_ia(my_group_L_size, nspins))
     233          534 :          DO ispin = 1, nspins
     234        13772 :          DO kkB = 1, my_group_L_size
     235        13544 :             NULLIFY (mp2_env%ri_grad%G_P_ia(kkB, ispin)%matrix)
     236              :          END DO
     237              :          END DO
     238              :       END IF
     239              : 
     240              :       ! create the Gamma_ia_P in DBCSR style
     241              :       CALL cp_array_to_dbcsr_slices(Gamma_2D, homo, virtual, para_env_sub, my_ia_start, my_ia_end, &
     242              :                                     mp2_env%ri_grad%mo_coeff_o(1)%matrix, &
     243          306 :                                     matrix_ptrs=mp2_env%ri_grad%G_P_ia(:, kspin))
     244              : 
     245          306 :       CALL release_group_dist(gd_ia)
     246          306 :       CALL release_group_dist(gd_P)
     247              : 
     248              :       ! release blacs_env
     249          306 :       CALL cp_blacs_env_release(blacs_env)
     250              : 
     251          306 :       CALL timestop(handle)
     252              : 
     253          612 :    END SUBROUTINE complete_gamma
     254              : 
     255              : ! **************************************************************************************************
     256              : !> \brief Redistribute a 3d matrix to a 2d matrix
     257              : !> \param B_ia_Q ...
     258              : !> \param BIb_C_2D ...
     259              : !> \param homo ...
     260              : !> \param my_B_size ...
     261              : !> \param virtual ...
     262              : !> \param my_B_virtual_start ...
     263              : !> \param my_ia_start ...
     264              : !> \param my_ia_end ...
     265              : !> \param my_ia_size ...
     266              : !> \param my_group_L_size ...
     267              : !> \param para_env_sub ...
     268              : !> \param gd_B_virtual ...
     269              : ! **************************************************************************************************
     270          306 :    SUBROUTINE mat_3d_to_2d(B_ia_Q, BIb_C_2D, homo, my_B_size, virtual, my_B_virtual_start, &
     271              :                            my_ia_start, my_ia_end, my_ia_size, my_group_L_size, para_env_sub, gd_B_virtual)
     272              :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
     273              :          INTENT(INOUT)                                   :: B_ia_Q
     274              :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), &
     275              :          INTENT(OUT)                                     :: BIb_C_2D
     276              :       INTEGER, INTENT(IN)                                :: homo, my_B_size, virtual, &
     277              :                                                             my_B_virtual_start, my_ia_start, &
     278              :                                                             my_ia_end, my_ia_size, my_group_L_size
     279              :       TYPE(mp_para_env_type), INTENT(IN)                 :: para_env_sub
     280              :       TYPE(group_dist_d1_type), INTENT(IN)               :: gd_B_virtual
     281              : 
     282              :       CHARACTER(LEN=*), PARAMETER                        :: routineN = 'mat_3d_to_2d'
     283              : 
     284              :       INTEGER :: handle, ia_global, iiB, jjB, proc_receive, proc_send, proc_shift, rec_B_size, &
     285              :          rec_B_virtual_end, rec_B_virtual_start
     286          306 :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :)     :: BIb_C_rec
     287              : 
     288          306 :       CALL timeset(routineN, handle)
     289              : 
     290         1224 :       ALLOCATE (BIb_C_2D(my_ia_size, my_group_L_size))
     291          306 :       BIb_C_2D = 0.0_dp
     292              : 
     293         1408 :       DO iiB = 1, homo
     294        17332 :          DO jjB = 1, my_B_size
     295        15924 :             ia_global = (iiB - 1)*virtual + my_B_virtual_start + jjB - 1
     296        17026 :             IF (ia_global >= my_ia_start .AND. ia_global <= my_ia_end) THEN
     297       705851 :                BIb_C_2D(ia_global - my_ia_start + 1, :) = B_ia_Q(iiB, jjB, 1:my_group_L_size)
     298              :             END IF
     299              :          END DO
     300              :       END DO
     301              : 
     302          314 :       DO proc_shift = 1, para_env_sub%num_pe - 1
     303            8 :          proc_send = MODULO(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
     304            8 :          proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
     305              : 
     306            8 :          CALL get_group_dist(gd_B_virtual, proc_receive, rec_B_virtual_start, rec_B_virtual_end, rec_B_size)
     307              : 
     308           40 :          ALLOCATE (BIb_C_rec(homo, rec_B_size, my_group_L_size))
     309            8 :          BIb_C_rec = 0.0_dp
     310              : 
     311              :          CALL para_env_sub%sendrecv(B_ia_Q, proc_send, &
     312            8 :                                     BIb_C_rec, proc_receive)
     313              : 
     314           48 :          DO iiB = 1, homo
     315          438 :             DO jjB = 1, rec_B_size
     316          390 :                ia_global = (iiB - 1)*virtual + rec_B_virtual_start + jjB - 1
     317          430 :                IF (ia_global >= my_ia_start .AND. ia_global <= my_ia_end) THEN
     318        17373 :                   BIb_C_2D(ia_global - my_ia_start + 1, :) = BIb_C_rec(iiB, jjB, 1:my_group_L_size)
     319              :                END IF
     320              :             END DO
     321              :          END DO
     322              : 
     323          322 :          DEALLOCATE (BIb_C_rec)
     324              :       END DO
     325          306 :       DEALLOCATE (B_ia_Q)
     326              : 
     327          306 :       CALL timestop(handle)
     328          612 :    END SUBROUTINE mat_3d_to_2d
     329              : 
     330              : ! **************************************************************************************************
     331              : !> \brief Redistribute a 3d matrix to a 2d matrix, specialized for Gamma_P_ia to account for a different order of indices
     332              : !> \param B_ia_Q ...
     333              : !> \param BIb_C_2D ...
     334              : !> \param homo ...
     335              : !> \param my_B_size ...
     336              : !> \param virtual ...
     337              : !> \param my_B_virtual_start ...
     338              : !> \param my_ia_start ...
     339              : !> \param my_ia_end ...
     340              : !> \param my_ia_size ...
     341              : !> \param my_group_L_size ...
     342              : !> \param para_env_sub ...
     343              : !> \param gd_B_virtual ...
     344              : ! **************************************************************************************************
     345          306 :    SUBROUTINE mat_3d_to_2d_gamma(B_ia_Q, BIb_C_2D, homo, my_B_size, virtual, my_B_virtual_start, &
     346              :                                  my_ia_start, my_ia_end, my_ia_size, my_group_L_size, para_env_sub, gd_B_virtual)
     347              :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
     348              :          INTENT(INOUT)                                   :: B_ia_Q
     349              :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), &
     350              :          INTENT(OUT)                                     :: BIb_C_2D
     351              :       INTEGER, INTENT(IN)                                :: homo, my_B_size, virtual, &
     352              :                                                             my_B_virtual_start, my_ia_start, &
     353              :                                                             my_ia_end, my_ia_size, my_group_L_size
     354              :       TYPE(mp_para_env_type), INTENT(IN)                 :: para_env_sub
     355              :       TYPE(group_dist_d1_type), INTENT(IN)               :: gd_B_virtual
     356              : 
     357              :       CHARACTER(LEN=*), PARAMETER :: routineN = 'mat_3d_to_2d_gamma'
     358              : 
     359              :       INTEGER :: handle, ia_global, iiB, jjB, proc_receive, proc_send, proc_shift, rec_B_size, &
     360              :          rec_B_virtual_end, rec_B_virtual_start
     361          306 :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :)     :: BIb_C_rec
     362              : 
     363          306 :       CALL timeset(routineN, handle)
     364              : 
     365         1224 :       ALLOCATE (BIb_C_2D(my_ia_size, my_group_L_size))
     366          306 :       BIb_C_2D = 0.0_dp
     367              : 
     368         1408 :       DO iiB = 1, homo
     369        17332 :          DO jjB = 1, my_B_size
     370        15924 :             ia_global = (iiB - 1)*virtual + my_B_virtual_start + jjB - 1
     371        17026 :             IF (ia_global >= my_ia_start .AND. ia_global <= my_ia_end) THEN
     372       705851 :                BIb_C_2D(ia_global - my_ia_start + 1, :) = B_ia_Q(jjB, iiB, 1:my_group_L_size)
     373              :             END IF
     374              :          END DO
     375              :       END DO
     376              : 
     377          314 :       DO proc_shift = 1, para_env_sub%num_pe - 1
     378            8 :          proc_send = MODULO(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
     379            8 :          proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
     380              : 
     381            8 :          CALL get_group_dist(gd_B_virtual, proc_receive, rec_B_virtual_start, rec_B_virtual_end, rec_B_size)
     382              : 
     383           40 :          ALLOCATE (BIb_C_rec(rec_B_size, homo, my_group_L_size))
     384            8 :          BIb_C_rec = 0.0_dp
     385              : 
     386              :          CALL para_env_sub%sendrecv(B_ia_Q, proc_send, &
     387            8 :                                     BIb_C_rec, proc_receive)
     388              : 
     389           48 :          DO iiB = 1, homo
     390          438 :             DO jjB = 1, rec_B_size
     391          390 :                ia_global = (iiB - 1)*virtual + rec_B_virtual_start + jjB - 1
     392          430 :                IF (ia_global >= my_ia_start .AND. ia_global <= my_ia_end) THEN
     393        17373 :                   BIb_C_2D(ia_global - my_ia_start + 1, :) = BIb_C_rec(jjB, iiB, 1:my_group_L_size)
     394              :                END IF
     395              :             END DO
     396              :          END DO
     397              : 
     398          322 :          DEALLOCATE (BIb_C_rec)
     399              :       END DO
     400          306 :       DEALLOCATE (B_ia_Q)
     401              : 
     402          306 :       CALL timestop(handle)
     403          612 :    END SUBROUTINE mat_3d_to_2d_gamma
     404              : 
     405              : END MODULE mp2_ri_grad_util
        

Generated by: LCOV version 2.0-1