LCOV - code coverage report
Current view: top level - src - qs_active_space_utils.F (source / functions) Coverage Total Hit
Test: CP2K Regtests (git:42dac4a) Lines: 0.0 % 63 0
Test Date: 2025-07-25 12:55:17 Functions: 0.0 % 2 0

            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 Contains utility routines for the active space module
      10              : !> \par History
      11              : !>      04.2023 created [SB]
      12              : !> \author SB
      13              : ! **************************************************************************************************
      14              : MODULE qs_active_space_utils
      15              : 
      16              :    USE cp_dbcsr_api,                    ONLY: dbcsr_csr_type
      17              :    USE cp_fm_types,                     ONLY: cp_fm_get_element,&
      18              :                                               cp_fm_get_info,&
      19              :                                               cp_fm_type
      20              :    USE kinds,                           ONLY: dp
      21              :    USE message_passing,                 ONLY: mp_comm_type
      22              :    USE qs_active_space_types,           ONLY: csr_idx_from_combined,&
      23              :                                               csr_idx_to_combined,&
      24              :                                               eri_type,&
      25              :                                               get_irange_csr
      26              : #include "./base/base_uses.f90"
      27              : 
      28              :    IMPLICIT NONE
      29              : 
      30              :    PRIVATE
      31              : 
      32              :    CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_active_space_utils'
      33              : 
      34              :    PUBLIC :: subspace_matrix_to_array, eri_to_array
      35              : 
      36              : CONTAINS
      37              : 
      38              : ! **************************************************************************************************
      39              : !> \brief Copy a (square portion) of a `cp_fm_type` matrix to a standard 1D Fortran array
      40              : !> \param source_matrix the matrix from where the data is taken
      41              : !> \param target_array the array were the data is copied to
      42              : !> \param row_index a list containing the row subspace indices
      43              : !> \param col_index a list containing the column subspace indices
      44              : ! **************************************************************************************************
      45            0 :    SUBROUTINE subspace_matrix_to_array(source_matrix, target_array, row_index, col_index)
      46              :       TYPE(cp_fm_type), INTENT(IN)                       :: source_matrix
      47              :       REAL(KIND=dp), DIMENSION(:), INTENT(OUT)           :: target_array
      48              :       INTEGER, DIMENSION(:), INTENT(IN)                  :: row_index, col_index
      49              : 
      50              :       INTEGER                                            :: i, i_sub, j, j_sub, max_col, max_row, &
      51              :                                                             ncols, nrows
      52              :       REAL(KIND=dp)                                      :: mval
      53              : 
      54            0 :       CALL cp_fm_get_info(source_matrix, nrow_global=max_row, ncol_global=max_col)
      55            0 :       nrows = SIZE(row_index)
      56            0 :       ncols = SIZE(col_index)
      57              : 
      58            0 :       CPASSERT(MAXVAL(row_index) <= max_row)
      59            0 :       CPASSERT(MAXVAL(col_index) <= max_col)
      60            0 :       CPASSERT(MINVAL(row_index) > 0)
      61            0 :       CPASSERT(MINVAL(col_index) > 0)
      62            0 :       CPASSERT(nrows <= max_row)
      63            0 :       CPASSERT(ncols <= max_col)
      64              : 
      65            0 :       CPASSERT(SIZE(target_array) == nrows*ncols)
      66              : 
      67            0 :       DO j = 1, ncols
      68            0 :          j_sub = col_index(j)
      69            0 :          DO i = 1, nrows
      70            0 :             i_sub = row_index(i)
      71            0 :             CALL cp_fm_get_element(source_matrix, i_sub, j_sub, mval)
      72            0 :             target_array(i + (j - 1)*nrows) = mval
      73              :          END DO
      74              :       END DO
      75            0 :    END SUBROUTINE subspace_matrix_to_array
      76              : 
      77              : ! **************************************************************************************************
      78              : !> \brief Copy the eri tensor for spins isp1 and isp2 to a standard 1D Fortran array
      79              : !> \param eri_env the eri environment
      80              : !> \param array the 1D Fortran array where the eri are copied to
      81              : !> \param active_orbitals a list containing the active orbitals indices
      82              : !> \param spin1 the spin of the bra
      83              : !> \param spin2 the spin of the ket
      84              : ! **************************************************************************************************
      85            0 :    SUBROUTINE eri_to_array(eri_env, array, active_orbitals, spin1, spin2)
      86              :       TYPE(eri_type), INTENT(IN)                         :: eri_env
      87              :       REAL(KIND=dp), DIMENSION(:), INTENT(INOUT)         :: array
      88              :       INTEGER, DIMENSION(:, :), INTENT(IN)               :: active_orbitals
      89              :       INTEGER, INTENT(IN)                                :: spin1, spin2
      90              : 
      91              :       INTEGER                                            :: i, i1, i12, i12l, i2, i3, i34, i34l, i4, &
      92              :                                                             ijkl, ijlk, irptr, j, jikl, jilk, k, &
      93              :                                                             klij, klji, l, lkij, lkji, nindex, &
      94              :                                                             nmo_active, nmo_max
      95              :       INTEGER, DIMENSION(2)                              :: irange
      96              :       REAL(KIND=dp)                                      :: erival
      97              :       TYPE(dbcsr_csr_type), POINTER                      :: eri
      98              :       TYPE(mp_comm_type)                                 :: mp_group
      99              : 
     100            0 :       nmo_active = SIZE(active_orbitals, 1)
     101            0 :       nmo_max = eri_env%norb
     102            0 :       nindex = (nmo_max*(nmo_max + 1))/2
     103            0 :       IF (spin1 == 1 .AND. spin2 == 1) THEN
     104            0 :          eri => eri_env%eri(1)%csr_mat
     105            0 :       ELSE IF ((spin1 == 1 .AND. spin2 == 2) .OR. (spin1 == 2 .AND. spin2 == 1)) THEN
     106            0 :          eri => eri_env%eri(2)%csr_mat
     107              :       ELSE
     108            0 :          eri => eri_env%eri(3)%csr_mat
     109              :       END IF
     110              : 
     111            0 :       CALL mp_group%set_handle(eri%mp_group%get_handle())
     112            0 :       irange = get_irange_csr(nindex, mp_group)
     113              : 
     114            0 :       array = 0.0_dp
     115              : 
     116            0 :       DO i = 1, nmo_active
     117            0 :          i1 = active_orbitals(i, spin1)
     118            0 :          DO j = i, nmo_active
     119            0 :             i2 = active_orbitals(j, spin1)
     120            0 :             i12 = csr_idx_to_combined(i1, i2, nmo_max)
     121            0 :             IF (i12 >= irange(1) .AND. i12 <= irange(2)) THEN
     122            0 :                i12l = i12 - irange(1) + 1
     123            0 :                irptr = eri%rowptr_local(i12l) - 1
     124            0 :                DO i34l = 1, eri%nzerow_local(i12l)
     125            0 :                   i34 = eri%colind_local(irptr + i34l)
     126            0 :                   CALL csr_idx_from_combined(i34, nmo_max, i3, i4)
     127              : ! The FINDLOC intrinsic function of the Fortran 2008 standard is only available since GCC 9
     128              : ! That is why we use a custom-made implementation of this function for this compiler
     129              : #if __GNUC__ < 9
     130              :                   k = cp_findloc(active_orbitals(:, spin2), i3)
     131              :                   l = cp_findloc(active_orbitals(:, spin2), i4)
     132              : #else
     133            0 :                   k = FINDLOC(active_orbitals(:, spin2), i3, dim=1)
     134            0 :                   l = FINDLOC(active_orbitals(:, spin2), i4, dim=1)
     135              : #endif
     136            0 :                   erival = eri%nzval_local%r_dp(irptr + i34l)
     137              : 
     138              :                   ! 8-fold permutational symmetry
     139            0 :                   ijkl = i + (j - 1)*nmo_active + (k - 1)*nmo_active**2 + (l - 1)*nmo_active**3
     140            0 :                   jikl = j + (i - 1)*nmo_active + (k - 1)*nmo_active**2 + (l - 1)*nmo_active**3
     141            0 :                   ijlk = i + (j - 1)*nmo_active + (l - 1)*nmo_active**2 + (k - 1)*nmo_active**3
     142            0 :                   jilk = j + (i - 1)*nmo_active + (l - 1)*nmo_active**2 + (k - 1)*nmo_active**3
     143            0 :                   array(ijkl) = erival
     144            0 :                   array(jikl) = erival
     145            0 :                   array(ijlk) = erival
     146            0 :                   array(jilk) = erival
     147            0 :                   IF (spin1 == spin2) THEN
     148            0 :                      klij = k + (l - 1)*nmo_active + (i - 1)*nmo_active**2 + (j - 1)*nmo_active**3
     149            0 :                      lkij = l + (k - 1)*nmo_active + (i - 1)*nmo_active**2 + (j - 1)*nmo_active**3
     150            0 :                      klji = k + (l - 1)*nmo_active + (j - 1)*nmo_active**2 + (i - 1)*nmo_active**3
     151            0 :                      lkji = l + (k - 1)*nmo_active + (j - 1)*nmo_active**2 + (i - 1)*nmo_active**3
     152            0 :                      array(klij) = erival
     153            0 :                      array(lkij) = erival
     154            0 :                      array(klji) = erival
     155            0 :                      array(lkji) = erival
     156              :                   END IF
     157              :                END DO
     158              :             END IF
     159              :          END DO
     160              :       END DO
     161            0 :       CALL mp_group%sum(array)
     162              : 
     163            0 :    END SUBROUTINE eri_to_array
     164              : 
     165              : #if __GNUC__ < 9
     166              : ! **************************************************************************************************
     167              : !> \brief This function implements the FINDLOC function of the Fortran 2008 standard for the case needed above
     168              : !>        To be removed as soon GCC 8 is dropped.
     169              : !> \param array ...
     170              : !> \param value ...
     171              : !> \return ...
     172              : ! **************************************************************************************************
     173              :    PURE INTEGER FUNCTION cp_findloc(array, value) RESULT(loc)
     174              :       INTEGER, DIMENSION(:), INTENT(IN)                  :: array
     175              :       INTEGER, INTENT(IN)                                :: value
     176              : 
     177              :       INTEGER                                            :: idx
     178              : 
     179              :       loc = 0
     180              : 
     181              :       DO idx = 1, SIZE(array)
     182              :       IF (array(idx) == value) THEN
     183              :          loc = idx
     184              :          RETURN
     185              :       END IF
     186              :       END DO
     187              : 
     188              :    END FUNCTION cp_findloc
     189              : #endif
     190              : 
     191              : END MODULE qs_active_space_utils
        

Generated by: LCOV version 2.0-1