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 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
|
