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 : !> \par History
10 : !> - Container to hold basis sets
11 : !> \author JGH (09.07.2015)
12 : ! **************************************************************************************************
13 : MODULE basis_set_container_types
14 :
15 : USE basis_set_types, ONLY: deallocate_gto_basis_set,&
16 : gto_basis_set_type
17 : USE kinds, ONLY: default_string_length
18 : #include "../base/base_uses.f90"
19 :
20 : IMPLICIT NONE
21 :
22 : PRIVATE
23 :
24 : ! Global parameters (only in this module)
25 :
26 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'basis_set_container_types'
27 :
28 : ! **************************************************************************************************
29 : INTEGER, PARAMETER :: unknown_basis = 100, &
30 : orbital_basis = 101, &
31 : auxiliary_basis = 102, &
32 : ri_aux_basis = 103, &
33 : lri_aux_basis = 104, &
34 : aux_fit_basis = 105, &
35 : soft_basis = 106, &
36 : gapw_1c_basis = 107, &
37 : mao_basis = 108, &
38 : harris_basis = 109, &
39 : aux_gw_basis = 110, &
40 : ri_hxc_basis = 111, &
41 : ri_k_basis = 112, &
42 : ri_xas_basis = 113, &
43 : aux_fit_soft_basis = 114, &
44 : ri_hfx_basis = 115, &
45 : p_lri_aux_basis = 116, &
46 : aux_opt_basis = 117, &
47 : min_basis = 118, &
48 : tda_k_basis = 119, &
49 : rhoin_basis = 120, &
50 : nuclear_basis = 121, &
51 : nuclear_soft_basis = 122, &
52 : harris_soft_basis = 123
53 : ! **************************************************************************************************
54 : TYPE basis_set_container_type
55 : PRIVATE
56 : CHARACTER(LEN=default_string_length) :: basis_type = ""
57 : INTEGER :: basis_type_nr = 0
58 : TYPE(gto_basis_set_type), POINTER :: basis_set => NULL()
59 : END TYPE basis_set_container_type
60 : ! **************************************************************************************************
61 :
62 : PUBLIC :: basis_set_container_type
63 :
64 : PUBLIC :: remove_basis_set_container, &
65 : add_basis_set_to_container, get_basis_from_container, &
66 : remove_basis_from_container
67 :
68 : ! **************************************************************************************************
69 :
70 : CONTAINS
71 :
72 : ! **************************************************************************************************
73 : !> \brief ...
74 : !> \param basis ...
75 : ! **************************************************************************************************
76 14609 : SUBROUTINE remove_basis_set_container(basis)
77 : TYPE(basis_set_container_type), DIMENSION(:), &
78 : INTENT(inout) :: basis
79 :
80 : INTEGER :: i
81 :
82 306789 : DO i = 1, SIZE(basis)
83 292180 : basis(i)%basis_type = ""
84 292180 : basis(i)%basis_type_nr = 0
85 306789 : IF (ASSOCIATED(basis(i)%basis_set)) THEN
86 21212 : CALL deallocate_gto_basis_set(basis(i)%basis_set)
87 : END IF
88 : END DO
89 :
90 14609 : END SUBROUTINE remove_basis_set_container
91 :
92 : ! **************************************************************************************************
93 : !> \brief ...
94 : !> \param basis_set_type ...
95 : !> \return ...
96 : ! **************************************************************************************************
97 18876935 : FUNCTION get_basis_type(basis_set_type) RESULT(basis_type_nr)
98 : CHARACTER(len=*) :: basis_set_type
99 : INTEGER :: basis_type_nr
100 :
101 : SELECT CASE (basis_set_type)
102 : CASE ("ORB")
103 124352 : basis_type_nr = orbital_basis
104 : CASE ("AUX")
105 124352 : basis_type_nr = auxiliary_basis
106 : CASE ("MIN")
107 18740 : basis_type_nr = min_basis
108 : CASE ("RI_AUX")
109 5627052 : basis_type_nr = ri_aux_basis
110 : CASE ("RI_HXC")
111 80316 : basis_type_nr = ri_hxc_basis
112 : CASE ("RI_HFX")
113 14423 : basis_type_nr = ri_hfx_basis
114 : CASE ("RI_K")
115 54712 : basis_type_nr = ri_k_basis
116 : CASE ("LRI_AUX")
117 85012 : basis_type_nr = lri_aux_basis
118 : CASE ("P_LRI_AUX")
119 19518 : basis_type_nr = p_lri_aux_basis
120 : CASE ("AUX_FIT")
121 189928 : basis_type_nr = aux_fit_basis
122 : CASE ("AUX_FIT_SOFT")
123 7176 : basis_type_nr = aux_fit_soft_basis
124 : CASE ("ORB_SOFT")
125 45656 : basis_type_nr = soft_basis
126 : CASE ("GAPW_1C")
127 2344591 : basis_type_nr = gapw_1c_basis
128 : CASE ("TDA_HFX")
129 18506 : basis_type_nr = tda_k_basis
130 : CASE ("MAO")
131 128010 : basis_type_nr = mao_basis
132 : CASE ("HARRIS")
133 147414 : basis_type_nr = harris_basis
134 : CASE ("HARRIS_SOFT")
135 400 : basis_type_nr = harris_soft_basis
136 : CASE ("AUX_GW")
137 26182 : basis_type_nr = aux_gw_basis
138 : CASE ("RI_XAS")
139 19910 : basis_type_nr = ri_xas_basis
140 : CASE ("AUX_OPT")
141 22050 : basis_type_nr = aux_opt_basis
142 : CASE ("RHOIN")
143 73490 : basis_type_nr = rhoin_basis
144 : CASE ("NUC")
145 179270 : basis_type_nr = nuclear_basis
146 : CASE ("NUC_SOFT")
147 212 : basis_type_nr = nuclear_soft_basis
148 : CASE DEFAULT
149 18876935 : basis_type_nr = unknown_basis
150 : END SELECT
151 :
152 18876935 : END FUNCTION get_basis_type
153 :
154 : ! **************************************************************************************************
155 : !> \brief ...
156 : !> \param container ...
157 : !> \param basis_set ...
158 : !> \param basis_set_type ...
159 : ! **************************************************************************************************
160 42440 : SUBROUTINE add_basis_set_to_container(container, basis_set, basis_set_type)
161 : TYPE(basis_set_container_type), DIMENSION(:), &
162 : INTENT(inout) :: container
163 : TYPE(gto_basis_set_type), POINTER :: basis_set
164 : CHARACTER(len=*) :: basis_set_type
165 :
166 : INTEGER :: i
167 : LOGICAL :: success
168 :
169 21220 : success = .FALSE.
170 32365 : DO i = 1, SIZE(container)
171 32365 : IF (container(i)%basis_type_nr == 0) THEN
172 21220 : container(i)%basis_type = basis_set_type
173 21220 : container(i)%basis_set => basis_set
174 21220 : container(i)%basis_type_nr = get_basis_type(basis_set_type)
175 : success = .TRUE.
176 : EXIT
177 : END IF
178 : END DO
179 0 : CPASSERT(success)
180 :
181 21220 : END SUBROUTINE add_basis_set_to_container
182 :
183 : ! **************************************************************************************************
184 : !> \brief ...
185 : !> \param container ...
186 : !> \param inum ...
187 : !> \param basis_type ...
188 : ! **************************************************************************************************
189 2084 : SUBROUTINE remove_basis_from_container(container, inum, basis_type)
190 : TYPE(basis_set_container_type), DIMENSION(:), &
191 : INTENT(inout) :: container
192 : INTEGER, INTENT(IN), OPTIONAL :: inum
193 : CHARACTER(len=*), OPTIONAL :: basis_type
194 :
195 : INTEGER :: basis_nr, i, ibas
196 :
197 2084 : IF (PRESENT(inum)) THEN
198 0 : CPASSERT(inum <= SIZE(container))
199 0 : CPASSERT(inum >= 1)
200 : ibas = inum
201 2084 : ELSE IF (PRESENT(basis_type)) THEN
202 2084 : basis_nr = get_basis_type(basis_type)
203 2084 : ibas = 0
204 43612 : DO i = 1, SIZE(container)
205 43612 : IF (container(i)%basis_type_nr == basis_nr) THEN
206 : ibas = i
207 : EXIT
208 : END IF
209 : END DO
210 : ELSE
211 0 : CPABORT("")
212 : END IF
213 : !
214 2084 : IF (ibas /= 0) THEN
215 8 : container(ibas)%basis_type = ""
216 8 : container(ibas)%basis_type_nr = 0
217 8 : IF (ASSOCIATED(container(ibas)%basis_set)) THEN
218 8 : CALL deallocate_gto_basis_set(container(ibas)%basis_set)
219 : END IF
220 : ! shift other basis sets
221 152 : DO i = ibas + 1, SIZE(container)
222 144 : IF (container(i)%basis_type_nr == 0) CYCLE
223 0 : container(i - 1)%basis_type = container(i)%basis_type
224 0 : container(i - 1)%basis_set => container(i)%basis_set
225 0 : container(i - 1)%basis_type_nr = container(i)%basis_type_nr
226 0 : container(i)%basis_type = ""
227 0 : container(i)%basis_type_nr = 0
228 152 : NULLIFY (container(i)%basis_set)
229 : END DO
230 : END IF
231 :
232 2084 : END SUBROUTINE remove_basis_from_container
233 :
234 : ! **************************************************************************************************
235 : !> \brief Retrieve a basis set from the container
236 : !> \param container ...
237 : !> \param basis_set ...
238 : !> \param inumbas ...
239 : !> \param basis_type ...
240 : ! **************************************************************************************************
241 40018464 : SUBROUTINE get_basis_from_container(container, basis_set, inumbas, basis_type)
242 : TYPE(basis_set_container_type), DIMENSION(:), &
243 : INTENT(inout) :: container
244 : TYPE(gto_basis_set_type), POINTER :: basis_set
245 : INTEGER, OPTIONAL :: inumbas
246 : CHARACTER(len=*), OPTIONAL :: basis_type
247 :
248 : INTEGER :: basis_nr, i
249 :
250 20009232 : IF (PRESENT(inumbas)) THEN
251 1155601 : CPASSERT(inumbas <= SIZE(container))
252 1155601 : CPASSERT(inumbas >= 1)
253 1155601 : basis_set => container(inumbas)%basis_set
254 1155601 : IF (PRESENT(basis_type)) THEN
255 1155601 : basis_type = container(inumbas)%basis_type
256 : END IF
257 18853631 : ELSE IF (PRESENT(basis_type)) THEN
258 18853631 : NULLIFY (basis_set)
259 18853631 : basis_nr = get_basis_type(basis_type)
260 56241043 : DO i = 1, SIZE(container)
261 56241043 : IF (container(i)%basis_type_nr == basis_nr) THEN
262 17529341 : basis_set => container(i)%basis_set
263 17529341 : EXIT
264 : END IF
265 : END DO
266 : ELSE
267 0 : CPABORT("")
268 : END IF
269 :
270 20009232 : END SUBROUTINE get_basis_from_container
271 : ! **************************************************************************************************
272 :
273 0 : END MODULE basis_set_container_types
|
