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 : !> \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 : ! **************************************************************************************************
51 : TYPE basis_set_container_type
52 : PRIVATE
53 : CHARACTER(LEN=default_string_length) :: basis_type = ""
54 : INTEGER :: basis_type_nr = 0
55 : TYPE(gto_basis_set_type), POINTER :: basis_set => NULL()
56 : END TYPE basis_set_container_type
57 : ! **************************************************************************************************
58 :
59 : PUBLIC :: basis_set_container_type
60 :
61 : PUBLIC :: remove_basis_set_container, &
62 : add_basis_set_to_container, get_basis_from_container, &
63 : remove_basis_from_container
64 :
65 : ! **************************************************************************************************
66 :
67 : CONTAINS
68 :
69 : ! **************************************************************************************************
70 : !> \brief ...
71 : !> \param basis ...
72 : ! **************************************************************************************************
73 12985 : SUBROUTINE remove_basis_set_container(basis)
74 : TYPE(basis_set_container_type), DIMENSION(:), &
75 : INTENT(inout) :: basis
76 :
77 : INTEGER :: i
78 :
79 272685 : DO i = 1, SIZE(basis)
80 259700 : basis(i)%basis_type = ""
81 259700 : basis(i)%basis_type_nr = 0
82 272685 : IF (ASSOCIATED(basis(i)%basis_set)) THEN
83 19102 : CALL deallocate_gto_basis_set(basis(i)%basis_set)
84 : END IF
85 : END DO
86 :
87 12985 : END SUBROUTINE remove_basis_set_container
88 :
89 : ! **************************************************************************************************
90 : !> \brief ...
91 : !> \param basis_set_type ...
92 : !> \return ...
93 : ! **************************************************************************************************
94 15998118 : FUNCTION get_basis_type(basis_set_type) RESULT(basis_type_nr)
95 : CHARACTER(len=*) :: basis_set_type
96 : INTEGER :: basis_type_nr
97 :
98 : SELECT CASE (basis_set_type)
99 : CASE ("ORB")
100 116514 : basis_type_nr = orbital_basis
101 : CASE ("AUX")
102 116514 : basis_type_nr = auxiliary_basis
103 : CASE ("MIN")
104 17070 : basis_type_nr = min_basis
105 : CASE ("RI_AUX")
106 4058908 : basis_type_nr = ri_aux_basis
107 : CASE ("RI_HXC")
108 75061 : basis_type_nr = ri_hxc_basis
109 : CASE ("RI_HFX")
110 12393 : basis_type_nr = ri_hfx_basis
111 : CASE ("RI_K")
112 51922 : basis_type_nr = ri_k_basis
113 : CASE ("LRI_AUX")
114 79807 : basis_type_nr = lri_aux_basis
115 : CASE ("P_LRI_AUX")
116 18040 : basis_type_nr = p_lri_aux_basis
117 : CASE ("AUX_FIT")
118 178965 : basis_type_nr = aux_fit_basis
119 : CASE ("AUX_FIT_SOFT")
120 6302 : basis_type_nr = aux_fit_soft_basis
121 : CASE ("ORB_SOFT")
122 43200 : basis_type_nr = soft_basis
123 : CASE ("GAPW_1C")
124 2162249 : basis_type_nr = gapw_1c_basis
125 : CASE ("TDA_HFX")
126 16836 : basis_type_nr = tda_k_basis
127 : CASE ("MAO")
128 120760 : basis_type_nr = mao_basis
129 : CASE ("HARRIS")
130 138708 : basis_type_nr = harris_basis
131 : CASE ("AUX_GW")
132 24508 : basis_type_nr = aux_gw_basis
133 : CASE ("RI_XAS")
134 17878 : basis_type_nr = ri_xas_basis
135 : CASE ("AUX_OPT")
136 20380 : basis_type_nr = aux_opt_basis
137 : CASE ("RHOIN")
138 69030 : basis_type_nr = rhoin_basis
139 : CASE DEFAULT
140 15998118 : basis_type_nr = unknown_basis
141 : END SELECT
142 :
143 15998118 : END FUNCTION get_basis_type
144 :
145 : ! **************************************************************************************************
146 : !> \brief ...
147 : !> \param container ...
148 : !> \param basis_set ...
149 : !> \param basis_set_type ...
150 : ! **************************************************************************************************
151 38220 : SUBROUTINE add_basis_set_to_container(container, basis_set, basis_set_type)
152 : TYPE(basis_set_container_type), DIMENSION(:), &
153 : INTENT(inout) :: container
154 : TYPE(gto_basis_set_type), POINTER :: basis_set
155 : CHARACTER(len=*) :: basis_set_type
156 :
157 : INTEGER :: i
158 : LOGICAL :: success
159 :
160 19110 : success = .FALSE.
161 29131 : DO i = 1, SIZE(container)
162 29131 : IF (container(i)%basis_type_nr == 0) THEN
163 19110 : container(i)%basis_type = basis_set_type
164 19110 : container(i)%basis_set => basis_set
165 19110 : container(i)%basis_type_nr = get_basis_type(basis_set_type)
166 : success = .TRUE.
167 : EXIT
168 : END IF
169 : END DO
170 0 : CPASSERT(success)
171 :
172 19110 : END SUBROUTINE add_basis_set_to_container
173 :
174 : ! **************************************************************************************************
175 : !> \brief ...
176 : !> \param container ...
177 : !> \param inum ...
178 : !> \param basis_type ...
179 : ! **************************************************************************************************
180 1936 : SUBROUTINE remove_basis_from_container(container, inum, basis_type)
181 : TYPE(basis_set_container_type), DIMENSION(:), &
182 : INTENT(inout) :: container
183 : INTEGER, INTENT(IN), OPTIONAL :: inum
184 : CHARACTER(len=*), OPTIONAL :: basis_type
185 :
186 : INTEGER :: basis_nr, i, ibas
187 :
188 1936 : IF (PRESENT(inum)) THEN
189 0 : CPASSERT(inum <= SIZE(container))
190 0 : CPASSERT(inum >= 1)
191 : ibas = inum
192 1936 : ELSE IF (PRESENT(basis_type)) THEN
193 1936 : basis_nr = get_basis_type(basis_type)
194 1936 : ibas = 0
195 40504 : DO i = 1, SIZE(container)
196 40504 : IF (container(i)%basis_type_nr == basis_nr) THEN
197 : ibas = i
198 : EXIT
199 : END IF
200 : END DO
201 : ELSE
202 0 : CPABORT("")
203 : END IF
204 : !
205 1936 : IF (ibas /= 0) THEN
206 8 : container(ibas)%basis_type = ""
207 8 : container(ibas)%basis_type_nr = 0
208 8 : IF (ASSOCIATED(container(ibas)%basis_set)) THEN
209 8 : CALL deallocate_gto_basis_set(container(ibas)%basis_set)
210 : END IF
211 : ! shift other basis sets
212 152 : DO i = ibas + 1, SIZE(container)
213 144 : IF (container(i)%basis_type_nr == 0) CYCLE
214 0 : container(i - 1)%basis_type = container(i)%basis_type
215 0 : container(i - 1)%basis_set => container(i)%basis_set
216 0 : container(i - 1)%basis_type_nr = container(i)%basis_type_nr
217 0 : container(i)%basis_type = ""
218 0 : container(i)%basis_type_nr = 0
219 152 : NULLIFY (container(i)%basis_set)
220 : END DO
221 : END IF
222 :
223 1936 : END SUBROUTINE remove_basis_from_container
224 :
225 : ! **************************************************************************************************
226 : !> \brief Retrieve a basis set from the container
227 : !> \param container ...
228 : !> \param basis_set ...
229 : !> \param inumbas ...
230 : !> \param basis_type ...
231 : ! **************************************************************************************************
232 33792558 : SUBROUTINE get_basis_from_container(container, basis_set, inumbas, basis_type)
233 : TYPE(basis_set_container_type), DIMENSION(:), &
234 : INTENT(inout) :: container
235 : TYPE(gto_basis_set_type), POINTER :: basis_set
236 : INTEGER, OPTIONAL :: inumbas
237 : CHARACTER(len=*), OPTIONAL :: basis_type
238 :
239 : INTEGER :: basis_nr, i
240 :
241 16896279 : IF (PRESENT(inumbas)) THEN
242 919207 : CPASSERT(inumbas <= SIZE(container))
243 919207 : CPASSERT(inumbas >= 1)
244 919207 : basis_set => container(inumbas)%basis_set
245 919207 : IF (PRESENT(basis_type)) THEN
246 919207 : basis_type = container(inumbas)%basis_type
247 : END IF
248 15977072 : ELSE IF (PRESENT(basis_type)) THEN
249 15977072 : NULLIFY (basis_set)
250 15977072 : basis_nr = get_basis_type(basis_type)
251 46400520 : DO i = 1, SIZE(container)
252 46400520 : IF (container(i)%basis_type_nr == basis_nr) THEN
253 14901026 : basis_set => container(i)%basis_set
254 14901026 : EXIT
255 : END IF
256 : END DO
257 : ELSE
258 0 : CPABORT("")
259 : END IF
260 :
261 16896279 : END SUBROUTINE get_basis_from_container
262 : ! **************************************************************************************************
263 :
264 0 : END MODULE basis_set_container_types
|
