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