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