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 : !> \par History
10 : !> - 02.2004 flexible normalization of basis sets [jgh]
11 : !> - 07.2014 Add a set of contraction coefficient that only work on active
12 : !> functions
13 : !> \author Matthias Krack (04.07.2000)
14 : ! **************************************************************************************************
15 : MODULE basis_set_types
16 :
17 : USE ai_coulomb, ONLY: coulomb2
18 : USE bibliography, ONLY: VandeVondele2007,&
19 : cite_reference
20 : USE cp_linked_list_input, ONLY: cp_sll_val_next,&
21 : cp_sll_val_type
22 : USE cp_parser_methods, ONLY: parser_get_object,&
23 : parser_search_string
24 : USE cp_parser_types, ONLY: cp_parser_type,&
25 : parser_create,&
26 : parser_release
27 : USE input_section_types, ONLY: section_vals_list_get,&
28 : section_vals_type,&
29 : section_vals_val_get
30 : USE input_val_types, ONLY: val_get,&
31 : val_type
32 : USE kinds, ONLY: default_path_length,&
33 : default_string_length,&
34 : dp
35 : USE mathconstants, ONLY: dfac,&
36 : pi
37 : USE memory_utilities, ONLY: reallocate
38 : USE message_passing, ONLY: mp_para_env_type
39 : USE orbital_pointers, ONLY: coset,&
40 : indco,&
41 : init_orbital_pointers,&
42 : nco,&
43 : ncoset,&
44 : nso,&
45 : nsoset
46 : USE orbital_symbols, ONLY: cgf_symbol,&
47 : sgf_symbol
48 : USE orbital_transformation_matrices, ONLY: init_spherical_harmonics,&
49 : orbtramat
50 : USE sto_ng, ONLY: get_sto_ng
51 : USE string_utilities, ONLY: integer_to_string,&
52 : remove_word,&
53 : uppercase
54 : USE util, ONLY: sort
55 : #include "../base/base_uses.f90"
56 :
57 : IMPLICIT NONE
58 :
59 : PRIVATE
60 :
61 : ! Global parameters (only in this module)
62 :
63 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'basis_set_types'
64 :
65 : ! basis set sort criteria
66 : INTEGER, PARAMETER, PUBLIC :: basis_sort_default = 0, &
67 : basis_sort_zet = 1
68 :
69 : ! **************************************************************************************************
70 : ! Define the Gaussian-type orbital basis set type
71 :
72 : TYPE gto_basis_set_type
73 : !MK PRIVATE
74 : CHARACTER(LEN=default_string_length) :: name = ""
75 : CHARACTER(LEN=default_string_length) :: aliases = ""
76 : REAL(KIND=dp) :: kind_radius = 0.0_dp
77 : REAL(KIND=dp) :: short_kind_radius = 0.0_dp
78 : INTEGER :: norm_type = -1
79 : INTEGER :: ncgf = -1, nset = -1, nsgf = -1
80 : CHARACTER(LEN=12), DIMENSION(:), POINTER :: cgf_symbol => NULL()
81 : CHARACTER(LEN=6), DIMENSION(:), POINTER :: sgf_symbol => NULL()
82 : REAL(KIND=dp), DIMENSION(:), POINTER :: norm_cgf => NULL(), set_radius => NULL()
83 : INTEGER, DIMENSION(:), POINTER :: lmax => NULL(), lmin => NULL(), &
84 : lx => NULL(), ly => NULL(), lz => NULL(), &
85 : m => NULL(), ncgf_set => NULL(), &
86 : npgf => NULL(), nsgf_set => NULL(), nshell => NULL()
87 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: cphi => NULL(), pgf_radius => NULL(), sphi => NULL(), &
88 : scon => NULL(), zet => NULL(), ccon => NULL()
89 : INTEGER, DIMENSION(:, :), POINTER :: first_cgf => NULL(), first_sgf => NULL(), l => NULL(), &
90 : last_cgf => NULL(), last_sgf => NULL(), n => NULL()
91 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: gcc => NULL()
92 : END TYPE gto_basis_set_type
93 :
94 : TYPE gto_basis_set_p_type
95 : TYPE(gto_basis_set_type), POINTER :: gto_basis_set => NULL()
96 : END TYPE gto_basis_set_p_type
97 :
98 : ! **************************************************************************************************
99 : ! Define the Slater-type orbital basis set type
100 :
101 : TYPE sto_basis_set_type
102 : PRIVATE
103 : CHARACTER(LEN=default_string_length) :: name = ""
104 : INTEGER :: nshell = -1
105 : CHARACTER(LEN=6), DIMENSION(:), POINTER :: symbol => NULL()
106 : INTEGER, DIMENSION(:), POINTER :: nq => NULL(), lq => NULL()
107 : REAL(KIND=dp), DIMENSION(:), POINTER :: zet => NULL()
108 : END TYPE sto_basis_set_type
109 :
110 : ! **************************************************************************************************
111 : INTERFACE read_gto_basis_set
112 : MODULE PROCEDURE read_gto_basis_set1, read_gto_basis_set2
113 : END INTERFACE
114 : ! **************************************************************************************************
115 :
116 : ! Public subroutines
117 : PUBLIC :: allocate_gto_basis_set, &
118 : deallocate_gto_basis_set, &
119 : get_gto_basis_set, &
120 : init_aux_basis_set, &
121 : init_cphi_and_sphi, &
122 : init_orb_basis_set, &
123 : read_gto_basis_set, &
124 : copy_gto_basis_set, &
125 : create_primitive_basis_set, &
126 : combine_basis_sets, &
127 : set_gto_basis_set, &
128 : sort_gto_basis_set, &
129 : write_gto_basis_set, &
130 : dump_gto_basis_set, &
131 : write_orb_basis_set
132 :
133 : PUBLIC :: allocate_sto_basis_set, &
134 : read_sto_basis_set, &
135 : create_gto_from_sto_basis, &
136 : deallocate_sto_basis_set, &
137 : set_sto_basis_set, &
138 : srules, process_gto_basis
139 :
140 : ! Public data types
141 : PUBLIC :: gto_basis_set_p_type, &
142 : gto_basis_set_type, &
143 : sto_basis_set_type
144 :
145 : CONTAINS
146 :
147 : ! **************************************************************************************************
148 : !> \brief ...
149 : !> \param gto_basis_set ...
150 : ! **************************************************************************************************
151 26860 : SUBROUTINE allocate_gto_basis_set(gto_basis_set)
152 :
153 : ! Allocate a Gaussian-type orbital (GTO) basis set data set.
154 :
155 : ! - Creation (26.10.2000,MK)
156 :
157 : TYPE(gto_basis_set_type), POINTER :: gto_basis_set
158 :
159 26860 : CALL deallocate_gto_basis_set(gto_basis_set)
160 :
161 26860 : ALLOCATE (gto_basis_set)
162 :
163 26860 : END SUBROUTINE allocate_gto_basis_set
164 :
165 : ! **************************************************************************************************
166 : !> \brief ...
167 : !> \param gto_basis_set ...
168 : ! **************************************************************************************************
169 54096 : SUBROUTINE deallocate_gto_basis_set(gto_basis_set)
170 :
171 : ! Deallocate a Gaussian-type orbital (GTO) basis set data set.
172 :
173 : ! - Creation (03.11.2000,MK)
174 :
175 : TYPE(gto_basis_set_type), POINTER :: gto_basis_set
176 :
177 54096 : IF (ASSOCIATED(gto_basis_set)) THEN
178 27236 : IF (ASSOCIATED(gto_basis_set%cgf_symbol)) DEALLOCATE (gto_basis_set%cgf_symbol)
179 27236 : IF (ASSOCIATED(gto_basis_set%sgf_symbol)) DEALLOCATE (gto_basis_set%sgf_symbol)
180 27236 : IF (ASSOCIATED(gto_basis_set%norm_cgf)) DEALLOCATE (gto_basis_set%norm_cgf)
181 27236 : IF (ASSOCIATED(gto_basis_set%set_radius)) DEALLOCATE (gto_basis_set%set_radius)
182 27236 : IF (ASSOCIATED(gto_basis_set%lmax)) DEALLOCATE (gto_basis_set%lmax)
183 27236 : IF (ASSOCIATED(gto_basis_set%lmin)) DEALLOCATE (gto_basis_set%lmin)
184 27236 : IF (ASSOCIATED(gto_basis_set%lx)) DEALLOCATE (gto_basis_set%lx)
185 27236 : IF (ASSOCIATED(gto_basis_set%ly)) DEALLOCATE (gto_basis_set%ly)
186 27236 : IF (ASSOCIATED(gto_basis_set%lz)) DEALLOCATE (gto_basis_set%lz)
187 27236 : IF (ASSOCIATED(gto_basis_set%m)) DEALLOCATE (gto_basis_set%m)
188 27236 : IF (ASSOCIATED(gto_basis_set%ncgf_set)) DEALLOCATE (gto_basis_set%ncgf_set)
189 27236 : IF (ASSOCIATED(gto_basis_set%npgf)) DEALLOCATE (gto_basis_set%npgf)
190 27236 : IF (ASSOCIATED(gto_basis_set%nsgf_set)) DEALLOCATE (gto_basis_set%nsgf_set)
191 27236 : IF (ASSOCIATED(gto_basis_set%nshell)) DEALLOCATE (gto_basis_set%nshell)
192 27236 : IF (ASSOCIATED(gto_basis_set%cphi)) DEALLOCATE (gto_basis_set%cphi)
193 27236 : IF (ASSOCIATED(gto_basis_set%pgf_radius)) DEALLOCATE (gto_basis_set%pgf_radius)
194 27236 : IF (ASSOCIATED(gto_basis_set%sphi)) DEALLOCATE (gto_basis_set%sphi)
195 27236 : IF (ASSOCIATED(gto_basis_set%scon)) DEALLOCATE (gto_basis_set%scon)
196 27236 : IF (ASSOCIATED(gto_basis_set%ccon)) DEALLOCATE (gto_basis_set%ccon)
197 27236 : IF (ASSOCIATED(gto_basis_set%zet)) DEALLOCATE (gto_basis_set%zet)
198 27236 : IF (ASSOCIATED(gto_basis_set%first_cgf)) DEALLOCATE (gto_basis_set%first_cgf)
199 27236 : IF (ASSOCIATED(gto_basis_set%first_sgf)) DEALLOCATE (gto_basis_set%first_sgf)
200 27236 : IF (ASSOCIATED(gto_basis_set%l)) DEALLOCATE (gto_basis_set%l)
201 27236 : IF (ASSOCIATED(gto_basis_set%last_cgf)) DEALLOCATE (gto_basis_set%last_cgf)
202 27236 : IF (ASSOCIATED(gto_basis_set%last_sgf)) DEALLOCATE (gto_basis_set%last_sgf)
203 27236 : IF (ASSOCIATED(gto_basis_set%n)) DEALLOCATE (gto_basis_set%n)
204 27236 : IF (ASSOCIATED(gto_basis_set%gcc)) DEALLOCATE (gto_basis_set%gcc)
205 27236 : DEALLOCATE (gto_basis_set)
206 : END IF
207 54096 : END SUBROUTINE deallocate_gto_basis_set
208 :
209 : ! **************************************************************************************************
210 : !> \brief ...
211 : !> \param basis_set_in ...
212 : !> \param basis_set_out ...
213 : ! **************************************************************************************************
214 4468 : SUBROUTINE copy_gto_basis_set(basis_set_in, basis_set_out)
215 :
216 : ! Copy a Gaussian-type orbital (GTO) basis set data set.
217 :
218 : TYPE(gto_basis_set_type), INTENT(IN) :: basis_set_in
219 : TYPE(gto_basis_set_type), POINTER :: basis_set_out
220 :
221 : INTEGER :: maxco, maxpgf, maxshell, ncgf, nset, nsgf
222 :
223 4468 : CALL allocate_gto_basis_set(basis_set_out)
224 :
225 4468 : basis_set_out%name = basis_set_in%name
226 4468 : basis_set_out%aliases = basis_set_in%aliases
227 4468 : basis_set_out%kind_radius = basis_set_in%kind_radius
228 4468 : basis_set_out%norm_type = basis_set_in%norm_type
229 4468 : basis_set_out%nset = basis_set_in%nset
230 4468 : basis_set_out%ncgf = basis_set_in%ncgf
231 4468 : basis_set_out%nsgf = basis_set_in%nsgf
232 4468 : nset = basis_set_in%nset
233 4468 : ncgf = basis_set_in%ncgf
234 4468 : nsgf = basis_set_in%nsgf
235 13404 : ALLOCATE (basis_set_out%cgf_symbol(ncgf))
236 13404 : ALLOCATE (basis_set_out%sgf_symbol(nsgf))
237 63442 : basis_set_out%cgf_symbol = basis_set_in%cgf_symbol
238 57478 : basis_set_out%sgf_symbol = basis_set_in%sgf_symbol
239 13404 : ALLOCATE (basis_set_out%norm_cgf(ncgf))
240 63442 : basis_set_out%norm_cgf = basis_set_in%norm_cgf
241 13404 : ALLOCATE (basis_set_out%set_radius(nset))
242 17504 : basis_set_out%set_radius = basis_set_in%set_radius
243 26808 : ALLOCATE (basis_set_out%lmax(nset), basis_set_out%lmin(nset), basis_set_out%npgf(nset), basis_set_out%nshell(nset))
244 17504 : basis_set_out%lmax = basis_set_in%lmax
245 17504 : basis_set_out%lmin = basis_set_in%lmin
246 17504 : basis_set_out%npgf = basis_set_in%npgf
247 17504 : basis_set_out%nshell = basis_set_in%nshell
248 31276 : ALLOCATE (basis_set_out%lx(ncgf), basis_set_out%ly(ncgf), basis_set_out%lz(ncgf), basis_set_out%m(nsgf))
249 63442 : basis_set_out%lx = basis_set_in%lx
250 63442 : basis_set_out%ly = basis_set_in%ly
251 63442 : basis_set_out%lz = basis_set_in%lz
252 57478 : basis_set_out%m = basis_set_in%m
253 13404 : ALLOCATE (basis_set_out%ncgf_set(nset), basis_set_out%nsgf_set(nset))
254 17504 : basis_set_out%ncgf_set = basis_set_in%ncgf_set
255 17504 : basis_set_out%nsgf_set = basis_set_in%nsgf_set
256 4468 : maxco = SIZE(basis_set_in%cphi, 1)
257 40212 : ALLOCATE (basis_set_out%cphi(maxco, ncgf), basis_set_out%sphi(maxco, nsgf), basis_set_out%scon(maxco, nsgf))
258 13404 : ALLOCATE (basis_set_out%ccon(maxco, ncgf))
259 1506152 : basis_set_out%cphi = basis_set_in%cphi
260 1289588 : basis_set_out%sphi = basis_set_in%sphi
261 1289588 : basis_set_out%scon = basis_set_in%scon
262 1506152 : basis_set_out%ccon = 0.0_dp
263 4468 : IF (ASSOCIATED(basis_set_in%ccon)) THEN
264 4280 : IF ((SIZE(basis_set_in%ccon, 1) == maxco) .AND. (SIZE(basis_set_in%ccon, 2) == ncgf)) THEN
265 1494012 : basis_set_out%ccon = basis_set_in%ccon
266 : END IF
267 : END IF
268 17504 : maxpgf = MAXVAL(basis_set_in%npgf)
269 26808 : ALLOCATE (basis_set_out%pgf_radius(maxpgf, nset), basis_set_out%zet(maxpgf, nset))
270 62644 : basis_set_out%pgf_radius = basis_set_in%pgf_radius
271 62644 : basis_set_out%zet = basis_set_in%zet
272 17504 : maxshell = MAXVAL(basis_set_in%nshell)
273 26808 : ALLOCATE (basis_set_out%first_cgf(maxshell, nset), basis_set_out%first_sgf(maxshell, nset))
274 22340 : ALLOCATE (basis_set_out%last_cgf(maxshell, nset), basis_set_out%last_sgf(maxshell, nset))
275 45270 : basis_set_out%first_cgf = basis_set_in%first_cgf
276 45270 : basis_set_out%first_sgf = basis_set_in%first_sgf
277 45270 : basis_set_out%last_cgf = basis_set_in%last_cgf
278 45270 : basis_set_out%last_sgf = basis_set_in%last_sgf
279 22340 : ALLOCATE (basis_set_out%n(maxshell, nset), basis_set_out%l(maxshell, nset))
280 45270 : basis_set_out%n = basis_set_in%n
281 45270 : basis_set_out%l = basis_set_in%l
282 22340 : ALLOCATE (basis_set_out%gcc(maxpgf, maxshell, nset))
283 154064 : basis_set_out%gcc = basis_set_in%gcc
284 :
285 4468 : END SUBROUTINE copy_gto_basis_set
286 :
287 : ! **************************************************************************************************
288 : !> \brief ...
289 : !> \param basis_set ...
290 : !> \param pbasis ...
291 : !> \param lmax ...
292 : ! **************************************************************************************************
293 246 : SUBROUTINE create_primitive_basis_set(basis_set, pbasis, lmax)
294 :
295 : ! Create a primitives only basis set
296 :
297 : TYPE(gto_basis_set_type), INTENT(IN) :: basis_set
298 : TYPE(gto_basis_set_type), POINTER :: pbasis
299 : INTEGER, INTENT(IN), OPTIONAL :: lmax
300 :
301 : INTEGER :: i, ico, ip, ipgf, iset, ishell, l, lm, &
302 : lshell, m, maxco, mpgf, nc, ncgf, ns, &
303 : nset, nsgf
304 246 : INTEGER, ALLOCATABLE, DIMENSION(:) :: nindex, nprim
305 : REAL(KIND=dp) :: zet0
306 246 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: zet, zeta
307 :
308 830 : mpgf = SUM(basis_set%npgf)
309 830 : lm = MAXVAL(basis_set%lmax)
310 2706 : ALLOCATE (zet(mpgf, 0:lm), zeta(mpgf, lm + 1), nindex(mpgf), nprim(0:lm))
311 246 : zet = 0.0_dp
312 246 : zeta = 0.0_dp
313 870 : DO l = 0, lm
314 624 : ip = 0
315 2240 : DO iset = 1, basis_set%nset
316 2240 : IF (basis_set%lmin(iset) <= l .AND. basis_set%lmax(iset) >= l) THEN
317 2610 : DO ipgf = 1, basis_set%npgf(iset)
318 1986 : ip = ip + 1
319 2610 : zet(ip, l) = basis_set%zet(ipgf, iset)
320 : END DO
321 : END IF
322 : END DO
323 870 : nprim(l) = ip
324 : END DO
325 :
326 : ! sort exponents
327 870 : DO l = 0, lm
328 2610 : zet(1:nprim(l), l) = -zet(1:nprim(l), l)
329 624 : CALL sort(zet(1:nprim(l), l), nprim(l), nindex)
330 : ! remove duplicates
331 624 : ip = 0
332 624 : zet0 = 0.0_dp
333 2610 : DO i = 1, nprim(l)
334 2610 : IF (ABS(zet0 - zet(i, l)) > 1.e-6_dp) THEN
335 1986 : ip = ip + 1
336 1986 : zeta(ip, l + 1) = zet(i, l)
337 : END IF
338 : END DO
339 624 : nprim(l) = ip
340 : !
341 2856 : zeta(1:ip, l + 1) = -zeta(1:ip, l + 1)
342 : END DO
343 :
344 246 : CALL allocate_gto_basis_set(pbasis)
345 :
346 246 : IF (PRESENT(lmax)) THEN
347 : ! if requested, reduce max l val
348 22 : lm = MIN(lm, lmax)
349 : END IF
350 :
351 246 : IF (LEN_TRIM(basis_set%name) + 10 > default_string_length) THEN
352 0 : CPWARN("The name of the primitive basis set will be truncated.")
353 : END IF
354 246 : pbasis%name = TRIM(basis_set%name)//"_primitive"
355 246 : pbasis%kind_radius = basis_set%kind_radius
356 246 : pbasis%short_kind_radius = basis_set%short_kind_radius
357 246 : pbasis%norm_type = basis_set%norm_type
358 246 : nset = lm + 1
359 246 : pbasis%nset = nset
360 1476 : ALLOCATE (pbasis%lmax(nset), pbasis%lmin(nset), pbasis%npgf(nset), pbasis%nshell(nset))
361 812 : DO iset = 1, nset
362 566 : pbasis%lmax(iset) = iset - 1
363 566 : pbasis%lmin(iset) = iset - 1
364 566 : pbasis%npgf(iset) = nprim(iset - 1)
365 812 : pbasis%nshell(iset) = nprim(iset - 1)
366 : END DO
367 246 : pbasis%ncgf = 0
368 246 : pbasis%nsgf = 0
369 812 : DO l = 0, lm
370 566 : pbasis%ncgf = pbasis%ncgf + nprim(l)*((l + 1)*(l + 2))/2
371 812 : pbasis%nsgf = pbasis%nsgf + nprim(l)*(2*l + 1)
372 : END DO
373 870 : mpgf = MAXVAL(nprim)
374 984 : ALLOCATE (pbasis%zet(mpgf, nset))
375 3080 : pbasis%zet(1:mpgf, 1:nset) = zeta(1:mpgf, 1:nset)
376 :
377 1476 : ALLOCATE (pbasis%l(mpgf, nset), pbasis%n(mpgf, nset))
378 812 : DO iset = 1, nset
379 2566 : DO ip = 1, nprim(iset - 1)
380 1754 : pbasis%l(ip, iset) = iset - 1
381 2320 : pbasis%n(ip, iset) = iset + ip - 1
382 : END DO
383 : END DO
384 :
385 738 : ALLOCATE (pbasis%cgf_symbol(pbasis%ncgf))
386 738 : ALLOCATE (pbasis%lx(pbasis%ncgf))
387 738 : ALLOCATE (pbasis%ly(pbasis%ncgf))
388 738 : ALLOCATE (pbasis%lz(pbasis%ncgf))
389 738 : ALLOCATE (pbasis%m(pbasis%nsgf))
390 738 : ALLOCATE (pbasis%sgf_symbol(pbasis%nsgf))
391 738 : ALLOCATE (pbasis%ncgf_set(nset), pbasis%nsgf_set(nset))
392 :
393 246 : ncgf = 0
394 246 : nsgf = 0
395 812 : DO iset = 1, nset
396 566 : l = iset - 1
397 566 : pbasis%ncgf_set(iset) = nprim(l)*((l + 1)*(l + 2))/2
398 566 : pbasis%nsgf_set(iset) = nprim(l)*(2*l + 1)
399 2566 : DO ishell = 1, pbasis%nshell(iset)
400 1754 : lshell = pbasis%l(ishell, iset)
401 7286 : DO ico = ncoset(lshell - 1) + 1, ncoset(lshell)
402 5532 : ncgf = ncgf + 1
403 5532 : pbasis%lx(ncgf) = indco(1, ico)
404 5532 : pbasis%ly(ncgf) = indco(2, ico)
405 5532 : pbasis%lz(ncgf) = indco(3, ico)
406 : pbasis%cgf_symbol(ncgf) = &
407 23882 : cgf_symbol(pbasis%n(ishell, iset), [pbasis%lx(ncgf), pbasis%ly(ncgf), pbasis%lz(ncgf)])
408 : END DO
409 7222 : DO m = -lshell, lshell
410 4902 : nsgf = nsgf + 1
411 4902 : pbasis%m(nsgf) = m
412 6656 : pbasis%sgf_symbol(nsgf) = sgf_symbol(pbasis%n(ishell, iset), lshell, m)
413 : END DO
414 : END DO
415 : END DO
416 246 : CPASSERT(ncgf == pbasis%ncgf)
417 246 : CPASSERT(nsgf == pbasis%nsgf)
418 :
419 1230 : ALLOCATE (pbasis%gcc(mpgf, mpgf, nset))
420 14084 : pbasis%gcc = 0.0_dp
421 812 : DO iset = 1, nset
422 3080 : DO i = 1, mpgf
423 2834 : pbasis%gcc(i, i, iset) = 1.0_dp
424 : END DO
425 : END DO
426 :
427 738 : ALLOCATE (pbasis%first_cgf(mpgf, nset))
428 738 : ALLOCATE (pbasis%first_sgf(mpgf, nset))
429 738 : ALLOCATE (pbasis%last_cgf(mpgf, nset))
430 738 : ALLOCATE (pbasis%last_sgf(mpgf, nset))
431 246 : nc = 0
432 246 : ns = 0
433 246 : maxco = 0
434 812 : DO iset = 1, nset
435 2320 : DO ishell = 1, pbasis%nshell(iset)
436 1754 : lshell = pbasis%l(ishell, iset)
437 1754 : pbasis%first_cgf(ishell, iset) = nc + 1
438 1754 : nc = nc + nco(lshell)
439 1754 : pbasis%last_cgf(ishell, iset) = nc
440 1754 : pbasis%first_sgf(ishell, iset) = ns + 1
441 1754 : ns = ns + nso(lshell)
442 2320 : pbasis%last_sgf(ishell, iset) = ns
443 : END DO
444 812 : maxco = MAX(maxco, pbasis%npgf(iset)*ncoset(pbasis%lmax(iset)))
445 : END DO
446 :
447 738 : ALLOCATE (pbasis%norm_cgf(ncgf))
448 984 : ALLOCATE (pbasis%cphi(maxco, ncgf))
449 293500 : pbasis%cphi = 0.0_dp
450 984 : ALLOCATE (pbasis%sphi(maxco, nsgf))
451 244226 : pbasis%sphi = 0.0_dp
452 738 : ALLOCATE (pbasis%scon(maxco, ncgf))
453 293500 : pbasis%scon = 0.0_dp
454 738 : ALLOCATE (pbasis%ccon(maxco, ncgf))
455 293500 : pbasis%ccon = 0.0_dp
456 738 : ALLOCATE (pbasis%set_radius(nset))
457 738 : ALLOCATE (pbasis%pgf_radius(mpgf, nset))
458 3080 : pbasis%pgf_radius = 0.0_dp
459 :
460 246 : CALL init_orb_basis_set(pbasis)
461 :
462 246 : DEALLOCATE (zet, zeta, nindex, nprim)
463 :
464 246 : END SUBROUTINE create_primitive_basis_set
465 :
466 : ! **************************************************************************************************
467 : !> \brief ...
468 : !> \param basis_set ...
469 : !> \param basis_set_add ...
470 : ! **************************************************************************************************
471 212 : SUBROUTINE combine_basis_sets(basis_set, basis_set_add)
472 :
473 : ! Combine two Gaussian-type orbital (GTO) basis sets.
474 :
475 : TYPE(gto_basis_set_type), INTENT(INOUT) :: basis_set
476 : TYPE(gto_basis_set_type), INTENT(IN) :: basis_set_add
477 :
478 212 : CHARACTER(LEN=12), DIMENSION(:), POINTER :: cgf_symbol
479 212 : CHARACTER(LEN=6), DIMENSION(:), POINTER :: sgf_symbol
480 : INTEGER :: iset, ishell, lshell, maxco, maxpgf, &
481 : maxshell, nc, ncgf, ncgfn, ncgfo, ns, &
482 : nset, nsetn, nseto, nsgf, nsgfn, nsgfo
483 :
484 212 : IF (LEN_TRIM(basis_set%name) + LEN_TRIM(basis_set_add%name) > default_string_length) THEN
485 0 : CPWARN("The name of the combined GTO basis set will be truncated.")
486 : END IF
487 212 : basis_set%name = TRIM(basis_set%name)//TRIM(basis_set_add%name)
488 212 : basis_set%nset = basis_set%nset + basis_set_add%nset
489 212 : basis_set%ncgf = basis_set%ncgf + basis_set_add%ncgf
490 212 : basis_set%nsgf = basis_set%nsgf + basis_set_add%nsgf
491 212 : nset = basis_set%nset
492 212 : ncgf = basis_set%ncgf
493 212 : nsgf = basis_set%nsgf
494 :
495 212 : nsetn = basis_set_add%nset
496 212 : nseto = nset - nsetn
497 212 : CALL reallocate(basis_set%set_radius, 1, nset) ! to be defined later
498 212 : CALL reallocate(basis_set%lmax, 1, nset)
499 212 : CALL reallocate(basis_set%lmin, 1, nset)
500 212 : CALL reallocate(basis_set%npgf, 1, nset)
501 212 : CALL reallocate(basis_set%nshell, 1, nset)
502 732 : basis_set%lmax(nseto + 1:nset) = basis_set_add%lmax(1:nsetn)
503 732 : basis_set%lmin(nseto + 1:nset) = basis_set_add%lmin(1:nsetn)
504 732 : basis_set%npgf(nseto + 1:nset) = basis_set_add%npgf(1:nsetn)
505 732 : basis_set%nshell(nseto + 1:nset) = basis_set_add%nshell(1:nsetn)
506 212 : CALL reallocate(basis_set%ncgf_set, 1, nset)
507 212 : CALL reallocate(basis_set%nsgf_set, 1, nset)
508 732 : basis_set%ncgf_set(nseto + 1:nset) = basis_set_add%ncgf_set(1:nsetn)
509 732 : basis_set%nsgf_set(nseto + 1:nset) = basis_set_add%nsgf_set(1:nsetn)
510 :
511 212 : nsgfn = basis_set_add%nsgf
512 212 : nsgfo = nsgf - nsgfn
513 212 : ncgfn = basis_set_add%ncgf
514 212 : ncgfo = ncgf - ncgfn
515 :
516 1060 : ALLOCATE (cgf_symbol(ncgf), sgf_symbol(nsgf))
517 2360 : cgf_symbol(1:ncgfo) = basis_set%cgf_symbol(1:ncgfo)
518 5458 : cgf_symbol(ncgfo + 1:ncgf) = basis_set_add%cgf_symbol(1:ncgfn)
519 2234 : sgf_symbol(1:nsgfo) = basis_set%sgf_symbol(1:nsgfo)
520 4832 : sgf_symbol(nsgfo + 1:nsgf) = basis_set_add%sgf_symbol(1:nsgfn)
521 212 : DEALLOCATE (basis_set%cgf_symbol, basis_set%sgf_symbol)
522 636 : ALLOCATE (basis_set%cgf_symbol(ncgf), basis_set%sgf_symbol(nsgf))
523 7606 : basis_set%cgf_symbol = cgf_symbol
524 6854 : basis_set%sgf_symbol = sgf_symbol
525 212 : DEALLOCATE (cgf_symbol, sgf_symbol)
526 :
527 212 : CALL reallocate(basis_set%lx, 1, ncgf)
528 212 : CALL reallocate(basis_set%ly, 1, ncgf)
529 212 : CALL reallocate(basis_set%lz, 1, ncgf)
530 212 : CALL reallocate(basis_set%m, 1, nsgf)
531 5458 : basis_set%lx(ncgfo + 1:ncgf) = basis_set_add%lx(1:ncgfn)
532 5458 : basis_set%ly(ncgfo + 1:ncgf) = basis_set_add%ly(1:ncgfn)
533 5458 : basis_set%lz(ncgfo + 1:ncgf) = basis_set_add%lz(1:ncgfn)
534 4832 : basis_set%m(nsgfo + 1:nsgf) = basis_set_add%m(1:nsgfn)
535 :
536 1090 : maxpgf = MAXVAL(basis_set%npgf)
537 212 : CALL reallocate(basis_set%zet, 1, maxpgf, 1, nset)
538 212 : nc = SIZE(basis_set_add%zet, 1)
539 732 : DO iset = 1, nsetn
540 2764 : basis_set%zet(1:nc, nseto + iset) = basis_set_add%zet(1:nc, iset)
541 : END DO
542 :
543 1090 : maxshell = MAXVAL(basis_set%nshell)
544 212 : CALL reallocate(basis_set%l, 1, maxshell, 1, nset)
545 212 : CALL reallocate(basis_set%n, 1, maxshell, 1, nset)
546 212 : nc = SIZE(basis_set_add%l, 1)
547 732 : DO iset = 1, nsetn
548 2552 : basis_set%l(1:nc, nseto + iset) = basis_set_add%l(1:nc, iset)
549 2764 : basis_set%n(1:nc, nseto + iset) = basis_set_add%n(1:nc, iset)
550 : END DO
551 :
552 212 : CALL reallocate(basis_set%first_cgf, 1, maxshell, 1, nset)
553 212 : CALL reallocate(basis_set%first_sgf, 1, maxshell, 1, nset)
554 212 : CALL reallocate(basis_set%last_cgf, 1, maxshell, 1, nset)
555 212 : CALL reallocate(basis_set%last_sgf, 1, maxshell, 1, nset)
556 212 : nc = 0
557 212 : ns = 0
558 1090 : DO iset = 1, nset
559 3528 : DO ishell = 1, basis_set%nshell(iset)
560 2438 : lshell = basis_set%l(ishell, iset)
561 2438 : basis_set%first_cgf(ishell, iset) = nc + 1
562 2438 : nc = nc + nco(lshell)
563 2438 : basis_set%last_cgf(ishell, iset) = nc
564 2438 : basis_set%first_sgf(ishell, iset) = ns + 1
565 2438 : ns = ns + nso(lshell)
566 3316 : basis_set%last_sgf(ishell, iset) = ns
567 : END DO
568 : END DO
569 :
570 212 : CALL reallocate(basis_set%gcc, 1, maxpgf, 1, maxshell, 1, nset)
571 212 : nc = SIZE(basis_set_add%gcc, 1)
572 212 : ns = SIZE(basis_set_add%gcc, 2)
573 732 : DO iset = 1, nsetn
574 12452 : basis_set%gcc(1:nc, 1:ns, nseto + iset) = basis_set_add%gcc(1:nc, 1:ns, iset)
575 : END DO
576 :
577 : ! these arrays are determined later using initialization calls
578 212 : CALL reallocate(basis_set%norm_cgf, 1, ncgf)
579 212 : maxco = MAX(SIZE(basis_set%cphi, 1), SIZE(basis_set_add%cphi, 1))
580 212 : CALL reallocate(basis_set%cphi, 1, maxco, 1, ncgf)
581 212 : CALL reallocate(basis_set%sphi, 1, maxco, 1, nsgf)
582 212 : CALL reallocate(basis_set%scon, 1, maxco, 1, nsgf)
583 212 : CALL reallocate(basis_set%ccon, 1, maxco, 1, ncgf)
584 212 : CALL reallocate(basis_set%pgf_radius, 1, maxpgf, 1, nset)
585 :
586 212 : END SUBROUTINE combine_basis_sets
587 :
588 : ! **************************************************************************************************
589 : !> \brief ...
590 : !> \param gto_basis_set ...
591 : !> \param name ...
592 : !> \param aliases ...
593 : !> \param norm_type ...
594 : !> \param kind_radius ...
595 : !> \param ncgf ...
596 : !> \param nset ...
597 : !> \param nsgf ...
598 : !> \param cgf_symbol ...
599 : !> \param sgf_symbol ...
600 : !> \param norm_cgf ...
601 : !> \param set_radius ...
602 : !> \param lmax ...
603 : !> \param lmin ...
604 : !> \param lx ...
605 : !> \param ly ...
606 : !> \param lz ...
607 : !> \param m ...
608 : !> \param ncgf_set ...
609 : !> \param npgf ...
610 : !> \param nsgf_set ...
611 : !> \param nshell ...
612 : !> \param cphi ...
613 : !> \param pgf_radius ...
614 : !> \param sphi ...
615 : !> \param scon ...
616 : !> \param zet ...
617 : !> \param first_cgf ...
618 : !> \param first_sgf ...
619 : !> \param l ...
620 : !> \param last_cgf ...
621 : !> \param last_sgf ...
622 : !> \param n ...
623 : !> \param gcc ...
624 : !> \param maxco ...
625 : !> \param maxl ...
626 : !> \param maxpgf ...
627 : !> \param maxsgf_set ...
628 : !> \param maxshell ...
629 : !> \param maxso ...
630 : !> \param nco_sum ...
631 : !> \param npgf_sum ...
632 : !> \param nshell_sum ...
633 : !> \param maxder ...
634 : !> \param short_kind_radius ...
635 : !> \param npgf_seg_sum number of primitives in "segmented contraction format"
636 : !> \param ccon ...
637 : ! **************************************************************************************************
638 37886879 : SUBROUTINE get_gto_basis_set(gto_basis_set, name, aliases, norm_type, kind_radius, ncgf, &
639 : nset, nsgf, cgf_symbol, sgf_symbol, norm_cgf, set_radius, lmax, lmin, lx, ly, lz, &
640 : m, ncgf_set, npgf, nsgf_set, nshell, cphi, pgf_radius, sphi, scon, zet, first_cgf, first_sgf, l, &
641 : last_cgf, last_sgf, n, gcc, maxco, maxl, maxpgf, maxsgf_set, maxshell, maxso, nco_sum, &
642 : npgf_sum, nshell_sum, maxder, short_kind_radius, npgf_seg_sum, ccon)
643 :
644 : ! Get informations about a Gaussian-type orbital (GTO) basis set.
645 :
646 : ! - Creation (10.01.2002,MK)
647 :
648 : TYPE(gto_basis_set_type), INTENT(IN) :: gto_basis_set
649 : CHARACTER(LEN=default_string_length), &
650 : INTENT(OUT), OPTIONAL :: name, aliases
651 : INTEGER, INTENT(OUT), OPTIONAL :: norm_type
652 : REAL(KIND=dp), INTENT(OUT), OPTIONAL :: kind_radius
653 : INTEGER, INTENT(OUT), OPTIONAL :: ncgf, nset, nsgf
654 : CHARACTER(LEN=12), DIMENSION(:), OPTIONAL, POINTER :: cgf_symbol
655 : CHARACTER(LEN=6), DIMENSION(:), OPTIONAL, POINTER :: sgf_symbol
656 : REAL(KIND=dp), DIMENSION(:), OPTIONAL, POINTER :: norm_cgf, set_radius
657 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: lmax, lmin, lx, ly, lz, m, ncgf_set, &
658 : npgf, nsgf_set, nshell
659 : REAL(KIND=dp), DIMENSION(:, :), OPTIONAL, POINTER :: cphi, pgf_radius, sphi, scon, zet
660 : INTEGER, DIMENSION(:, :), OPTIONAL, POINTER :: first_cgf, first_sgf, l, last_cgf, &
661 : last_sgf, n
662 : REAL(KIND=dp), DIMENSION(:, :, :), OPTIONAL, &
663 : POINTER :: gcc
664 : INTEGER, INTENT(OUT), OPTIONAL :: maxco, maxl, maxpgf, maxsgf_set, &
665 : maxshell, maxso, nco_sum, npgf_sum, &
666 : nshell_sum
667 : INTEGER, INTENT(IN), OPTIONAL :: maxder
668 : REAL(KIND=dp), INTENT(OUT), OPTIONAL :: short_kind_radius
669 : INTEGER, INTENT(OUT), OPTIONAL :: npgf_seg_sum
670 : REAL(KIND=dp), DIMENSION(:, :), OPTIONAL, POINTER :: ccon
671 :
672 : INTEGER :: iset, nder
673 :
674 37886879 : IF (PRESENT(name)) name = gto_basis_set%name
675 37886879 : IF (PRESENT(aliases)) aliases = gto_basis_set%aliases
676 37886879 : IF (PRESENT(norm_type)) norm_type = gto_basis_set%norm_type
677 37886879 : IF (PRESENT(kind_radius)) kind_radius = gto_basis_set%kind_radius
678 37886879 : IF (PRESENT(short_kind_radius)) short_kind_radius = gto_basis_set%short_kind_radius
679 37886879 : IF (PRESENT(ncgf)) ncgf = gto_basis_set%ncgf
680 37886879 : IF (PRESENT(nset)) nset = gto_basis_set%nset
681 37886879 : IF (PRESENT(nsgf)) nsgf = gto_basis_set%nsgf
682 37886879 : IF (PRESENT(cgf_symbol)) cgf_symbol => gto_basis_set%cgf_symbol
683 37886879 : IF (PRESENT(sgf_symbol)) sgf_symbol => gto_basis_set%sgf_symbol
684 37886879 : IF (PRESENT(norm_cgf)) norm_cgf => gto_basis_set%norm_cgf
685 37886879 : IF (PRESENT(set_radius)) set_radius => gto_basis_set%set_radius
686 37886879 : IF (PRESENT(lmax)) lmax => gto_basis_set%lmax
687 37886879 : IF (PRESENT(lmin)) lmin => gto_basis_set%lmin
688 37886879 : IF (PRESENT(lx)) lx => gto_basis_set%lx
689 37886879 : IF (PRESENT(ly)) ly => gto_basis_set%ly
690 37886879 : IF (PRESENT(lz)) lz => gto_basis_set%lz
691 37886879 : IF (PRESENT(m)) m => gto_basis_set%m
692 37886879 : IF (PRESENT(ncgf_set)) ncgf_set => gto_basis_set%ncgf_set
693 37886879 : IF (PRESENT(npgf)) npgf => gto_basis_set%npgf
694 37886879 : IF (PRESENT(nsgf_set)) nsgf_set => gto_basis_set%nsgf_set
695 37886879 : IF (PRESENT(nshell)) nshell => gto_basis_set%nshell
696 37886879 : IF (PRESENT(cphi)) cphi => gto_basis_set%cphi
697 37886879 : IF (PRESENT(pgf_radius)) pgf_radius => gto_basis_set%pgf_radius
698 37886879 : IF (PRESENT(sphi)) sphi => gto_basis_set%sphi
699 37886879 : IF (PRESENT(scon)) scon => gto_basis_set%scon
700 37886879 : IF (PRESENT(ccon)) ccon => gto_basis_set%ccon
701 37886879 : IF (PRESENT(zet)) zet => gto_basis_set%zet
702 37886879 : IF (PRESENT(first_cgf)) first_cgf => gto_basis_set%first_cgf
703 37886879 : IF (PRESENT(first_sgf)) first_sgf => gto_basis_set%first_sgf
704 37886879 : IF (PRESENT(l)) l => gto_basis_set%l
705 37886879 : IF (PRESENT(last_cgf)) last_cgf => gto_basis_set%last_cgf
706 37886879 : IF (PRESENT(last_sgf)) last_sgf => gto_basis_set%last_sgf
707 37886879 : IF (PRESENT(n)) n => gto_basis_set%n
708 37886879 : IF (PRESENT(gcc)) gcc => gto_basis_set%gcc
709 37886879 : IF (PRESENT(maxco)) THEN
710 8379670 : maxco = 0
711 8379670 : IF (PRESENT(maxder)) THEN
712 0 : nder = maxder
713 : ELSE
714 : nder = 0
715 : END IF
716 27813231 : DO iset = 1, gto_basis_set%nset
717 : maxco = MAX(maxco, gto_basis_set%npgf(iset)* &
718 27813231 : ncoset(gto_basis_set%lmax(iset) + nder))
719 : END DO
720 : END IF
721 37886879 : IF (PRESENT(maxl)) THEN
722 8247966 : maxl = -1
723 26678318 : DO iset = 1, gto_basis_set%nset
724 26678318 : maxl = MAX(maxl, gto_basis_set%lmax(iset))
725 : END DO
726 : END IF
727 37886879 : IF (PRESENT(maxpgf)) THEN
728 6202 : maxpgf = 0
729 26072 : DO iset = 1, gto_basis_set%nset
730 26072 : maxpgf = MAX(maxpgf, gto_basis_set%npgf(iset))
731 : END DO
732 : END IF
733 37886879 : IF (PRESENT(maxsgf_set)) THEN
734 514332 : maxsgf_set = 0
735 2470875 : DO iset = 1, gto_basis_set%nset
736 2470875 : maxsgf_set = MAX(maxsgf_set, gto_basis_set%nsgf_set(iset))
737 : END DO
738 : END IF
739 37886879 : IF (PRESENT(maxshell)) THEN ! MAXVAL on structure component avoided
740 3770 : maxshell = 0
741 16170 : DO iset = 1, gto_basis_set%nset
742 16170 : maxshell = MAX(maxshell, gto_basis_set%nshell(iset))
743 : END DO
744 : END IF
745 37886879 : IF (PRESENT(maxso)) THEN
746 1489864 : maxso = 0
747 5469070 : DO iset = 1, gto_basis_set%nset
748 : maxso = MAX(maxso, gto_basis_set%npgf(iset)* &
749 5469070 : nsoset(gto_basis_set%lmax(iset)))
750 : END DO
751 : END IF
752 :
753 37886879 : IF (PRESENT(nco_sum)) THEN
754 151078 : nco_sum = 0
755 511238 : DO iset = 1, gto_basis_set%nset
756 : nco_sum = nco_sum + gto_basis_set%npgf(iset)* &
757 511238 : ncoset(gto_basis_set%lmax(iset))
758 : END DO
759 : END IF
760 37905644 : IF (PRESENT(npgf_sum)) npgf_sum = SUM(gto_basis_set%npgf)
761 37905650 : IF (PRESENT(nshell_sum)) nshell_sum = SUM(gto_basis_set%nshell)
762 37886879 : IF (PRESENT(npgf_seg_sum)) THEN
763 22 : npgf_seg_sum = 0
764 100 : DO iset = 1, gto_basis_set%nset
765 100 : npgf_seg_sum = npgf_seg_sum + gto_basis_set%npgf(iset)*gto_basis_set%nshell(iset)
766 : END DO
767 : END IF
768 :
769 37886879 : END SUBROUTINE get_gto_basis_set
770 :
771 : ! **************************************************************************************************
772 : !> \brief ...
773 : !> \param gto_basis_set ...
774 : ! **************************************************************************************************
775 12 : SUBROUTINE init_aux_basis_set(gto_basis_set)
776 :
777 : ! Initialise a Gaussian-type orbital (GTO) basis set data set.
778 :
779 : ! - Creation (06.12.2000,MK)
780 :
781 : TYPE(gto_basis_set_type), POINTER :: gto_basis_set
782 :
783 : CHARACTER(len=*), PARAMETER :: routineN = 'init_aux_basis_set'
784 :
785 : INTEGER :: handle
786 :
787 : ! -------------------------------------------------------------------------
788 :
789 6 : IF (.NOT. ASSOCIATED(gto_basis_set)) RETURN
790 :
791 6 : CALL timeset(routineN, handle)
792 :
793 12 : SELECT CASE (gto_basis_set%norm_type)
794 : CASE (0)
795 : ! No normalisation requested
796 : CASE (1)
797 6 : CALL init_norm_cgf_aux_2(gto_basis_set)
798 : CASE (2)
799 : ! WARNING this was never tested
800 0 : CALL init_norm_cgf_aux(gto_basis_set)
801 : CASE DEFAULT
802 6 : CPABORT("Normalization method not specified")
803 : END SELECT
804 :
805 : ! Initialise the transformation matrices "pgf" -> "cgf"
806 6 : CALL init_cphi_and_sphi(gto_basis_set, .FALSE.)
807 :
808 6 : CALL timestop(handle)
809 :
810 : END SUBROUTINE init_aux_basis_set
811 :
812 : ! **************************************************************************************************
813 : !> \brief ...
814 : !> \param gto_basis_set ...
815 : !> \param lccon ...
816 : ! **************************************************************************************************
817 46522 : SUBROUTINE init_cphi_and_sphi(gto_basis_set, lccon)
818 :
819 : ! Initialise the matrices for the transformation of primitive Cartesian
820 : ! Gaussian-type functions to contracted Cartesian (cphi) and spherical
821 : ! (sphi) Gaussian-type functions.
822 :
823 : ! - Creation (20.09.2000,MK)
824 :
825 : TYPE(gto_basis_set_type), INTENT(INOUT) :: gto_basis_set
826 : LOGICAL, INTENT(IN), OPTIONAL :: lccon
827 :
828 : CHARACTER(len=*), PARAMETER :: routineN = 'init_cphi_and_sphi'
829 :
830 : INTEGER :: first_cgf, first_sgf, handle, icgf, ico, &
831 : ipgf, iset, ishell, l, last_sgf, lmax, &
832 : lmin, n, n1, n2, ncgf, nn, nn1, nn2, &
833 : npgf, nsgf
834 : LOGICAL :: my_lccon
835 :
836 23261 : my_lccon = .FALSE.
837 23261 : IF (PRESENT(lccon)) my_lccon = lccon
838 : ! -------------------------------------------------------------------------
839 : ! Build the Cartesian transformation matrix "cphi"
840 :
841 23261 : CALL timeset(routineN, handle)
842 :
843 8422288 : gto_basis_set%cphi = 0.0_dp
844 83830 : DO iset = 1, gto_basis_set%nset
845 60569 : n = ncoset(gto_basis_set%lmax(iset))
846 183791 : DO ishell = 1, gto_basis_set%nshell(iset)
847 363983 : DO icgf = gto_basis_set%first_cgf(ishell, iset), &
848 160530 : gto_basis_set%last_cgf(ishell, iset)
849 : ico = coset(gto_basis_set%lx(icgf), &
850 : gto_basis_set%ly(icgf), &
851 264022 : gto_basis_set%lz(icgf))
852 1236847 : DO ipgf = 1, gto_basis_set%npgf(iset)
853 : gto_basis_set%cphi(ico, icgf) = gto_basis_set%norm_cgf(icgf)* &
854 872864 : gto_basis_set%gcc(ipgf, ishell, iset)
855 1136886 : ico = ico + n
856 : END DO
857 : END DO
858 : END DO
859 : END DO
860 :
861 : ! Build the spherical transformation matrix "sphi"
862 :
863 23261 : n = SIZE(gto_basis_set%cphi, 1)
864 :
865 7430999 : gto_basis_set%sphi = 0.0_dp
866 23261 : IF (n > 0) THEN
867 23251 : lmax = -1
868 : ! Ensure proper setup of orbtramat
869 83814 : DO iset = 1, gto_basis_set%nset
870 183769 : DO ishell = 1, gto_basis_set%nshell(iset)
871 160518 : lmax = MAX(lmax, gto_basis_set%l(ishell, iset))
872 : END DO
873 : END DO
874 23251 : CALL init_spherical_harmonics(lmax, -1)
875 :
876 83814 : DO iset = 1, gto_basis_set%nset
877 183769 : DO ishell = 1, gto_basis_set%nshell(iset)
878 99955 : l = gto_basis_set%l(ishell, iset)
879 99955 : first_cgf = gto_basis_set%first_cgf(ishell, iset)
880 99955 : first_sgf = gto_basis_set%first_sgf(ishell, iset)
881 99955 : ncgf = nco(l)
882 99955 : nsgf = nso(l)
883 : CALL dgemm("N", "T", n, nsgf, ncgf, &
884 : 1.0_dp, gto_basis_set%cphi(1, first_cgf), n, &
885 : orbtramat(l)%c2s(1, 1), nsgf, &
886 160518 : 0.0_dp, gto_basis_set%sphi(1, first_sgf), n)
887 : END DO
888 : END DO
889 : END IF
890 :
891 : ! Build the reduced transformation matrix "scon"
892 : ! This matrix transforms from cartesian primitifs to spherical contracted functions
893 : ! "scon" only includes primitifs (lmin -> lmax), whereas sphi is (0 -> lmax)
894 :
895 23261 : n = SIZE(gto_basis_set%scon, 1)
896 :
897 7480273 : gto_basis_set%scon = 0.0_dp
898 23261 : IF (n > 0) THEN
899 83814 : DO iset = 1, gto_basis_set%nset
900 60563 : lmin = gto_basis_set%lmin(iset)
901 60563 : lmax = gto_basis_set%lmax(iset)
902 60563 : npgf = gto_basis_set%npgf(iset)
903 60563 : nn = ncoset(lmax) - ncoset(lmin - 1)
904 183769 : DO ishell = 1, gto_basis_set%nshell(iset)
905 99955 : first_sgf = gto_basis_set%first_sgf(ishell, iset)
906 99955 : last_sgf = gto_basis_set%last_sgf(ishell, iset)
907 532437 : DO ipgf = 1, npgf
908 371919 : nn1 = (ipgf - 1)*ncoset(lmax) + ncoset(lmin - 1) + 1
909 371919 : nn2 = ipgf*ncoset(lmax)
910 371919 : n1 = (ipgf - 1)*nn + 1
911 371919 : n2 = ipgf*nn
912 6405247 : gto_basis_set%scon(n1:n2, first_sgf:last_sgf) = gto_basis_set%sphi(nn1:nn2, first_sgf:last_sgf)
913 : END DO
914 : END DO
915 : END DO
916 : END IF
917 :
918 23261 : IF (my_lccon) THEN
919 20747 : IF (.NOT. ASSOCIATED(gto_basis_set%ccon)) THEN
920 248 : CALL reallocate(gto_basis_set%ccon, 1, SIZE(gto_basis_set%cphi, 1), 1, gto_basis_set%ncgf)
921 20499 : ELSE IF ((SIZE(gto_basis_set%ccon, 1) /= SIZE(gto_basis_set%cphi, 1)) .OR. &
922 : (SIZE(gto_basis_set%ccon, 2) /= gto_basis_set%ncgf)) THEN
923 0 : CALL reallocate(gto_basis_set%ccon, 1, SIZE(gto_basis_set%cphi, 1), 1, gto_basis_set%ncgf)
924 : END IF
925 20747 : n = SIZE(gto_basis_set%ccon, 1)
926 7955498 : gto_basis_set%ccon = 0.0_dp
927 20747 : IF (n > 0) THEN
928 73968 : DO iset = 1, gto_basis_set%nset
929 53229 : lmin = gto_basis_set%lmin(iset)
930 53229 : lmax = gto_basis_set%lmax(iset)
931 53229 : npgf = gto_basis_set%npgf(iset)
932 53229 : nn = ncoset(lmax) - ncoset(lmin - 1)
933 162079 : DO ishell = 1, gto_basis_set%nshell(iset)
934 88111 : first_sgf = gto_basis_set%first_cgf(ishell, iset)
935 88111 : last_sgf = gto_basis_set%last_cgf(ishell, iset)
936 489131 : DO ipgf = 1, npgf
937 347791 : nn1 = (ipgf - 1)*ncoset(lmax) + ncoset(lmin - 1) + 1
938 347791 : nn2 = ipgf*ncoset(lmax)
939 347791 : n1 = (ipgf - 1)*nn + 1
940 347791 : n2 = ipgf*nn
941 6759260 : gto_basis_set%ccon(n1:n2, first_sgf:last_sgf) = gto_basis_set%cphi(nn1:nn2, first_sgf:last_sgf)
942 : END DO
943 : END DO
944 : END DO
945 : END IF
946 : END IF
947 :
948 23261 : CALL timestop(handle)
949 :
950 23261 : END SUBROUTINE init_cphi_and_sphi
951 :
952 : ! **************************************************************************************************
953 : !> \brief ...
954 : !> \param gto_basis_set ...
955 : ! **************************************************************************************************
956 0 : SUBROUTINE init_norm_cgf_aux(gto_basis_set)
957 :
958 : ! Initialise the normalization factors of the contracted Cartesian Gaussian
959 : ! functions, if the Gaussian functions represent charge distributions.
960 :
961 : ! - Creation (07.12.2000,MK)
962 :
963 : TYPE(gto_basis_set_type), INTENT(INOUT) :: gto_basis_set
964 :
965 : INTEGER :: icgf, ico, ipgf, iset, ishell, jco, &
966 : jpgf, ll, lmax, lmin, lx, ly, lz, n, &
967 : npgfa
968 : REAL(KIND=dp) :: fnorm, gcca, gccb
969 0 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: ff
970 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: gaa
971 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: vv
972 0 : REAL(KIND=dp), DIMENSION(:), POINTER :: rpgfa, zeta
973 :
974 : ! -------------------------------------------------------------------------
975 :
976 0 : n = 0
977 0 : ll = 0
978 0 : DO iset = 1, gto_basis_set%nset
979 0 : n = MAX(n, gto_basis_set%npgf(iset)*ncoset(gto_basis_set%lmax(iset)))
980 0 : ll = MAX(ll, gto_basis_set%lmax(iset))
981 : END DO
982 :
983 0 : ALLOCATE (gaa(n, n))
984 0 : ALLOCATE (vv(ncoset(ll), ncoset(ll), ll + ll + 1))
985 0 : ALLOCATE (ff(0:ll + ll))
986 :
987 0 : DO iset = 1, gto_basis_set%nset
988 0 : lmax = gto_basis_set%lmax(iset)
989 0 : lmin = gto_basis_set%lmin(iset)
990 0 : n = ncoset(lmax)
991 0 : npgfa = gto_basis_set%npgf(iset)
992 0 : rpgfa => gto_basis_set%pgf_radius(1:npgfa, iset)
993 0 : zeta => gto_basis_set%zet(1:npgfa, iset)
994 : CALL coulomb2(lmax, npgfa, zeta, rpgfa, lmin, &
995 : lmax, npgfa, zeta, rpgfa, lmin, &
996 0 : [0.0_dp, 0.0_dp, 0.0_dp], 0.0_dp, gaa, vv, ff(0:))
997 0 : DO ishell = 1, gto_basis_set%nshell(iset)
998 0 : DO icgf = gto_basis_set%first_cgf(ishell, iset), &
999 0 : gto_basis_set%last_cgf(ishell, iset)
1000 0 : lx = gto_basis_set%lx(icgf)
1001 0 : ly = gto_basis_set%ly(icgf)
1002 0 : lz = gto_basis_set%lz(icgf)
1003 0 : ico = coset(lx, ly, lz)
1004 0 : fnorm = 0.0_dp
1005 0 : DO ipgf = 1, npgfa
1006 0 : gcca = gto_basis_set%gcc(ipgf, ishell, iset)
1007 0 : jco = coset(lx, ly, lz)
1008 0 : DO jpgf = 1, npgfa
1009 0 : gccb = gto_basis_set%gcc(jpgf, ishell, iset)
1010 0 : fnorm = fnorm + gcca*gccb*gaa(ico, jco)
1011 0 : jco = jco + n
1012 : END DO
1013 0 : ico = ico + n
1014 : END DO
1015 0 : gto_basis_set%norm_cgf(icgf) = 1.0_dp/SQRT(fnorm)
1016 : END DO
1017 : END DO
1018 : END DO
1019 :
1020 0 : DEALLOCATE (vv, ff)
1021 0 : DEALLOCATE (gaa)
1022 :
1023 0 : END SUBROUTINE init_norm_cgf_aux
1024 :
1025 : ! **************************************************************************************************
1026 : !> \brief ...
1027 : !> \param gto_basis_set ...
1028 : ! **************************************************************************************************
1029 6 : ELEMENTAL SUBROUTINE init_norm_cgf_aux_2(gto_basis_set)
1030 :
1031 : ! Initialise the normalization factors of the auxiliary Cartesian Gaussian
1032 : ! functions (Kim-Gordon polarization basis) Norm = 1.
1033 :
1034 : ! - Creation (07.12.2000,GT)
1035 :
1036 : TYPE(gto_basis_set_type), INTENT(INOUT) :: gto_basis_set
1037 :
1038 : INTEGER :: icgf, iset, ishell
1039 :
1040 92 : DO iset = 1, gto_basis_set%nset
1041 178 : DO ishell = 1, gto_basis_set%nshell(iset)
1042 396 : DO icgf = gto_basis_set%first_cgf(ishell, iset), &
1043 172 : gto_basis_set%last_cgf(ishell, iset)
1044 396 : gto_basis_set%norm_cgf(icgf) = 1.0_dp
1045 : END DO
1046 : END DO
1047 : END DO
1048 :
1049 6 : END SUBROUTINE init_norm_cgf_aux_2
1050 :
1051 : ! **************************************************************************************************
1052 : !> \brief Initialise the normalization factors of the contracted Cartesian Gaussian functions.
1053 : !> \param gto_basis_set ...
1054 : !> \author MK
1055 : ! **************************************************************************************************
1056 20747 : ELEMENTAL SUBROUTINE init_norm_cgf_orb(gto_basis_set)
1057 :
1058 : TYPE(gto_basis_set_type), INTENT(INOUT) :: gto_basis_set
1059 :
1060 : INTEGER :: icgf, ipgf, iset, ishell, jpgf, l, lx, &
1061 : ly, lz
1062 : REAL(KIND=dp) :: expzet, fnorm, gcca, gccb, prefac, zeta, &
1063 : zetb
1064 :
1065 73976 : DO iset = 1, gto_basis_set%nset
1066 162087 : DO ishell = 1, gto_basis_set%nshell(iset)
1067 :
1068 88111 : l = gto_basis_set%l(ishell, iset)
1069 :
1070 88111 : expzet = 0.5_dp*REAL(2*l + 3, dp)
1071 :
1072 88111 : fnorm = 0.0_dp
1073 :
1074 435902 : DO ipgf = 1, gto_basis_set%npgf(iset)
1075 347791 : gcca = gto_basis_set%gcc(ipgf, ishell, iset)
1076 347791 : zeta = gto_basis_set%zet(ipgf, iset)
1077 2525715 : DO jpgf = 1, gto_basis_set%npgf(iset)
1078 2089813 : gccb = gto_basis_set%gcc(jpgf, ishell, iset)
1079 2089813 : zetb = gto_basis_set%zet(jpgf, iset)
1080 2437604 : fnorm = fnorm + gcca*gccb/(zeta + zetb)**expzet
1081 : END DO
1082 : END DO
1083 :
1084 88111 : fnorm = 0.5_dp**l*pi**1.5_dp*fnorm
1085 :
1086 324179 : DO icgf = gto_basis_set%first_cgf(ishell, iset), &
1087 141340 : gto_basis_set%last_cgf(ishell, iset)
1088 236068 : lx = gto_basis_set%lx(icgf)
1089 236068 : ly = gto_basis_set%ly(icgf)
1090 236068 : lz = gto_basis_set%lz(icgf)
1091 236068 : prefac = dfac(2*lx - 1)*dfac(2*ly - 1)*dfac(2*lz - 1)
1092 324179 : gto_basis_set%norm_cgf(icgf) = 1.0_dp/SQRT(prefac*fnorm)
1093 : END DO
1094 :
1095 : END DO
1096 : END DO
1097 :
1098 20747 : END SUBROUTINE init_norm_cgf_orb
1099 :
1100 : ! **************************************************************************************************
1101 : !> \brief Initialise the normalization factors of the contracted Cartesian Gaussian
1102 : !> functions used for frozen density representation.
1103 : !> \param gto_basis_set ...
1104 : !> \author GT
1105 : ! **************************************************************************************************
1106 0 : ELEMENTAL SUBROUTINE init_norm_cgf_orb_den(gto_basis_set)
1107 :
1108 : TYPE(gto_basis_set_type), INTENT(INOUT) :: gto_basis_set
1109 :
1110 : INTEGER :: icgf, ipgf, iset, ishell, l
1111 : REAL(KIND=dp) :: expzet, gcca, prefac, zeta
1112 :
1113 0 : DO iset = 1, gto_basis_set%nset
1114 0 : DO ishell = 1, gto_basis_set%nshell(iset)
1115 0 : l = gto_basis_set%l(ishell, iset)
1116 0 : expzet = 0.5_dp*REAL(2*l + 3, dp)
1117 0 : prefac = (1.0_dp/pi)**1.5_dp
1118 0 : DO ipgf = 1, gto_basis_set%npgf(iset)
1119 0 : gcca = gto_basis_set%gcc(ipgf, ishell, iset)
1120 0 : zeta = gto_basis_set%zet(ipgf, iset)
1121 0 : gto_basis_set%gcc(ipgf, ishell, iset) = prefac*zeta**expzet*gcca
1122 : END DO
1123 0 : DO icgf = gto_basis_set%first_cgf(ishell, iset), &
1124 0 : gto_basis_set%last_cgf(ishell, iset)
1125 0 : gto_basis_set%norm_cgf(icgf) = 1.0_dp
1126 : END DO
1127 : END DO
1128 : END DO
1129 :
1130 0 : END SUBROUTINE init_norm_cgf_orb_den
1131 :
1132 : ! **************************************************************************************************
1133 : !> \brief Initialise a Gaussian-type orbital (GTO) basis set data set.
1134 : !> \param gto_basis_set ...
1135 : !> \author MK
1136 : ! **************************************************************************************************
1137 41494 : SUBROUTINE init_orb_basis_set(gto_basis_set)
1138 :
1139 : TYPE(gto_basis_set_type), POINTER :: gto_basis_set
1140 :
1141 : CHARACTER(len=*), PARAMETER :: routineN = 'init_orb_basis_set'
1142 :
1143 : INTEGER :: handle
1144 :
1145 : ! -------------------------------------------------------------------------
1146 :
1147 20747 : IF (.NOT. ASSOCIATED(gto_basis_set)) RETURN
1148 :
1149 20747 : CALL timeset(routineN, handle)
1150 :
1151 20747 : SELECT CASE (gto_basis_set%norm_type)
1152 : CASE (0)
1153 : ! No normalisation requested
1154 : CASE (1)
1155 0 : CALL init_norm_cgf_orb_den(gto_basis_set)
1156 : CASE (2)
1157 : ! Normalise the primitive Gaussian functions
1158 20423 : CALL normalise_gcc_orb(gto_basis_set)
1159 : ! Compute the normalization factors of the contracted Gaussian-type
1160 : ! functions
1161 20423 : CALL init_norm_cgf_orb(gto_basis_set)
1162 : CASE (3)
1163 324 : CALL init_norm_cgf_orb(gto_basis_set)
1164 : CASE DEFAULT
1165 20747 : CPABORT("Normalization method not specified")
1166 : END SELECT
1167 :
1168 : ! Initialise the transformation matrices "pgf" -> "cgf"
1169 :
1170 20747 : CALL init_cphi_and_sphi(gto_basis_set, .TRUE.)
1171 :
1172 20747 : CALL timestop(handle)
1173 :
1174 : END SUBROUTINE init_orb_basis_set
1175 :
1176 : ! **************************************************************************************************
1177 : !> \brief Normalise the primitive Cartesian Gaussian functions. The normalization
1178 : !> factor is included in the Gaussian contraction coefficients.
1179 : !> \param gto_basis_set ...
1180 : !> \author MK
1181 : ! **************************************************************************************************
1182 20423 : SUBROUTINE normalise_gcc_orb(gto_basis_set)
1183 :
1184 : TYPE(gto_basis_set_type), POINTER :: gto_basis_set
1185 :
1186 : INTEGER :: ipgf, iset, ishell, l
1187 : REAL(KIND=dp) :: expzet, gcca, prefac, zeta
1188 :
1189 72918 : DO iset = 1, gto_basis_set%nset
1190 160295 : DO ishell = 1, gto_basis_set%nshell(iset)
1191 87377 : l = gto_basis_set%l(ishell, iset)
1192 87377 : expzet = 0.25_dp*REAL(2*l + 3, dp)
1193 87377 : prefac = 2.0_dp**l*(2.0_dp/pi)**0.75_dp
1194 484009 : DO ipgf = 1, gto_basis_set%npgf(iset)
1195 344137 : gcca = gto_basis_set%gcc(ipgf, ishell, iset)
1196 344137 : zeta = gto_basis_set%zet(ipgf, iset)
1197 431514 : gto_basis_set%gcc(ipgf, ishell, iset) = prefac*zeta**expzet*gcca
1198 : END DO
1199 : END DO
1200 : END DO
1201 :
1202 20423 : END SUBROUTINE normalise_gcc_orb
1203 :
1204 : ! **************************************************************************************************
1205 : !> \brief Read a Gaussian-type orbital (GTO) basis set from the database file.
1206 : !> \param element_symbol ...
1207 : !> \param basis_set_name ...
1208 : !> \param gto_basis_set ...
1209 : !> \param para_env ...
1210 : !> \param dft_section ...
1211 : !> \author MK
1212 : ! **************************************************************************************************
1213 13660 : SUBROUTINE read_gto_basis_set1(element_symbol, basis_set_name, gto_basis_set, &
1214 : para_env, dft_section)
1215 :
1216 : CHARACTER(LEN=*), INTENT(IN) :: element_symbol, basis_set_name
1217 : TYPE(gto_basis_set_type), INTENT(INOUT) :: gto_basis_set
1218 : TYPE(mp_para_env_type), POINTER :: para_env
1219 : TYPE(section_vals_type), POINTER :: dft_section
1220 :
1221 : CHARACTER(LEN=240) :: line
1222 : CHARACTER(LEN=242) :: line2
1223 : CHARACTER(len=default_path_length) :: basis_set_file_name, tmp
1224 : CHARACTER(LEN=default_path_length), DIMENSION(:), &
1225 13660 : POINTER :: cbasis
1226 13660 : CHARACTER(LEN=LEN(basis_set_name)) :: bsname
1227 13660 : CHARACTER(LEN=LEN(basis_set_name)+2) :: bsname2
1228 13660 : CHARACTER(LEN=LEN(element_symbol)) :: symbol
1229 13660 : CHARACTER(LEN=LEN(element_symbol)+2) :: symbol2
1230 : INTEGER :: i, ibasis, ico, ipgf, irep, iset, ishell, lshell, m, maxco, maxl, maxpgf, &
1231 : maxshell, nbasis, ncgf, nmin, nset, nsgf, sort_method, strlen1, strlen2
1232 13660 : INTEGER, DIMENSION(:), POINTER :: lmax, lmin, npgf, nshell
1233 13660 : INTEGER, DIMENSION(:, :), POINTER :: l, n
1234 : LOGICAL :: basis_found, found, match
1235 13660 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: zet
1236 13660 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: gcc
1237 : TYPE(cp_parser_type) :: parser
1238 :
1239 13660 : line = ""
1240 13660 : line2 = ""
1241 13660 : symbol = ""
1242 13660 : symbol2 = ""
1243 13660 : bsname = ""
1244 13660 : bsname2 = ""
1245 :
1246 : nbasis = 1
1247 :
1248 13660 : gto_basis_set%name = basis_set_name
1249 13660 : gto_basis_set%aliases = basis_set_name
1250 : CALL section_vals_val_get(dft_section, "BASIS_SET_FILE_NAME", &
1251 13660 : n_rep_val=nbasis)
1252 40980 : ALLOCATE (cbasis(nbasis))
1253 29666 : DO ibasis = 1, nbasis
1254 : CALL section_vals_val_get(dft_section, "BASIS_SET_FILE_NAME", &
1255 16006 : i_rep_val=ibasis, c_val=cbasis(ibasis))
1256 16006 : basis_set_file_name = cbasis(ibasis)
1257 16006 : tmp = basis_set_file_name
1258 16006 : CALL uppercase(tmp)
1259 29666 : IF (INDEX(tmp, "MOLOPT") /= 0) CALL cite_reference(VandeVondele2007)
1260 : END DO
1261 :
1262 : ! Search for the requested basis set in the basis set file
1263 : ! until the basis set is found or the end of file is reached
1264 :
1265 13660 : basis_found = .FALSE.
1266 28402 : basis_loop: DO ibasis = 1, nbasis
1267 15924 : IF (basis_found) EXIT basis_loop
1268 14742 : basis_set_file_name = cbasis(ibasis)
1269 14742 : CALL parser_create(parser, basis_set_file_name, para_env=para_env)
1270 :
1271 14742 : bsname = basis_set_name
1272 14742 : symbol = element_symbol
1273 14742 : irep = 0
1274 :
1275 14742 : tmp = basis_set_name
1276 14742 : CALL uppercase(tmp)
1277 14742 : IF (INDEX(tmp, "MOLOPT") /= 0) CALL cite_reference(VandeVondele2007)
1278 :
1279 14742 : nset = 0
1280 14742 : maxshell = 0
1281 14742 : maxpgf = 0
1282 14742 : maxco = 0
1283 14742 : ncgf = 0
1284 14742 : nsgf = 0
1285 14742 : gto_basis_set%nset = nset
1286 14742 : gto_basis_set%ncgf = ncgf
1287 14742 : gto_basis_set%nsgf = nsgf
1288 14742 : CALL reallocate(gto_basis_set%lmax, 1, nset)
1289 14742 : CALL reallocate(gto_basis_set%lmin, 1, nset)
1290 14742 : CALL reallocate(gto_basis_set%npgf, 1, nset)
1291 14742 : CALL reallocate(gto_basis_set%nshell, 1, nset)
1292 14742 : CALL reallocate(gto_basis_set%n, 1, maxshell, 1, nset)
1293 14742 : CALL reallocate(gto_basis_set%l, 1, maxshell, 1, nset)
1294 14742 : CALL reallocate(gto_basis_set%zet, 1, maxpgf, 1, nset)
1295 14742 : CALL reallocate(gto_basis_set%gcc, 1, maxpgf, 1, maxshell, 1, nset)
1296 14742 : CALL reallocate(gto_basis_set%set_radius, 1, nset)
1297 14742 : CALL reallocate(gto_basis_set%pgf_radius, 1, maxpgf, 1, nset)
1298 14742 : CALL reallocate(gto_basis_set%first_cgf, 1, maxshell, 1, nset)
1299 14742 : CALL reallocate(gto_basis_set%first_sgf, 1, maxshell, 1, nset)
1300 14742 : CALL reallocate(gto_basis_set%last_cgf, 1, maxshell, 1, nset)
1301 14742 : CALL reallocate(gto_basis_set%last_sgf, 1, maxshell, 1, nset)
1302 14742 : CALL reallocate(gto_basis_set%ncgf_set, 1, nset)
1303 14742 : CALL reallocate(gto_basis_set%nsgf_set, 1, nset)
1304 14742 : CALL reallocate(gto_basis_set%cphi, 1, maxco, 1, ncgf)
1305 14742 : CALL reallocate(gto_basis_set%sphi, 1, maxco, 1, nsgf)
1306 14742 : CALL reallocate(gto_basis_set%scon, 1, maxco, 1, nsgf)
1307 14742 : CALL reallocate(gto_basis_set%ccon, 1, maxco, 1, ncgf)
1308 14742 : CALL reallocate(gto_basis_set%lx, 1, ncgf)
1309 14742 : CALL reallocate(gto_basis_set%ly, 1, ncgf)
1310 14742 : CALL reallocate(gto_basis_set%lz, 1, ncgf)
1311 14742 : CALL reallocate(gto_basis_set%m, 1, nsgf)
1312 14742 : CALL reallocate(gto_basis_set%norm_cgf, 1, ncgf)
1313 :
1314 14742 : IF (tmp /= "NONE") THEN
1315 : search_loop: DO
1316 :
1317 70651 : CALL parser_search_string(parser, TRIM(bsname), .TRUE., found, line)
1318 70651 : IF (found) THEN
1319 69569 : CALL uppercase(symbol)
1320 69569 : CALL uppercase(bsname)
1321 :
1322 69569 : match = .FALSE.
1323 69569 : CALL uppercase(line)
1324 : ! Check both the element symbol and the basis set name
1325 69569 : line2 = " "//line//" "
1326 69569 : symbol2 = " "//TRIM(symbol)//" "
1327 69569 : bsname2 = " "//TRIM(bsname)//" "
1328 69569 : strlen1 = LEN_TRIM(symbol2) + 1
1329 69569 : strlen2 = LEN_TRIM(bsname2) + 1
1330 :
1331 69569 : IF ((INDEX(line2, symbol2(:strlen1)) > 0) .AND. &
1332 13652 : (INDEX(line2, bsname2(:strlen2)) > 0)) match = .TRUE.
1333 69569 : IF (match) THEN
1334 : ! copy all names into aliases field
1335 13652 : i = INDEX(line2, symbol2(:strlen1))
1336 13652 : i = i + 1 + INDEX(line2(i + 1:), " ")
1337 13652 : gto_basis_set%aliases = line2(i:)
1338 :
1339 13652 : NULLIFY (gcc, l, lmax, lmin, n, npgf, nshell, zet)
1340 : ! Read the basis set information
1341 13652 : CALL parser_get_object(parser, nset, newline=.TRUE.)
1342 :
1343 13652 : CALL reallocate(npgf, 1, nset)
1344 13652 : CALL reallocate(nshell, 1, nset)
1345 13652 : CALL reallocate(lmax, 1, nset)
1346 13652 : CALL reallocate(lmin, 1, nset)
1347 13652 : CALL reallocate(n, 1, 1, 1, nset)
1348 :
1349 13652 : maxl = 0
1350 13652 : maxpgf = 0
1351 13652 : maxshell = 0
1352 :
1353 52410 : DO iset = 1, nset
1354 38758 : CALL parser_get_object(parser, n(1, iset), newline=.TRUE.)
1355 38758 : CALL parser_get_object(parser, lmin(iset))
1356 38758 : CALL parser_get_object(parser, lmax(iset))
1357 38758 : CALL parser_get_object(parser, npgf(iset))
1358 38758 : maxl = MAX(maxl, lmax(iset))
1359 38758 : IF (npgf(iset) > maxpgf) THEN
1360 13882 : maxpgf = npgf(iset)
1361 13882 : CALL reallocate(zet, 1, maxpgf, 1, nset)
1362 13882 : CALL reallocate(gcc, 1, maxpgf, 1, maxshell, 1, nset)
1363 : END IF
1364 38758 : nshell(iset) = 0
1365 87780 : DO lshell = lmin(iset), lmax(iset)
1366 49022 : nmin = n(1, iset) + lshell - lmin(iset)
1367 49022 : CALL parser_get_object(parser, ishell)
1368 49022 : nshell(iset) = nshell(iset) + ishell
1369 49022 : IF (nshell(iset) > maxshell) THEN
1370 21194 : maxshell = nshell(iset)
1371 21194 : CALL reallocate(n, 1, maxshell, 1, nset)
1372 21194 : CALL reallocate(l, 1, maxshell, 1, nset)
1373 21194 : CALL reallocate(gcc, 1, maxpgf, 1, maxshell, 1, nset)
1374 : END IF
1375 198447 : DO i = 1, ishell
1376 61645 : n(nshell(iset) - ishell + i, iset) = nmin + i - 1
1377 110667 : l(nshell(iset) - ishell + i, iset) = lshell
1378 : END DO
1379 : END DO
1380 134492 : DO ipgf = 1, npgf(iset)
1381 82082 : CALL parser_get_object(parser, zet(ipgf, iset), newline=.TRUE.)
1382 298369 : DO ishell = 1, nshell(iset)
1383 259611 : CALL parser_get_object(parser, gcc(ipgf, ishell, iset))
1384 : END DO
1385 : END DO
1386 : END DO
1387 :
1388 : ! Maximum angular momentum quantum number of the atomic kind
1389 :
1390 13652 : CALL init_orbital_pointers(maxl)
1391 :
1392 : ! Allocate the global variables
1393 :
1394 13652 : gto_basis_set%nset = nset
1395 13652 : CALL reallocate(gto_basis_set%lmax, 1, nset)
1396 13652 : CALL reallocate(gto_basis_set%lmin, 1, nset)
1397 13652 : CALL reallocate(gto_basis_set%npgf, 1, nset)
1398 13652 : CALL reallocate(gto_basis_set%nshell, 1, nset)
1399 13652 : CALL reallocate(gto_basis_set%n, 1, maxshell, 1, nset)
1400 13652 : CALL reallocate(gto_basis_set%l, 1, maxshell, 1, nset)
1401 13652 : CALL reallocate(gto_basis_set%zet, 1, maxpgf, 1, nset)
1402 13652 : CALL reallocate(gto_basis_set%gcc, 1, maxpgf, 1, maxshell, 1, nset)
1403 :
1404 : ! Copy the basis set information into the data structure
1405 :
1406 52410 : DO iset = 1, nset
1407 38758 : gto_basis_set%lmax(iset) = lmax(iset)
1408 38758 : gto_basis_set%lmin(iset) = lmin(iset)
1409 38758 : gto_basis_set%npgf(iset) = npgf(iset)
1410 38758 : gto_basis_set%nshell(iset) = nshell(iset)
1411 100403 : DO ishell = 1, nshell(iset)
1412 61645 : gto_basis_set%n(ishell, iset) = n(ishell, iset)
1413 61645 : gto_basis_set%l(ishell, iset) = l(ishell, iset)
1414 277932 : DO ipgf = 1, npgf(iset)
1415 239174 : gto_basis_set%gcc(ipgf, ishell, iset) = gcc(ipgf, ishell, iset)
1416 : END DO
1417 : END DO
1418 134492 : DO ipgf = 1, npgf(iset)
1419 120840 : gto_basis_set%zet(ipgf, iset) = zet(ipgf, iset)
1420 : END DO
1421 : END DO
1422 :
1423 : ! Initialise the depending atomic kind information
1424 :
1425 13652 : CALL reallocate(gto_basis_set%set_radius, 1, nset)
1426 13652 : CALL reallocate(gto_basis_set%pgf_radius, 1, maxpgf, 1, nset)
1427 13652 : CALL reallocate(gto_basis_set%first_cgf, 1, maxshell, 1, nset)
1428 13652 : CALL reallocate(gto_basis_set%first_sgf, 1, maxshell, 1, nset)
1429 13652 : CALL reallocate(gto_basis_set%last_cgf, 1, maxshell, 1, nset)
1430 13652 : CALL reallocate(gto_basis_set%last_sgf, 1, maxshell, 1, nset)
1431 13652 : CALL reallocate(gto_basis_set%ncgf_set, 1, nset)
1432 13652 : CALL reallocate(gto_basis_set%nsgf_set, 1, nset)
1433 :
1434 13652 : maxco = 0
1435 13652 : ncgf = 0
1436 13652 : nsgf = 0
1437 :
1438 52410 : DO iset = 1, nset
1439 38758 : gto_basis_set%ncgf_set(iset) = 0
1440 38758 : gto_basis_set%nsgf_set(iset) = 0
1441 100403 : DO ishell = 1, nshell(iset)
1442 61645 : lshell = gto_basis_set%l(ishell, iset)
1443 61645 : gto_basis_set%first_cgf(ishell, iset) = ncgf + 1
1444 61645 : ncgf = ncgf + nco(lshell)
1445 61645 : gto_basis_set%last_cgf(ishell, iset) = ncgf
1446 : gto_basis_set%ncgf_set(iset) = &
1447 61645 : gto_basis_set%ncgf_set(iset) + nco(lshell)
1448 61645 : gto_basis_set%first_sgf(ishell, iset) = nsgf + 1
1449 61645 : nsgf = nsgf + nso(lshell)
1450 61645 : gto_basis_set%last_sgf(ishell, iset) = nsgf
1451 : gto_basis_set%nsgf_set(iset) = &
1452 100403 : gto_basis_set%nsgf_set(iset) + nso(lshell)
1453 : END DO
1454 52410 : maxco = MAX(maxco, npgf(iset)*ncoset(lmax(iset)))
1455 : END DO
1456 :
1457 13652 : gto_basis_set%ncgf = ncgf
1458 13652 : gto_basis_set%nsgf = nsgf
1459 :
1460 13652 : CALL reallocate(gto_basis_set%cphi, 1, maxco, 1, ncgf)
1461 13652 : CALL reallocate(gto_basis_set%sphi, 1, maxco, 1, nsgf)
1462 13652 : CALL reallocate(gto_basis_set%scon, 1, maxco, 1, nsgf)
1463 13652 : CALL reallocate(gto_basis_set%ccon, 1, maxco, 1, ncgf)
1464 13652 : CALL reallocate(gto_basis_set%lx, 1, ncgf)
1465 13652 : CALL reallocate(gto_basis_set%ly, 1, ncgf)
1466 13652 : CALL reallocate(gto_basis_set%lz, 1, ncgf)
1467 13652 : CALL reallocate(gto_basis_set%m, 1, nsgf)
1468 13652 : CALL reallocate(gto_basis_set%norm_cgf, 1, ncgf)
1469 40956 : ALLOCATE (gto_basis_set%cgf_symbol(ncgf))
1470 :
1471 40956 : ALLOCATE (gto_basis_set%sgf_symbol(nsgf))
1472 :
1473 13652 : ncgf = 0
1474 13652 : nsgf = 0
1475 :
1476 52410 : DO iset = 1, nset
1477 114055 : DO ishell = 1, nshell(iset)
1478 61645 : lshell = gto_basis_set%l(ishell, iset)
1479 226671 : DO ico = ncoset(lshell - 1) + 1, ncoset(lshell)
1480 165026 : ncgf = ncgf + 1
1481 165026 : gto_basis_set%lx(ncgf) = indco(1, ico)
1482 165026 : gto_basis_set%ly(ncgf) = indco(2, ico)
1483 165026 : gto_basis_set%lz(ncgf) = indco(3, ico)
1484 : gto_basis_set%cgf_symbol(ncgf) = &
1485 : cgf_symbol(n(ishell, iset), [gto_basis_set%lx(ncgf), &
1486 : gto_basis_set%ly(ncgf), &
1487 721749 : gto_basis_set%lz(ncgf)])
1488 : END DO
1489 250166 : DO m = -lshell, lshell
1490 149763 : nsgf = nsgf + 1
1491 149763 : gto_basis_set%m(nsgf) = m
1492 : gto_basis_set%sgf_symbol(nsgf) = &
1493 211408 : sgf_symbol(n(ishell, iset), lshell, m)
1494 : END DO
1495 : END DO
1496 : END DO
1497 :
1498 13652 : DEALLOCATE (gcc, l, lmax, lmin, n, npgf, nshell, zet)
1499 :
1500 13652 : basis_found = .TRUE.
1501 13652 : EXIT search_loop
1502 : END IF
1503 : ELSE
1504 : EXIT search_loop
1505 : END IF
1506 : END DO search_loop
1507 : ELSE
1508 8 : match = .FALSE.
1509 16 : ALLOCATE (gto_basis_set%cgf_symbol(ncgf))
1510 16 : ALLOCATE (gto_basis_set%sgf_symbol(nsgf))
1511 : END IF
1512 :
1513 43144 : CALL parser_release(parser)
1514 :
1515 : END DO basis_loop
1516 :
1517 13660 : IF (tmp /= "NONE") THEN
1518 13652 : IF (.NOT. basis_found) THEN
1519 0 : basis_set_file_name = ""
1520 0 : DO ibasis = 1, nbasis
1521 0 : basis_set_file_name = TRIM(basis_set_file_name)//"<"//TRIM(cbasis(ibasis))//"> "
1522 : END DO
1523 : CALL cp_abort(__LOCATION__, &
1524 : "The requested basis set <"//TRIM(bsname)// &
1525 : "> for element <"//TRIM(symbol)//"> was not "// &
1526 : "found in the basis set files "// &
1527 0 : TRIM(basis_set_file_name))
1528 : END IF
1529 : END IF
1530 13660 : DEALLOCATE (cbasis)
1531 :
1532 13660 : CALL section_vals_val_get(dft_section, "SORT_BASIS", i_val=sort_method)
1533 13660 : CALL sort_gto_basis_set(gto_basis_set, sort_method)
1534 :
1535 68300 : END SUBROUTINE read_gto_basis_set1
1536 :
1537 : ! **************************************************************************************************
1538 : !> \brief Read a Gaussian-type orbital (GTO) basis set from the database file.
1539 : !> \param element_symbol ...
1540 : !> \param basis_type ...
1541 : !> \param gto_basis_set ...
1542 : !> \param basis_section ...
1543 : !> \param irep ...
1544 : !> \param dft_section ...
1545 : !> \author MK
1546 : ! **************************************************************************************************
1547 170 : SUBROUTINE read_gto_basis_set2(element_symbol, basis_type, gto_basis_set, &
1548 : basis_section, irep, dft_section)
1549 :
1550 : CHARACTER(LEN=*), INTENT(IN) :: element_symbol
1551 : CHARACTER(LEN=*), INTENT(INOUT) :: basis_type
1552 : TYPE(gto_basis_set_type), INTENT(INOUT) :: gto_basis_set
1553 : TYPE(section_vals_type), OPTIONAL, POINTER :: basis_section
1554 : INTEGER :: irep
1555 : TYPE(section_vals_type), OPTIONAL, POINTER :: dft_section
1556 :
1557 : CHARACTER(len=20*default_string_length) :: line_att
1558 : CHARACTER(LEN=240) :: line
1559 : CHARACTER(LEN=242) :: line2
1560 : CHARACTER(LEN=default_path_length) :: bsname, bsname2
1561 170 : CHARACTER(LEN=LEN(element_symbol)) :: symbol
1562 170 : CHARACTER(LEN=LEN(element_symbol)+2) :: symbol2
1563 : INTEGER :: i, ico, ipgf, iset, ishell, lshell, m, &
1564 : maxco, maxl, maxpgf, maxshell, ncgf, &
1565 : nmin, nset, nsgf, sort_method
1566 170 : INTEGER, DIMENSION(:), POINTER :: lmax, lmin, npgf, nshell
1567 170 : INTEGER, DIMENSION(:, :), POINTER :: l, n
1568 : LOGICAL :: is_ok
1569 170 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: zet
1570 170 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: gcc
1571 : TYPE(cp_sll_val_type), POINTER :: list
1572 : TYPE(val_type), POINTER :: val
1573 :
1574 170 : line = ""
1575 170 : line2 = ""
1576 170 : symbol = ""
1577 170 : symbol2 = ""
1578 : bsname = ""
1579 170 : bsname2 = ""
1580 :
1581 170 : gto_basis_set%name = " "
1582 170 : gto_basis_set%aliases = " "
1583 :
1584 170 : bsname = " "
1585 170 : symbol = element_symbol
1586 :
1587 170 : nset = 0
1588 170 : maxshell = 0
1589 170 : maxpgf = 0
1590 170 : maxco = 0
1591 170 : ncgf = 0
1592 170 : nsgf = 0
1593 170 : gto_basis_set%nset = nset
1594 170 : gto_basis_set%ncgf = ncgf
1595 170 : gto_basis_set%nsgf = nsgf
1596 170 : CALL reallocate(gto_basis_set%lmax, 1, nset)
1597 170 : CALL reallocate(gto_basis_set%lmin, 1, nset)
1598 170 : CALL reallocate(gto_basis_set%npgf, 1, nset)
1599 170 : CALL reallocate(gto_basis_set%nshell, 1, nset)
1600 170 : CALL reallocate(gto_basis_set%n, 1, maxshell, 1, nset)
1601 170 : CALL reallocate(gto_basis_set%l, 1, maxshell, 1, nset)
1602 170 : CALL reallocate(gto_basis_set%zet, 1, maxpgf, 1, nset)
1603 170 : CALL reallocate(gto_basis_set%gcc, 1, maxpgf, 1, maxshell, 1, nset)
1604 170 : CALL reallocate(gto_basis_set%set_radius, 1, nset)
1605 170 : CALL reallocate(gto_basis_set%pgf_radius, 1, maxpgf, 1, nset)
1606 170 : CALL reallocate(gto_basis_set%first_cgf, 1, maxshell, 1, nset)
1607 170 : CALL reallocate(gto_basis_set%first_sgf, 1, maxshell, 1, nset)
1608 170 : CALL reallocate(gto_basis_set%last_cgf, 1, maxshell, 1, nset)
1609 170 : CALL reallocate(gto_basis_set%last_sgf, 1, maxshell, 1, nset)
1610 170 : CALL reallocate(gto_basis_set%ncgf_set, 1, nset)
1611 170 : CALL reallocate(gto_basis_set%nsgf_set, 1, nset)
1612 170 : CALL reallocate(gto_basis_set%cphi, 1, maxco, 1, ncgf)
1613 170 : CALL reallocate(gto_basis_set%sphi, 1, maxco, 1, nsgf)
1614 170 : CALL reallocate(gto_basis_set%scon, 1, maxco, 1, nsgf)
1615 170 : CALL reallocate(gto_basis_set%ccon, 1, maxco, 1, ncgf)
1616 170 : CALL reallocate(gto_basis_set%lx, 1, ncgf)
1617 170 : CALL reallocate(gto_basis_set%ly, 1, ncgf)
1618 170 : CALL reallocate(gto_basis_set%lz, 1, ncgf)
1619 170 : CALL reallocate(gto_basis_set%m, 1, nsgf)
1620 170 : CALL reallocate(gto_basis_set%norm_cgf, 1, ncgf)
1621 :
1622 170 : basis_type = ""
1623 170 : CALL section_vals_val_get(basis_section, "_SECTION_PARAMETERS_", i_rep_section=irep, c_val=basis_type)
1624 170 : IF (basis_type == "Orbital") basis_type = "ORB"
1625 :
1626 170 : NULLIFY (list, val)
1627 170 : CALL section_vals_list_get(basis_section, "_DEFAULT_KEYWORD_", i_rep_section=irep, list=list)
1628 170 : CALL uppercase(symbol)
1629 170 : CALL uppercase(bsname)
1630 :
1631 170 : NULLIFY (gcc, l, lmax, lmin, n, npgf, nshell, zet)
1632 : ! Read the basis set information
1633 170 : is_ok = cp_sll_val_next(list, val)
1634 170 : IF (.NOT. is_ok) CPABORT("Error reading the Basis set from input file!")
1635 170 : CALL val_get(val, c_val=line_att)
1636 170 : READ (line_att, *) nset
1637 :
1638 170 : CALL reallocate(npgf, 1, nset)
1639 170 : CALL reallocate(nshell, 1, nset)
1640 170 : CALL reallocate(lmax, 1, nset)
1641 170 : CALL reallocate(lmin, 1, nset)
1642 170 : CALL reallocate(n, 1, 1, 1, nset)
1643 :
1644 170 : maxl = 0
1645 170 : maxpgf = 0
1646 170 : maxshell = 0
1647 :
1648 488 : DO iset = 1, nset
1649 318 : is_ok = cp_sll_val_next(list, val)
1650 318 : IF (.NOT. is_ok) CPABORT("Error reading the Basis set from input file!")
1651 318 : CALL val_get(val, c_val=line_att)
1652 318 : READ (line_att, *) n(1, iset)
1653 318 : CALL remove_word(line_att)
1654 318 : READ (line_att, *) lmin(iset)
1655 318 : CALL remove_word(line_att)
1656 318 : READ (line_att, *) lmax(iset)
1657 318 : CALL remove_word(line_att)
1658 318 : READ (line_att, *) npgf(iset)
1659 318 : CALL remove_word(line_att)
1660 318 : maxl = MAX(maxl, lmax(iset))
1661 318 : IF (npgf(iset) > maxpgf) THEN
1662 170 : maxpgf = npgf(iset)
1663 170 : CALL reallocate(zet, 1, maxpgf, 1, nset)
1664 170 : CALL reallocate(gcc, 1, maxpgf, 1, maxshell, 1, nset)
1665 : END IF
1666 318 : nshell(iset) = 0
1667 1066 : DO lshell = lmin(iset), lmax(iset)
1668 748 : nmin = n(1, iset) + lshell - lmin(iset)
1669 748 : READ (line_att, *) ishell
1670 748 : CALL remove_word(line_att)
1671 748 : nshell(iset) = nshell(iset) + ishell
1672 748 : IF (nshell(iset) > maxshell) THEN
1673 330 : maxshell = nshell(iset)
1674 330 : CALL reallocate(n, 1, maxshell, 1, nset)
1675 330 : CALL reallocate(l, 1, maxshell, 1, nset)
1676 330 : CALL reallocate(gcc, 1, maxpgf, 1, maxshell, 1, nset)
1677 : END IF
1678 2102 : DO i = 1, ishell
1679 1036 : n(nshell(iset) - ishell + i, iset) = nmin + i - 1
1680 1784 : l(nshell(iset) - ishell + i, iset) = lshell
1681 : END DO
1682 : END DO
1683 318 : IF (LEN_TRIM(line_att) /= 0) THEN
1684 0 : CPABORT("Error reading the Basis from input file!")
1685 : END IF
1686 1280 : DO ipgf = 1, npgf(iset)
1687 792 : is_ok = cp_sll_val_next(list, val)
1688 792 : IF (.NOT. is_ok) CPABORT("Error reading the Basis set from input file!")
1689 792 : CALL val_get(val, c_val=line_att)
1690 5380 : READ (line_att, *) zet(ipgf, iset), (gcc(ipgf, ishell, iset), ishell=1, nshell(iset))
1691 : END DO
1692 : END DO
1693 :
1694 : ! Maximum angular momentum quantum number of the atomic kind
1695 :
1696 170 : CALL init_orbital_pointers(maxl)
1697 :
1698 : ! Allocate the global variables
1699 :
1700 170 : gto_basis_set%nset = nset
1701 170 : CALL reallocate(gto_basis_set%lmax, 1, nset)
1702 170 : CALL reallocate(gto_basis_set%lmin, 1, nset)
1703 170 : CALL reallocate(gto_basis_set%npgf, 1, nset)
1704 170 : CALL reallocate(gto_basis_set%nshell, 1, nset)
1705 170 : CALL reallocate(gto_basis_set%n, 1, maxshell, 1, nset)
1706 170 : CALL reallocate(gto_basis_set%l, 1, maxshell, 1, nset)
1707 170 : CALL reallocate(gto_basis_set%zet, 1, maxpgf, 1, nset)
1708 170 : CALL reallocate(gto_basis_set%gcc, 1, maxpgf, 1, maxshell, 1, nset)
1709 :
1710 : ! Copy the basis set information into the data structure
1711 :
1712 488 : DO iset = 1, nset
1713 318 : gto_basis_set%lmax(iset) = lmax(iset)
1714 318 : gto_basis_set%lmin(iset) = lmin(iset)
1715 318 : gto_basis_set%npgf(iset) = npgf(iset)
1716 318 : gto_basis_set%nshell(iset) = nshell(iset)
1717 1354 : DO ishell = 1, nshell(iset)
1718 1036 : gto_basis_set%n(ishell, iset) = n(ishell, iset)
1719 1036 : gto_basis_set%l(ishell, iset) = l(ishell, iset)
1720 5624 : DO ipgf = 1, npgf(iset)
1721 5306 : gto_basis_set%gcc(ipgf, ishell, iset) = gcc(ipgf, ishell, iset)
1722 : END DO
1723 : END DO
1724 1280 : DO ipgf = 1, npgf(iset)
1725 1110 : gto_basis_set%zet(ipgf, iset) = zet(ipgf, iset)
1726 : END DO
1727 : END DO
1728 :
1729 : ! Initialise the depending atomic kind information
1730 :
1731 170 : CALL reallocate(gto_basis_set%set_radius, 1, nset)
1732 170 : CALL reallocate(gto_basis_set%pgf_radius, 1, maxpgf, 1, nset)
1733 170 : CALL reallocate(gto_basis_set%first_cgf, 1, maxshell, 1, nset)
1734 170 : CALL reallocate(gto_basis_set%first_sgf, 1, maxshell, 1, nset)
1735 170 : CALL reallocate(gto_basis_set%last_cgf, 1, maxshell, 1, nset)
1736 170 : CALL reallocate(gto_basis_set%last_sgf, 1, maxshell, 1, nset)
1737 170 : CALL reallocate(gto_basis_set%ncgf_set, 1, nset)
1738 170 : CALL reallocate(gto_basis_set%nsgf_set, 1, nset)
1739 :
1740 170 : maxco = 0
1741 170 : ncgf = 0
1742 170 : nsgf = 0
1743 :
1744 488 : DO iset = 1, nset
1745 318 : gto_basis_set%ncgf_set(iset) = 0
1746 318 : gto_basis_set%nsgf_set(iset) = 0
1747 1354 : DO ishell = 1, nshell(iset)
1748 1036 : lshell = gto_basis_set%l(ishell, iset)
1749 1036 : gto_basis_set%first_cgf(ishell, iset) = ncgf + 1
1750 1036 : ncgf = ncgf + nco(lshell)
1751 1036 : gto_basis_set%last_cgf(ishell, iset) = ncgf
1752 : gto_basis_set%ncgf_set(iset) = &
1753 1036 : gto_basis_set%ncgf_set(iset) + nco(lshell)
1754 1036 : gto_basis_set%first_sgf(ishell, iset) = nsgf + 1
1755 1036 : nsgf = nsgf + nso(lshell)
1756 1036 : gto_basis_set%last_sgf(ishell, iset) = nsgf
1757 : gto_basis_set%nsgf_set(iset) = &
1758 1354 : gto_basis_set%nsgf_set(iset) + nso(lshell)
1759 : END DO
1760 488 : maxco = MAX(maxco, npgf(iset)*ncoset(lmax(iset)))
1761 : END DO
1762 :
1763 170 : gto_basis_set%ncgf = ncgf
1764 170 : gto_basis_set%nsgf = nsgf
1765 :
1766 170 : CALL reallocate(gto_basis_set%cphi, 1, maxco, 1, ncgf)
1767 170 : CALL reallocate(gto_basis_set%sphi, 1, maxco, 1, nsgf)
1768 170 : CALL reallocate(gto_basis_set%scon, 1, maxco, 1, nsgf)
1769 170 : CALL reallocate(gto_basis_set%ccon, 1, maxco, 1, ncgf)
1770 170 : CALL reallocate(gto_basis_set%lx, 1, ncgf)
1771 170 : CALL reallocate(gto_basis_set%ly, 1, ncgf)
1772 170 : CALL reallocate(gto_basis_set%lz, 1, ncgf)
1773 170 : CALL reallocate(gto_basis_set%m, 1, nsgf)
1774 170 : CALL reallocate(gto_basis_set%norm_cgf, 1, ncgf)
1775 510 : ALLOCATE (gto_basis_set%cgf_symbol(ncgf))
1776 :
1777 510 : ALLOCATE (gto_basis_set%sgf_symbol(nsgf))
1778 :
1779 170 : ncgf = 0
1780 170 : nsgf = 0
1781 :
1782 488 : DO iset = 1, nset
1783 1524 : DO ishell = 1, nshell(iset)
1784 1036 : lshell = gto_basis_set%l(ishell, iset)
1785 5024 : DO ico = ncoset(lshell - 1) + 1, ncoset(lshell)
1786 3988 : ncgf = ncgf + 1
1787 3988 : gto_basis_set%lx(ncgf) = indco(1, ico)
1788 3988 : gto_basis_set%ly(ncgf) = indco(2, ico)
1789 3988 : gto_basis_set%lz(ncgf) = indco(3, ico)
1790 : gto_basis_set%cgf_symbol(ncgf) = &
1791 : cgf_symbol(n(ishell, iset), [gto_basis_set%lx(ncgf), &
1792 : gto_basis_set%ly(ncgf), &
1793 16988 : gto_basis_set%lz(ncgf)])
1794 : END DO
1795 4582 : DO m = -lshell, lshell
1796 3228 : nsgf = nsgf + 1
1797 3228 : gto_basis_set%m(nsgf) = m
1798 : gto_basis_set%sgf_symbol(nsgf) = &
1799 4264 : sgf_symbol(n(ishell, iset), lshell, m)
1800 : END DO
1801 : END DO
1802 : END DO
1803 :
1804 170 : DEALLOCATE (gcc, l, lmax, lmin, n, npgf, nshell, zet)
1805 :
1806 170 : IF (PRESENT(dft_section)) THEN
1807 158 : CALL section_vals_val_get(dft_section, "SORT_BASIS", i_val=sort_method)
1808 158 : CALL sort_gto_basis_set(gto_basis_set, sort_method)
1809 : END IF
1810 :
1811 170 : END SUBROUTINE read_gto_basis_set2
1812 :
1813 : ! **************************************************************************************************
1814 : !> \brief Set the components of Gaussian-type orbital (GTO) basis set data set.
1815 : !> \param gto_basis_set ...
1816 : !> \param name ...
1817 : !> \param aliases ...
1818 : !> \param norm_type ...
1819 : !> \param kind_radius ...
1820 : !> \param ncgf ...
1821 : !> \param nset ...
1822 : !> \param nsgf ...
1823 : !> \param cgf_symbol ...
1824 : !> \param sgf_symbol ...
1825 : !> \param norm_cgf ...
1826 : !> \param set_radius ...
1827 : !> \param lmax ...
1828 : !> \param lmin ...
1829 : !> \param lx ...
1830 : !> \param ly ...
1831 : !> \param lz ...
1832 : !> \param m ...
1833 : !> \param ncgf_set ...
1834 : !> \param npgf ...
1835 : !> \param nsgf_set ...
1836 : !> \param nshell ...
1837 : !> \param cphi ...
1838 : !> \param pgf_radius ...
1839 : !> \param sphi ...
1840 : !> \param scon ...
1841 : !> \param zet ...
1842 : !> \param first_cgf ...
1843 : !> \param first_sgf ...
1844 : !> \param l ...
1845 : !> \param last_cgf ...
1846 : !> \param last_sgf ...
1847 : !> \param n ...
1848 : !> \param gcc ...
1849 : !> \param short_kind_radius ...
1850 : !> \param ccon ...
1851 : !> \author MK
1852 : ! **************************************************************************************************
1853 43112 : SUBROUTINE set_gto_basis_set(gto_basis_set, name, aliases, norm_type, kind_radius, ncgf, &
1854 : nset, nsgf, cgf_symbol, sgf_symbol, norm_cgf, set_radius, lmax, &
1855 : lmin, lx, ly, lz, m, ncgf_set, npgf, nsgf_set, nshell, &
1856 : cphi, pgf_radius, sphi, scon, zet, first_cgf, first_sgf, l, &
1857 : last_cgf, last_sgf, n, gcc, short_kind_radius, ccon)
1858 :
1859 : TYPE(gto_basis_set_type), INTENT(INOUT) :: gto_basis_set
1860 : CHARACTER(LEN=default_string_length), INTENT(IN), &
1861 : OPTIONAL :: name, aliases
1862 : INTEGER, INTENT(IN), OPTIONAL :: norm_type
1863 : REAL(KIND=dp), INTENT(IN), OPTIONAL :: kind_radius
1864 : INTEGER, INTENT(IN), OPTIONAL :: ncgf, nset, nsgf
1865 : CHARACTER(LEN=12), DIMENSION(:), OPTIONAL, POINTER :: cgf_symbol
1866 : CHARACTER(LEN=6), DIMENSION(:), OPTIONAL, POINTER :: sgf_symbol
1867 : REAL(KIND=dp), DIMENSION(:), OPTIONAL, POINTER :: norm_cgf, set_radius
1868 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: lmax, lmin, lx, ly, lz, m, ncgf_set, &
1869 : npgf, nsgf_set, nshell
1870 : REAL(KIND=dp), DIMENSION(:, :), OPTIONAL, POINTER :: cphi, pgf_radius, sphi, scon, zet
1871 : INTEGER, DIMENSION(:, :), OPTIONAL, POINTER :: first_cgf, first_sgf, l, last_cgf, &
1872 : last_sgf, n
1873 : REAL(KIND=dp), DIMENSION(:, :, :), OPTIONAL, &
1874 : POINTER :: gcc
1875 : REAL(KIND=dp), INTENT(IN), OPTIONAL :: short_kind_radius
1876 : REAL(KIND=dp), DIMENSION(:, :), OPTIONAL, POINTER :: ccon
1877 :
1878 43112 : IF (PRESENT(name)) gto_basis_set%name = name
1879 43112 : IF (PRESENT(aliases)) gto_basis_set%aliases = aliases
1880 43112 : IF (PRESENT(norm_type)) gto_basis_set%norm_type = norm_type
1881 43112 : IF (PRESENT(kind_radius)) gto_basis_set%kind_radius = kind_radius
1882 43112 : IF (PRESENT(short_kind_radius)) gto_basis_set%short_kind_radius = short_kind_radius
1883 43112 : IF (PRESENT(ncgf)) gto_basis_set%ncgf = ncgf
1884 43112 : IF (PRESENT(nset)) gto_basis_set%nset = nset
1885 43112 : IF (PRESENT(nsgf)) gto_basis_set%nsgf = nsgf
1886 43112 : IF (PRESENT(cgf_symbol)) gto_basis_set%cgf_symbol(:) = cgf_symbol(:)
1887 43112 : IF (PRESENT(sgf_symbol)) gto_basis_set%sgf_symbol(:) = sgf_symbol(:)
1888 43112 : IF (PRESENT(norm_cgf)) gto_basis_set%norm_cgf(:) = norm_cgf(:)
1889 186644 : IF (PRESENT(set_radius)) gto_basis_set%set_radius(:) = set_radius(:)
1890 43112 : IF (PRESENT(lmax)) gto_basis_set%lmax(:) = lmax(:)
1891 43112 : IF (PRESENT(lmin)) gto_basis_set%lmin(:) = lmin(:)
1892 43112 : IF (PRESENT(lx)) gto_basis_set%lx(:) = lx(:)
1893 43112 : IF (PRESENT(ly)) gto_basis_set%ly(:) = ly(:)
1894 43112 : IF (PRESENT(lz)) gto_basis_set%lz(:) = lz(:)
1895 43112 : IF (PRESENT(m)) gto_basis_set%m(:) = m(:)
1896 43112 : IF (PRESENT(ncgf_set)) gto_basis_set%ncgf_set(:) = ncgf_set(:)
1897 43112 : IF (PRESENT(npgf)) gto_basis_set%npgf(:) = npgf(:)
1898 43112 : IF (PRESENT(nsgf_set)) gto_basis_set%nsgf_set(:) = nsgf_set(:)
1899 43112 : IF (PRESENT(nshell)) gto_basis_set%nshell(:) = nshell(:)
1900 43112 : IF (PRESENT(cphi)) gto_basis_set%cphi(:, :) = cphi(:, :)
1901 577260 : IF (PRESENT(pgf_radius)) gto_basis_set%pgf_radius(:, :) = pgf_radius(:, :)
1902 43112 : IF (PRESENT(sphi)) gto_basis_set%sphi(:, :) = sphi(:, :)
1903 43112 : IF (PRESENT(scon)) gto_basis_set%scon(:, :) = scon(:, :)
1904 43112 : IF (PRESENT(ccon)) gto_basis_set%ccon(:, :) = ccon(:, :)
1905 43112 : IF (PRESENT(zet)) gto_basis_set%zet(:, :) = zet(:, :)
1906 43112 : IF (PRESENT(first_cgf)) gto_basis_set%first_cgf(:, :) = first_cgf(:, :)
1907 43112 : IF (PRESENT(first_sgf)) gto_basis_set%first_sgf(:, :) = first_sgf(:, :)
1908 43112 : IF (PRESENT(l)) l(:, :) = gto_basis_set%l(:, :)
1909 43112 : IF (PRESENT(last_cgf)) gto_basis_set%last_cgf(:, :) = last_cgf(:, :)
1910 43112 : IF (PRESENT(last_sgf)) gto_basis_set%last_sgf(:, :) = last_sgf(:, :)
1911 43112 : IF (PRESENT(n)) gto_basis_set%n(:, :) = n(:, :)
1912 43112 : IF (PRESENT(gcc)) gto_basis_set%gcc(:, :, :) = gcc(:, :, :)
1913 :
1914 43112 : END SUBROUTINE set_gto_basis_set
1915 :
1916 : ! **************************************************************************************************
1917 : !> \brief Write a Gaussian-type orbital (GTO) basis set data set to the output unit.
1918 : !> \param gto_basis_set ...
1919 : !> \param output_unit ...
1920 : !> \param header ...
1921 : !> \author MK
1922 : ! **************************************************************************************************
1923 142 : SUBROUTINE write_gto_basis_set(gto_basis_set, output_unit, header)
1924 :
1925 : TYPE(gto_basis_set_type), INTENT(IN) :: gto_basis_set
1926 : INTEGER, INTENT(in) :: output_unit
1927 : CHARACTER(len=*), OPTIONAL :: header
1928 :
1929 : INTEGER :: ipgf, iset, ishell
1930 :
1931 142 : IF (output_unit > 0) THEN
1932 :
1933 142 : IF (PRESENT(header)) THEN
1934 : WRITE (UNIT=output_unit, FMT="(/,T6,A,T41,A40)") &
1935 142 : TRIM(header), TRIM(gto_basis_set%name)
1936 : END IF
1937 :
1938 : WRITE (UNIT=output_unit, FMT="(/,(T8,A,T71,I10))") &
1939 142 : "Number of orbital shell sets: ", &
1940 142 : gto_basis_set%nset, &
1941 142 : "Number of orbital shells: ", &
1942 496 : SUM(gto_basis_set%nshell(:)), &
1943 142 : "Number of primitive Cartesian functions: ", &
1944 496 : SUM(gto_basis_set%npgf(:)), &
1945 142 : "Number of Cartesian basis functions: ", &
1946 142 : gto_basis_set%ncgf, &
1947 142 : "Number of spherical basis functions: ", &
1948 142 : gto_basis_set%nsgf, &
1949 142 : "Norm type: ", &
1950 284 : gto_basis_set%norm_type
1951 :
1952 : WRITE (UNIT=output_unit, FMT="(/,T6,A,T41,A40,/,/,T25,A)") &
1953 142 : "GTO basis set information for", TRIM(gto_basis_set%name), &
1954 284 : "Set Shell n l Exponent Coefficient"
1955 :
1956 496 : DO iset = 1, gto_basis_set%nset
1957 354 : WRITE (UNIT=output_unit, FMT="(A)") ""
1958 998 : DO ishell = 1, gto_basis_set%nshell(iset)
1959 : WRITE (UNIT=output_unit, &
1960 : FMT="(T25,I3,4X,I4,4X,I2,2X,I2,(T51,2F15.6))") &
1961 502 : iset, ishell, &
1962 502 : gto_basis_set%n(ishell, iset), &
1963 502 : gto_basis_set%l(ishell, iset), &
1964 1896 : (gto_basis_set%zet(ipgf, iset), &
1965 2398 : gto_basis_set%gcc(ipgf, ishell, iset), &
1966 3756 : ipgf=1, gto_basis_set%npgf(iset))
1967 : END DO
1968 : END DO
1969 :
1970 : END IF
1971 :
1972 142 : END SUBROUTINE write_gto_basis_set
1973 :
1974 : ! **************************************************************************************************
1975 :
1976 : ! **************************************************************************************************
1977 : !> \brief Write a Gaussian-type orbital (GTO) basis set data set to the output unit.
1978 : !> \param orb_basis_set ...
1979 : !> \param output_unit ...
1980 : !> \param header ...
1981 : !> \author MK
1982 : ! **************************************************************************************************
1983 5228 : SUBROUTINE write_orb_basis_set(orb_basis_set, output_unit, header)
1984 :
1985 : TYPE(gto_basis_set_type), INTENT(IN) :: orb_basis_set
1986 : INTEGER, INTENT(in) :: output_unit
1987 : CHARACTER(len=*), OPTIONAL :: header
1988 :
1989 : INTEGER :: icgf, ico, ipgf, iset, ishell
1990 :
1991 5228 : IF (output_unit > 0) THEN
1992 5228 : IF (PRESENT(header)) THEN
1993 : WRITE (UNIT=output_unit, FMT="(/,T6,A,T41,A40)") &
1994 5228 : TRIM(header), TRIM(orb_basis_set%name)
1995 : END IF
1996 :
1997 : WRITE (UNIT=output_unit, FMT="(/,(T8,A,T71,I10))") &
1998 5228 : "Number of orbital shell sets: ", &
1999 5228 : orb_basis_set%nset, &
2000 5228 : "Number of orbital shells: ", &
2001 20338 : SUM(orb_basis_set%nshell(:)), &
2002 5228 : "Number of primitive Cartesian functions: ", &
2003 20338 : SUM(orb_basis_set%npgf(:)), &
2004 5228 : "Number of Cartesian basis functions: ", &
2005 5228 : orb_basis_set%ncgf, &
2006 5228 : "Number of spherical basis functions: ", &
2007 5228 : orb_basis_set%nsgf, &
2008 5228 : "Norm type: ", &
2009 10456 : orb_basis_set%norm_type
2010 :
2011 : WRITE (UNIT=output_unit, FMT="(/,T8,A,/,/,T25,A)") &
2012 5228 : "Normalised Cartesian orbitals:", &
2013 10456 : "Set Shell Orbital Exponent Coefficient"
2014 :
2015 5228 : icgf = 0
2016 :
2017 20338 : DO iset = 1, orb_basis_set%nset
2018 42716 : DO ishell = 1, orb_basis_set%nshell(iset)
2019 22378 : WRITE (UNIT=output_unit, FMT="(A)") ""
2020 97817 : DO ico = 1, nco(orb_basis_set%l(ishell, iset))
2021 60329 : icgf = icgf + 1
2022 : WRITE (UNIT=output_unit, &
2023 : FMT="(T25,I3,4X,I4,3X,A12,(T51,2F15.6))") &
2024 60329 : iset, ishell, orb_basis_set%cgf_symbol(icgf), &
2025 181732 : (orb_basis_set%zet(ipgf, iset), &
2026 : orb_basis_set%norm_cgf(icgf)* &
2027 242061 : orb_basis_set%gcc(ipgf, ishell, iset), &
2028 385097 : ipgf=1, orb_basis_set%npgf(iset))
2029 : END DO
2030 : END DO
2031 : END DO
2032 : END IF
2033 :
2034 5228 : END SUBROUTINE write_orb_basis_set
2035 :
2036 : ! **************************************************************************************************
2037 : !> \brief ...
2038 : !> \param gto_basis_set ...
2039 : !> \param output_unit ...
2040 : !> \author JGH
2041 : ! **************************************************************************************************
2042 0 : SUBROUTINE dump_gto_basis_set(gto_basis_set, output_unit)
2043 :
2044 : TYPE(gto_basis_set_type), INTENT(IN) :: gto_basis_set
2045 : INTEGER, INTENT(in) :: output_unit
2046 :
2047 : INTEGER :: ipgf, iset, ishell
2048 :
2049 0 : IF (output_unit > 0) THEN
2050 :
2051 0 : WRITE (UNIT=output_unit, FMT="(/,T6,A40)") TRIM(gto_basis_set%name)
2052 0 : WRITE (UNIT=output_unit, FMT="(/,T6,A40)") TRIM(gto_basis_set%aliases)
2053 0 : WRITE (UNIT=output_unit, FMT="(/,T6,F12.8)") gto_basis_set%kind_radius
2054 0 : WRITE (UNIT=output_unit, FMT="(/,T6,F12.8)") gto_basis_set%short_kind_radius
2055 0 : WRITE (UNIT=output_unit, FMT="(/,T6,I8)") gto_basis_set%norm_type
2056 0 : WRITE (UNIT=output_unit, FMT="(/,T6,3I8)") gto_basis_set%ncgf, gto_basis_set%nset, gto_basis_set%nsgf
2057 0 : WRITE (UNIT=output_unit, FMT="(/,T6,6A12)") gto_basis_set%cgf_symbol
2058 0 : WRITE (UNIT=output_unit, FMT="(/,T6,6A12)") gto_basis_set%sgf_symbol
2059 0 : WRITE (UNIT=output_unit, FMT="(/,T6,6F12.6)") gto_basis_set%norm_cgf
2060 0 : WRITE (UNIT=output_unit, FMT="(/,T6,6F12.6)") gto_basis_set%set_radius
2061 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%lmax
2062 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%lmin
2063 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%lx
2064 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%ly
2065 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%lz
2066 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%m
2067 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%ncgf_set
2068 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%nsgf_set
2069 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%npgf
2070 0 : WRITE (UNIT=output_unit, FMT="(/,T6,12I6)") gto_basis_set%nshell
2071 :
2072 0 : DO iset = 1, gto_basis_set%nset
2073 : WRITE (UNIT=output_unit, FMT="(T8,6F15.6)") &
2074 0 : gto_basis_set%pgf_radius(1:gto_basis_set%npgf(iset), iset)
2075 : END DO
2076 :
2077 0 : DO iset = 1, gto_basis_set%nset
2078 : WRITE (UNIT=output_unit, FMT="(T8,6F15.6)") &
2079 0 : gto_basis_set%zet(1:gto_basis_set%npgf(iset), iset)
2080 : END DO
2081 :
2082 0 : DO iset = 1, gto_basis_set%nset
2083 0 : DO ishell = 1, gto_basis_set%nshell(iset)
2084 : WRITE (UNIT=output_unit, FMT="(T8,8I10)") &
2085 0 : iset, ishell, &
2086 0 : gto_basis_set%n(ishell, iset), &
2087 0 : gto_basis_set%l(ishell, iset), &
2088 0 : gto_basis_set%first_cgf(ishell, iset), &
2089 0 : gto_basis_set%last_cgf(ishell, iset), &
2090 0 : gto_basis_set%first_sgf(ishell, iset), &
2091 0 : gto_basis_set%last_sgf(ishell, iset)
2092 : END DO
2093 : END DO
2094 :
2095 0 : DO iset = 1, gto_basis_set%nset
2096 0 : DO ishell = 1, gto_basis_set%nshell(iset)
2097 : WRITE (UNIT=output_unit, FMT="(T8,2I5,(T25,4F15.6))") &
2098 0 : iset, ishell, &
2099 0 : (gto_basis_set%gcc(ipgf, ishell, iset), &
2100 0 : ipgf=1, gto_basis_set%npgf(iset))
2101 : END DO
2102 : END DO
2103 :
2104 0 : WRITE (UNIT=output_unit, FMT="(A5)") "CPHI"
2105 0 : WRITE (UNIT=output_unit, FMT="(12F10.5)") gto_basis_set%cphi
2106 0 : WRITE (UNIT=output_unit, FMT="(A1)") "SPHI"
2107 0 : WRITE (UNIT=output_unit, FMT="(12F10.5)") gto_basis_set%sphi
2108 0 : WRITE (UNIT=output_unit, FMT="(A1)") "SCON"
2109 0 : WRITE (UNIT=output_unit, FMT="(12F10.5)") gto_basis_set%scon
2110 0 : WRITE (UNIT=output_unit, FMT="(A1)") "CCON"
2111 0 : WRITE (UNIT=output_unit, FMT="(12F10.5)") gto_basis_set%ccon
2112 :
2113 : END IF
2114 :
2115 0 : END SUBROUTINE dump_gto_basis_set
2116 :
2117 : ! **************************************************************************************************
2118 : !> \brief ...
2119 : !> \param sto_basis_set ...
2120 : ! **************************************************************************************************
2121 4784 : SUBROUTINE allocate_sto_basis_set(sto_basis_set)
2122 :
2123 : TYPE(sto_basis_set_type), POINTER :: sto_basis_set
2124 :
2125 4784 : CALL deallocate_sto_basis_set(sto_basis_set)
2126 :
2127 4784 : ALLOCATE (sto_basis_set)
2128 :
2129 4784 : END SUBROUTINE allocate_sto_basis_set
2130 :
2131 : ! **************************************************************************************************
2132 : !> \brief ...
2133 : !> \param sto_basis_set ...
2134 : ! **************************************************************************************************
2135 11292 : SUBROUTINE deallocate_sto_basis_set(sto_basis_set)
2136 :
2137 : TYPE(sto_basis_set_type), POINTER :: sto_basis_set
2138 :
2139 : ! -------------------------------------------------------------------------
2140 :
2141 11292 : IF (ASSOCIATED(sto_basis_set)) THEN
2142 4784 : IF (ASSOCIATED(sto_basis_set%symbol)) THEN
2143 4622 : DEALLOCATE (sto_basis_set%symbol)
2144 : END IF
2145 4784 : IF (ASSOCIATED(sto_basis_set%nq)) THEN
2146 4784 : DEALLOCATE (sto_basis_set%nq)
2147 : END IF
2148 4784 : IF (ASSOCIATED(sto_basis_set%lq)) THEN
2149 4784 : DEALLOCATE (sto_basis_set%lq)
2150 : END IF
2151 4784 : IF (ASSOCIATED(sto_basis_set%zet)) THEN
2152 4784 : DEALLOCATE (sto_basis_set%zet)
2153 : END IF
2154 :
2155 4784 : DEALLOCATE (sto_basis_set)
2156 : END IF
2157 11292 : END SUBROUTINE deallocate_sto_basis_set
2158 :
2159 : ! **************************************************************************************************
2160 : !> \brief ...
2161 : !> \param sto_basis_set ...
2162 : !> \param name ...
2163 : !> \param nshell ...
2164 : !> \param symbol ...
2165 : !> \param nq ...
2166 : !> \param lq ...
2167 : !> \param zet ...
2168 : !> \param maxlq ...
2169 : !> \param numsto ...
2170 : ! **************************************************************************************************
2171 4784 : SUBROUTINE get_sto_basis_set(sto_basis_set, name, nshell, symbol, nq, lq, zet, maxlq, numsto)
2172 :
2173 : TYPE(sto_basis_set_type), INTENT(IN) :: sto_basis_set
2174 : CHARACTER(LEN=default_string_length), &
2175 : INTENT(OUT), OPTIONAL :: name
2176 : INTEGER, INTENT(OUT), OPTIONAL :: nshell
2177 : CHARACTER(LEN=6), DIMENSION(:), OPTIONAL, POINTER :: symbol
2178 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: nq, lq
2179 : REAL(KIND=dp), DIMENSION(:), OPTIONAL, POINTER :: zet
2180 : INTEGER, INTENT(OUT), OPTIONAL :: maxlq, numsto
2181 :
2182 : INTEGER :: iset
2183 :
2184 4784 : IF (PRESENT(name)) name = sto_basis_set%name
2185 4784 : IF (PRESENT(nshell)) nshell = sto_basis_set%nshell
2186 4784 : IF (PRESENT(symbol)) symbol => sto_basis_set%symbol
2187 4784 : IF (PRESENT(nq)) nq => sto_basis_set%nq
2188 4784 : IF (PRESENT(lq)) lq => sto_basis_set%lq
2189 4784 : IF (PRESENT(zet)) zet => sto_basis_set%zet
2190 4784 : IF (PRESENT(maxlq)) THEN
2191 0 : maxlq = MAXVAL(sto_basis_set%lq(1:sto_basis_set%nshell))
2192 : END IF
2193 4784 : IF (PRESENT(numsto)) THEN
2194 0 : numsto = 0
2195 0 : DO iset = 1, sto_basis_set%nshell
2196 0 : numsto = numsto + 2*sto_basis_set%lq(iset) + 1
2197 : END DO
2198 : END IF
2199 :
2200 4784 : END SUBROUTINE get_sto_basis_set
2201 :
2202 : ! **************************************************************************************************
2203 : !> \brief ...
2204 : !> \param sto_basis_set ...
2205 : !> \param name ...
2206 : !> \param nshell ...
2207 : !> \param symbol ...
2208 : !> \param nq ...
2209 : !> \param lq ...
2210 : !> \param zet ...
2211 : ! **************************************************************************************************
2212 4780 : SUBROUTINE set_sto_basis_set(sto_basis_set, name, nshell, symbol, nq, lq, zet)
2213 :
2214 : TYPE(sto_basis_set_type), INTENT(INOUT) :: sto_basis_set
2215 : CHARACTER(LEN=default_string_length), INTENT(IN), &
2216 : OPTIONAL :: name
2217 : INTEGER, INTENT(IN), OPTIONAL :: nshell
2218 : CHARACTER(LEN=6), DIMENSION(:), OPTIONAL, POINTER :: symbol
2219 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: nq, lq
2220 : REAL(KIND=dp), DIMENSION(:), OPTIONAL, POINTER :: zet
2221 :
2222 : INTEGER :: ns
2223 :
2224 4780 : IF (PRESENT(name)) sto_basis_set%name = name
2225 4780 : IF (PRESENT(nshell)) sto_basis_set%nshell = nshell
2226 4780 : IF (PRESENT(symbol)) THEN
2227 4618 : ns = SIZE(symbol)
2228 4618 : IF (ASSOCIATED(sto_basis_set%symbol)) DEALLOCATE (sto_basis_set%symbol)
2229 13854 : ALLOCATE (sto_basis_set%symbol(1:ns))
2230 18962 : sto_basis_set%symbol(:) = symbol(:)
2231 : END IF
2232 4780 : IF (PRESENT(nq)) THEN
2233 4780 : ns = SIZE(nq)
2234 4780 : CALL reallocate(sto_basis_set%nq, 1, ns)
2235 19286 : sto_basis_set%nq = nq(:)
2236 : END IF
2237 4780 : IF (PRESENT(lq)) THEN
2238 4780 : ns = SIZE(lq)
2239 4780 : CALL reallocate(sto_basis_set%lq, 1, ns)
2240 19286 : sto_basis_set%lq = lq(:)
2241 : END IF
2242 4780 : IF (PRESENT(zet)) THEN
2243 4780 : ns = SIZE(zet)
2244 4780 : CALL reallocate(sto_basis_set%zet, 1, ns)
2245 19286 : sto_basis_set%zet = zet(:)
2246 : END IF
2247 :
2248 4780 : END SUBROUTINE set_sto_basis_set
2249 :
2250 : ! **************************************************************************************************
2251 : !> \brief ...
2252 : !> \param element_symbol ...
2253 : !> \param basis_set_name ...
2254 : !> \param sto_basis_set ...
2255 : !> \param para_env ...
2256 : !> \param dft_section ...
2257 : ! **************************************************************************************************
2258 4 : SUBROUTINE read_sto_basis_set(element_symbol, basis_set_name, sto_basis_set, para_env, dft_section)
2259 :
2260 : ! Read a Slater-type orbital (STO) basis set from the database file.
2261 :
2262 : CHARACTER(LEN=*), INTENT(IN) :: element_symbol, basis_set_name
2263 : TYPE(sto_basis_set_type), INTENT(INOUT) :: sto_basis_set
2264 : TYPE(mp_para_env_type), POINTER :: para_env
2265 : TYPE(section_vals_type), POINTER :: dft_section
2266 :
2267 : CHARACTER(LEN=10) :: nlsym
2268 : CHARACTER(LEN=2) :: lsym
2269 : CHARACTER(LEN=240) :: line
2270 : CHARACTER(LEN=242) :: line2
2271 : CHARACTER(len=default_path_length) :: basis_set_file_name, tmp
2272 : CHARACTER(LEN=default_path_length), DIMENSION(:), &
2273 4 : POINTER :: cbasis
2274 4 : CHARACTER(LEN=LEN(basis_set_name)) :: bsname
2275 4 : CHARACTER(LEN=LEN(basis_set_name)+2) :: bsname2
2276 4 : CHARACTER(LEN=LEN(element_symbol)) :: symbol
2277 4 : CHARACTER(LEN=LEN(element_symbol)+2) :: symbol2
2278 : INTEGER :: ibasis, irep, iset, nbasis, nq, nset, &
2279 : strlen1, strlen2
2280 : LOGICAL :: basis_found, found, match
2281 : REAL(KIND=dp) :: zet
2282 : TYPE(cp_parser_type) :: parser
2283 :
2284 4 : line = ""
2285 4 : line2 = ""
2286 4 : symbol = ""
2287 4 : symbol2 = ""
2288 4 : bsname = ""
2289 4 : bsname2 = ""
2290 :
2291 : nbasis = 1
2292 :
2293 4 : sto_basis_set%name = basis_set_name
2294 : CALL section_vals_val_get(dft_section, "BASIS_SET_FILE_NAME", &
2295 4 : n_rep_val=nbasis)
2296 12 : ALLOCATE (cbasis(nbasis))
2297 8 : DO ibasis = 1, nbasis
2298 : CALL section_vals_val_get(dft_section, "BASIS_SET_FILE_NAME", &
2299 4 : i_rep_val=ibasis, c_val=cbasis(ibasis))
2300 4 : basis_set_file_name = cbasis(ibasis)
2301 4 : tmp = basis_set_file_name
2302 8 : CALL uppercase(tmp)
2303 : END DO
2304 :
2305 : ! Search for the requested basis set in the basis set file
2306 : ! until the basis set is found or the end of file is reached
2307 :
2308 4 : basis_found = .FALSE.
2309 8 : basis_loop: DO ibasis = 1, nbasis
2310 4 : IF (basis_found) EXIT basis_loop
2311 4 : basis_set_file_name = cbasis(ibasis)
2312 4 : CALL parser_create(parser, basis_set_file_name, para_env=para_env)
2313 :
2314 4 : bsname = basis_set_name
2315 4 : symbol = element_symbol
2316 4 : irep = 0
2317 :
2318 4 : tmp = basis_set_name
2319 4 : CALL uppercase(tmp)
2320 :
2321 4 : IF (tmp /= "NONE") THEN
2322 : search_loop: DO
2323 :
2324 6 : CALL parser_search_string(parser, TRIM(bsname), .TRUE., found, line)
2325 6 : IF (found) THEN
2326 6 : CALL uppercase(symbol)
2327 6 : CALL uppercase(bsname)
2328 :
2329 6 : match = .FALSE.
2330 6 : CALL uppercase(line)
2331 : ! Check both the element symbol and the basis set name
2332 6 : line2 = " "//line//" "
2333 6 : symbol2 = " "//TRIM(symbol)//" "
2334 6 : bsname2 = " "//TRIM(bsname)//" "
2335 6 : strlen1 = LEN_TRIM(symbol2) + 1
2336 6 : strlen2 = LEN_TRIM(bsname2) + 1
2337 :
2338 6 : IF ((INDEX(line2, symbol2(:strlen1)) > 0) .AND. &
2339 4 : (INDEX(line2, bsname2(:strlen2)) > 0)) match = .TRUE.
2340 6 : IF (match) THEN
2341 : ! Read the basis set information
2342 4 : CALL parser_get_object(parser, nset, newline=.TRUE.)
2343 4 : sto_basis_set%nshell = nset
2344 :
2345 4 : CALL reallocate(sto_basis_set%nq, 1, nset)
2346 4 : CALL reallocate(sto_basis_set%lq, 1, nset)
2347 4 : CALL reallocate(sto_basis_set%zet, 1, nset)
2348 12 : ALLOCATE (sto_basis_set%symbol(nset))
2349 :
2350 20 : DO iset = 1, nset
2351 16 : CALL parser_get_object(parser, nq, newline=.TRUE.)
2352 16 : CALL parser_get_object(parser, lsym)
2353 16 : CALL parser_get_object(parser, zet)
2354 16 : sto_basis_set%nq(iset) = nq
2355 16 : sto_basis_set%zet(iset) = zet
2356 16 : WRITE (nlsym, "(I2,A)") nq, TRIM(lsym)
2357 16 : sto_basis_set%symbol(iset) = TRIM(nlsym)
2358 20 : SELECT CASE (TRIM(lsym))
2359 : CASE ("S", "s")
2360 12 : sto_basis_set%lq(iset) = 0
2361 : CASE ("P", "p")
2362 4 : sto_basis_set%lq(iset) = 1
2363 : CASE ("D", "d")
2364 0 : sto_basis_set%lq(iset) = 2
2365 : CASE ("F", "f")
2366 0 : sto_basis_set%lq(iset) = 3
2367 : CASE ("G", "g")
2368 0 : sto_basis_set%lq(iset) = 4
2369 : CASE ("H", "h")
2370 0 : sto_basis_set%lq(iset) = 5
2371 : CASE ("I", "i", "J", "j")
2372 0 : sto_basis_set%lq(iset) = 6
2373 : CASE ("K", "k")
2374 0 : sto_basis_set%lq(iset) = 7
2375 : CASE ("L", "l")
2376 0 : sto_basis_set%lq(iset) = 8
2377 : CASE ("M", "m")
2378 0 : sto_basis_set%lq(iset) = 9
2379 : CASE DEFAULT
2380 : CALL cp_abort(__LOCATION__, &
2381 : "The requested basis set <"//TRIM(bsname)// &
2382 16 : "> for element <"//TRIM(symbol)//"> has an invalid component: ")
2383 : END SELECT
2384 : END DO
2385 :
2386 : basis_found = .TRUE.
2387 : EXIT search_loop
2388 : END IF
2389 : ELSE
2390 : EXIT search_loop
2391 : END IF
2392 : END DO search_loop
2393 : ELSE
2394 4 : match = .FALSE.
2395 : END IF
2396 :
2397 12 : CALL parser_release(parser)
2398 :
2399 : END DO basis_loop
2400 :
2401 4 : IF (tmp /= "NONE") THEN
2402 4 : IF (.NOT. basis_found) THEN
2403 0 : basis_set_file_name = ""
2404 0 : DO ibasis = 1, nbasis
2405 0 : basis_set_file_name = TRIM(basis_set_file_name)//"<"//TRIM(cbasis(ibasis))//"> "
2406 : END DO
2407 : CALL cp_abort(__LOCATION__, &
2408 : "The requested basis set <"//TRIM(bsname)// &
2409 : "> for element <"//TRIM(symbol)//"> was not "// &
2410 : "found in the basis set files "// &
2411 0 : TRIM(basis_set_file_name))
2412 : END IF
2413 : END IF
2414 4 : DEALLOCATE (cbasis)
2415 :
2416 16 : END SUBROUTINE read_sto_basis_set
2417 :
2418 : ! **************************************************************************************************
2419 : !> \brief ...
2420 : !> \param sto_basis_set ...
2421 : !> \param gto_basis_set ...
2422 : !> \param ngauss ...
2423 : !> \param ortho ...
2424 : !> \param ngaussflex ...
2425 : ! **************************************************************************************************
2426 4784 : SUBROUTINE create_gto_from_sto_basis(sto_basis_set, gto_basis_set, ngauss, ortho, ngaussflex)
2427 :
2428 : TYPE(sto_basis_set_type), INTENT(IN) :: sto_basis_set
2429 : TYPE(gto_basis_set_type), POINTER :: gto_basis_set
2430 : INTEGER, INTENT(IN), OPTIONAL :: ngauss
2431 : LOGICAL, INTENT(IN), OPTIONAL :: ortho
2432 : INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: ngaussflex
2433 :
2434 : INTEGER, PARAMETER :: maxng = 6
2435 :
2436 : CHARACTER(LEN=default_string_length) :: name, sng
2437 : INTEGER :: ipgf, iset, maxl, ng, ng_max, ng_set, &
2438 : nset, nshell
2439 4784 : INTEGER, DIMENSION(:), POINTER :: lq, nq
2440 : LOGICAL :: do_ortho
2441 4784 : REAL(KIND=dp), DIMENSION(:), POINTER :: zet
2442 : REAL(KIND=dp), DIMENSION(maxng) :: gcc, zetg
2443 :
2444 4784 : ng = 6
2445 4784 : IF (PRESENT(ngauss)) ng = ngauss
2446 4784 : IF (ng < 1 .OR. ng > maxng) CPABORT("Invalid number of Gaussian primitives requested")
2447 4784 : do_ortho = .FALSE.
2448 4784 : IF (PRESENT(ortho)) do_ortho = ortho
2449 :
2450 4784 : CALL allocate_gto_basis_set(gto_basis_set)
2451 :
2452 : CALL get_sto_basis_set(sto_basis_set, name=name, nshell=nshell, nq=nq, &
2453 4784 : lq=lq, zet=zet)
2454 :
2455 19306 : maxl = MAXVAL(lq)
2456 4784 : CALL init_orbital_pointers(maxl)
2457 :
2458 4784 : nset = nshell
2459 4784 : ng_max = ng
2460 4784 : IF (PRESENT(ngaussflex)) THEN
2461 8 : IF (SIZE(ngaussflex) < nset) CPABORT("Not enough Gaussian primitive counts provided")
2462 56 : IF (ANY(ngaussflex(1:nset) < 1) .OR. ANY(ngaussflex(1:nset) > maxng)) THEN
2463 0 : CPABORT("Invalid flexible Gaussian primitive count")
2464 : END IF
2465 28 : ng_max = MAXVAL(ngaussflex(1:nset))
2466 8 : gto_basis_set%name = TRIM(name)//"_STO-FLEX"
2467 : ELSE
2468 4776 : CALL integer_to_string(ng, sng)
2469 4776 : gto_basis_set%name = TRIM(name)//"_STO-"//TRIM(sng)//"G"
2470 : END IF
2471 :
2472 4784 : gto_basis_set%nset = nset
2473 4784 : CALL reallocate(gto_basis_set%lmax, 1, nset)
2474 4784 : CALL reallocate(gto_basis_set%lmin, 1, nset)
2475 4784 : CALL reallocate(gto_basis_set%npgf, 1, nset)
2476 4784 : CALL reallocate(gto_basis_set%nshell, 1, nset)
2477 4784 : CALL reallocate(gto_basis_set%n, 1, 1, 1, nset)
2478 4784 : CALL reallocate(gto_basis_set%l, 1, 1, 1, nset)
2479 4784 : CALL reallocate(gto_basis_set%zet, 1, ng_max, 1, nset)
2480 4784 : CALL reallocate(gto_basis_set%gcc, 1, ng_max, 1, 1, 1, nset)
2481 73884 : gto_basis_set%zet = 0.0_dp
2482 84186 : gto_basis_set%gcc = 0.0_dp
2483 :
2484 15086 : DO iset = 1, nset
2485 10302 : ng_set = ng
2486 10302 : IF (PRESENT(ngaussflex)) ng_set = ngaussflex(iset)
2487 10302 : CALL get_sto_ng(zet(iset), ng_set, nq(iset), lq(iset), zetg, gcc)
2488 10302 : gto_basis_set%lmax(iset) = lq(iset)
2489 10302 : gto_basis_set%lmin(iset) = lq(iset)
2490 10302 : gto_basis_set%npgf(iset) = ng_set
2491 10302 : gto_basis_set%nshell(iset) = 1
2492 10302 : gto_basis_set%n(1, iset) = lq(iset) + 1
2493 10302 : gto_basis_set%l(1, iset) = lq(iset)
2494 73876 : DO ipgf = 1, ng_set
2495 58790 : gto_basis_set%gcc(ipgf, 1, iset) = gcc(ipgf)
2496 69092 : gto_basis_set%zet(ipgf, iset) = zetg(ipgf)
2497 : END DO
2498 : END DO
2499 :
2500 4784 : CALL process_gto_basis(gto_basis_set, do_ortho, nset, maxl)
2501 :
2502 4784 : END SUBROUTINE create_gto_from_sto_basis
2503 :
2504 : ! **************************************************************************************************
2505 : !> \brief ...
2506 : !> \param gto_basis_set ...
2507 : !> \param do_ortho ...
2508 : !> \param nset ...
2509 : !> \param maxl ...
2510 : ! **************************************************************************************************
2511 5108 : SUBROUTINE process_gto_basis(gto_basis_set, do_ortho, nset, maxl)
2512 :
2513 : TYPE(gto_basis_set_type), POINTER :: gto_basis_set
2514 : LOGICAL, INTENT(IN), OPTIONAL :: do_ortho
2515 : INTEGER, INTENT(IN) :: nset, maxl
2516 :
2517 : INTEGER :: i1, i2, ico, iset, jset, l, lshell, m, &
2518 : max_ng, max_ngl, maxco, ncgf, ng, ngs, &
2519 : np, nsgf
2520 5108 : INTEGER, ALLOCATABLE, DIMENSION(:) :: ng_set
2521 : INTEGER, DIMENSION(0:10) :: mxf, ngl, offset
2522 5108 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: gal, zal, zll
2523 :
2524 5108 : IF (do_ortho) THEN
2525 2294 : mxf = 0
2526 2294 : ngl = 0
2527 7526 : DO iset = 1, nset
2528 5232 : l = gto_basis_set%l(1, iset)
2529 5232 : mxf(l) = mxf(l) + 1
2530 7526 : ngl(l) = ngl(l) + gto_basis_set%npgf(iset)
2531 : END DO
2532 27528 : m = MAXVAL(mxf)
2533 2294 : IF (m > 1) THEN
2534 1566 : max_ng = MAXVAL(gto_basis_set%npgf(1:nset))
2535 6264 : max_ngl = MAXVAL(ngl)
2536 5742 : ALLOCATE (gal(max_ng, nset), zal(max_ng, nset), zll(max_ngl, 0:maxl), ng_set(nset))
2537 522 : gal = 0.0_dp
2538 522 : zal = 0.0_dp
2539 1566 : DO iset = 1, nset
2540 1044 : ng_set(iset) = gto_basis_set%npgf(iset)
2541 1044 : ng = ng_set(iset)
2542 5220 : zal(1:ng, iset) = gto_basis_set%zet(1:ng, iset)
2543 5742 : gal(1:ng, iset) = gto_basis_set%gcc(1:ng, 1, iset)
2544 : END DO
2545 522 : CALL reallocate(gto_basis_set%zet, 1, max_ngl, 1, nset)
2546 522 : CALL reallocate(gto_basis_set%gcc, 1, max_ngl, 1, 1, 1, nset)
2547 9918 : gto_basis_set%zet = 0.0_dp
2548 10962 : gto_basis_set%gcc = 0.0_dp
2549 522 : zll = 0.0_dp
2550 522 : offset = 0
2551 1566 : DO iset = 1, nset
2552 1044 : l = gto_basis_set%l(1, iset)
2553 1044 : ng = ng_set(iset)
2554 1044 : i1 = offset(l) + 1
2555 1044 : i2 = offset(l) + ng
2556 5220 : zll(i1:i2, l) = zal(1:ng, iset)
2557 5220 : gto_basis_set%gcc(i1:i2, 1, iset) = gal(1:ng, iset)
2558 1566 : offset(l) = i2
2559 : END DO
2560 1566 : DO iset = 1, nset
2561 1044 : l = gto_basis_set%l(1, iset)
2562 1044 : ng = ngl(l)
2563 1044 : gto_basis_set%npgf(iset) = ng
2564 9918 : gto_basis_set%zet(1:ng, iset) = zll(1:ng, l)
2565 : END DO
2566 1566 : DO iset = 1, nset
2567 1044 : l = gto_basis_set%l(1, iset)
2568 2088 : DO jset = 1, iset - 1
2569 1566 : IF (gto_basis_set%l(1, jset) == l) THEN
2570 522 : m = ngl(l)
2571 : CALL orthofun(gto_basis_set%zet(1:m, iset), gto_basis_set%gcc(1:m, 1, iset), &
2572 522 : gto_basis_set%gcc(1:m, 1, jset), l)
2573 : END IF
2574 : END DO
2575 : END DO
2576 522 : DEALLOCATE (gal, zal, zll, ng_set)
2577 : END IF
2578 : END IF
2579 :
2580 16144 : ngs = MAXVAL(gto_basis_set%npgf(1:nset))
2581 5108 : CALL reallocate(gto_basis_set%set_radius, 1, nset)
2582 5108 : CALL reallocate(gto_basis_set%pgf_radius, 1, ngs, 1, nset)
2583 5108 : CALL reallocate(gto_basis_set%first_cgf, 1, 1, 1, nset)
2584 5108 : CALL reallocate(gto_basis_set%first_sgf, 1, 1, 1, nset)
2585 5108 : CALL reallocate(gto_basis_set%last_cgf, 1, 1, 1, nset)
2586 5108 : CALL reallocate(gto_basis_set%last_sgf, 1, 1, 1, nset)
2587 5108 : CALL reallocate(gto_basis_set%ncgf_set, 1, nset)
2588 5108 : CALL reallocate(gto_basis_set%nsgf_set, 1, nset)
2589 :
2590 5108 : maxco = 0
2591 5108 : ncgf = 0
2592 5108 : nsgf = 0
2593 :
2594 16144 : DO iset = 1, nset
2595 11036 : gto_basis_set%ncgf_set(iset) = 0
2596 11036 : gto_basis_set%nsgf_set(iset) = 0
2597 11036 : lshell = gto_basis_set%l(1, iset)
2598 11036 : gto_basis_set%first_cgf(1, iset) = ncgf + 1
2599 11036 : ncgf = ncgf + nco(lshell)
2600 11036 : gto_basis_set%last_cgf(1, iset) = ncgf
2601 : gto_basis_set%ncgf_set(iset) = &
2602 11036 : gto_basis_set%ncgf_set(iset) + nco(lshell)
2603 11036 : gto_basis_set%first_sgf(1, iset) = nsgf + 1
2604 11036 : nsgf = nsgf + nso(lshell)
2605 11036 : gto_basis_set%last_sgf(1, iset) = nsgf
2606 : gto_basis_set%nsgf_set(iset) = &
2607 11036 : gto_basis_set%nsgf_set(iset) + nso(lshell)
2608 11036 : ngs = gto_basis_set%npgf(iset)
2609 16144 : maxco = MAX(maxco, ngs*ncoset(lshell))
2610 : END DO
2611 :
2612 5108 : gto_basis_set%ncgf = ncgf
2613 5108 : gto_basis_set%nsgf = nsgf
2614 :
2615 5108 : CALL reallocate(gto_basis_set%cphi, 1, maxco, 1, ncgf)
2616 5108 : CALL reallocate(gto_basis_set%sphi, 1, maxco, 1, nsgf)
2617 5108 : CALL reallocate(gto_basis_set%scon, 1, maxco, 1, nsgf)
2618 5108 : CALL reallocate(gto_basis_set%ccon, 1, maxco, 1, ncgf)
2619 5108 : CALL reallocate(gto_basis_set%lx, 1, ncgf)
2620 5108 : CALL reallocate(gto_basis_set%ly, 1, ncgf)
2621 5108 : CALL reallocate(gto_basis_set%lz, 1, ncgf)
2622 5108 : CALL reallocate(gto_basis_set%m, 1, nsgf)
2623 5108 : CALL reallocate(gto_basis_set%norm_cgf, 1, ncgf)
2624 15324 : ALLOCATE (gto_basis_set%cgf_symbol(ncgf))
2625 15324 : ALLOCATE (gto_basis_set%sgf_symbol(nsgf))
2626 :
2627 5108 : ncgf = 0
2628 5108 : nsgf = 0
2629 :
2630 16144 : DO iset = 1, nset
2631 11036 : lshell = gto_basis_set%l(1, iset)
2632 11036 : np = lshell + 1
2633 37178 : DO ico = ncoset(lshell - 1) + 1, ncoset(lshell)
2634 26142 : ncgf = ncgf + 1
2635 26142 : gto_basis_set%lx(ncgf) = indco(1, ico)
2636 26142 : gto_basis_set%ly(ncgf) = indco(2, ico)
2637 26142 : gto_basis_set%lz(ncgf) = indco(3, ico)
2638 : gto_basis_set%cgf_symbol(ncgf) = &
2639 : cgf_symbol(np, [gto_basis_set%lx(ncgf), &
2640 : gto_basis_set%ly(ncgf), &
2641 115604 : gto_basis_set%lz(ncgf)])
2642 : END DO
2643 40816 : DO m = -lshell, lshell
2644 24672 : nsgf = nsgf + 1
2645 24672 : gto_basis_set%m(nsgf) = m
2646 35708 : gto_basis_set%sgf_symbol(nsgf) = sgf_symbol(np, lshell, m)
2647 : END DO
2648 : END DO
2649 :
2650 5108 : gto_basis_set%norm_type = -1
2651 :
2652 5108 : END SUBROUTINE process_gto_basis
2653 :
2654 : ! **************************************************************************************************
2655 : !> \brief ...
2656 : !> \param zet ...
2657 : !> \param co ...
2658 : !> \param cr ...
2659 : !> \param l ...
2660 : ! **************************************************************************************************
2661 522 : SUBROUTINE orthofun(zet, co, cr, l)
2662 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zet
2663 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: co, cr
2664 : INTEGER, INTENT(IN) :: l
2665 :
2666 : REAL(KIND=dp) :: ss
2667 :
2668 522 : CALL aovlp(l, zet, cr, cr, ss)
2669 4698 : cr(:) = cr(:)/SQRT(ss)
2670 522 : CALL aovlp(l, zet, co, cr, ss)
2671 4698 : co(:) = co(:) - ss*cr(:)
2672 522 : CALL aovlp(l, zet, co, co, ss)
2673 4698 : co(:) = co(:)/SQRT(ss)
2674 :
2675 522 : END SUBROUTINE orthofun
2676 :
2677 : ! **************************************************************************************************
2678 : !> \brief ...
2679 : !> \param l ...
2680 : !> \param zet ...
2681 : !> \param ca ...
2682 : !> \param cb ...
2683 : !> \param ss ...
2684 : ! **************************************************************************************************
2685 1566 : SUBROUTINE aovlp(l, zet, ca, cb, ss)
2686 : INTEGER, INTENT(IN) :: l
2687 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zet, ca, cb
2688 : REAL(KIND=dp), INTENT(OUT) :: ss
2689 :
2690 : INTEGER :: i, j, m
2691 : REAL(KIND=dp) :: ab, ai, aj, s00, sss
2692 :
2693 : !
2694 : ! use init_norm_cgf_orb
2695 : !
2696 1566 : m = SIZE(zet)
2697 1566 : ss = 0.0_dp
2698 14094 : DO i = 1, m
2699 12528 : ai = (2.0_dp*zet(i)/pi)**0.75_dp
2700 114318 : DO j = 1, m
2701 100224 : aj = (2.0_dp*zet(j)/pi)**0.75_dp
2702 100224 : ab = 1._dp/(zet(i) + zet(j))
2703 100224 : s00 = ai*aj*(pi*ab)**1.50_dp
2704 100224 : IF (l == 0) THEN
2705 : sss = s00
2706 0 : ELSE IF (l == 1) THEN
2707 0 : sss = s00*ab*0.5_dp
2708 : ELSE
2709 0 : CPABORT("aovlp lvalue")
2710 : END IF
2711 112752 : ss = ss + sss*ca(i)*cb(j)
2712 : END DO
2713 : END DO
2714 :
2715 1566 : END SUBROUTINE aovlp
2716 :
2717 : ! **************************************************************************************************
2718 : !> \brief ...
2719 : !> \param z ...
2720 : !> \param ne ...
2721 : !> \param n ...
2722 : !> \param l ...
2723 : !> \return ...
2724 : ! **************************************************************************************************
2725 24858 : PURE FUNCTION srules(z, ne, n, l)
2726 : ! Slater rules
2727 : INTEGER, INTENT(IN) :: z
2728 : INTEGER, DIMENSION(:, :), INTENT(IN) :: ne
2729 : INTEGER, INTENT(IN) :: n, l
2730 : REAL(dp) :: srules
2731 :
2732 : REAL(dp), DIMENSION(7), PARAMETER :: &
2733 : xns = [1.0_dp, 2.0_dp, 3.0_dp, 3.7_dp, 4.0_dp, 4.2_dp, 4.4_dp]
2734 :
2735 : INTEGER :: i, l1, l2, m, m1, m2, nn
2736 : REAL(dp) :: s
2737 :
2738 24858 : s = 0.0_dp
2739 : ! The complete shell
2740 24858 : l1 = MIN(l + 1, 4)
2741 24858 : nn = MIN(n, 7)
2742 : IF (l1 == 1) l2 = 2
2743 24858 : IF (l1 == 2) l2 = 1
2744 17507 : IF (l1 == 3) l2 = 4
2745 23413 : IF (l1 == 4) l2 = 3
2746 : ! Rule a) no contribution from shells further out
2747 : ! Rule b) 0.35 (1s 0.3) from each other electron in the same shell
2748 24858 : IF (n == 1) THEN
2749 7192 : m = ne(1, 1)
2750 7192 : s = s + 0.3_dp*REAL(m - 1, dp)
2751 : ELSE
2752 17666 : m = ne(l1, nn) + ne(l2, nn)
2753 17666 : s = s + 0.35_dp*REAL(m - 1, dp)
2754 : END IF
2755 : ! Rule c) if (s,p) shell 0.85 from each electron with n-1, and 1.0
2756 : ! from all electrons further in
2757 24858 : IF (l1 + l2 == 3) THEN
2758 23226 : IF (nn > 1) THEN
2759 16034 : m1 = ne(1, nn - 1) + ne(2, nn - 1) + ne(3, nn - 1) + ne(4, nn - 1)
2760 16034 : m2 = 0
2761 24498 : DO i = 1, nn - 2
2762 24498 : m2 = m2 + ne(1, i) + ne(2, i) + ne(3, i) + ne(4, I)
2763 : END DO
2764 16034 : s = s + 0.85_dp*REAL(m1, dp) + 1._dp*REAL(m2, dp)
2765 : END IF
2766 : ELSE
2767 : ! Rule d) if (d,f) shell 1.0 from each electron inside
2768 : m = 0
2769 6624 : DO i = 1, nn - 1
2770 6624 : m = m + ne(1, i) + ne(2, i) + ne(3, i) + ne(4, i)
2771 : END DO
2772 1632 : s = s + 1._dp*REAL(m, dp)
2773 : END IF
2774 : ! Slater exponent is (Z-S)/NS
2775 24858 : srules = (REAL(z, dp) - s)/xns(nn)
2776 24858 : END FUNCTION srules
2777 :
2778 : ! **************************************************************************************************
2779 : !> \brief sort basis sets w.r.t. radius
2780 : !> \param basis_set ...
2781 : !> \param sort_method ...
2782 : ! **************************************************************************************************
2783 14024 : SUBROUTINE sort_gto_basis_set(basis_set, sort_method)
2784 : TYPE(gto_basis_set_type), INTENT(INOUT) :: basis_set
2785 : INTEGER, INTENT(IN) :: sort_method
2786 :
2787 14024 : CHARACTER(LEN=12), DIMENSION(:), POINTER :: cgf_symbol
2788 14024 : CHARACTER(LEN=6), DIMENSION(:), POINTER :: sgf_symbol
2789 : INTEGER :: ic, ic_max, icgf, icgf_new, icgf_old, ico, is, is_max, iset, isgf, isgf_new, &
2790 : isgf_old, ishell, lshell, maxco, maxpgf, maxshell, mm, nc, ncgf, ns, nset
2791 14024 : INTEGER, ALLOCATABLE, DIMENSION(:) :: sort_index
2792 14024 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: icgf_set, isgf_set
2793 14024 : INTEGER, DIMENSION(:), POINTER :: lx, ly, lz, m, npgf
2794 : LOGICAL :: ccon_available
2795 14024 : REAL(dp), ALLOCATABLE, DIMENSION(:) :: tmp
2796 14024 : REAL(dp), DIMENSION(:), POINTER :: set_radius
2797 14024 : REAL(dp), DIMENSION(:, :), POINTER :: zet
2798 14024 : REAL(KIND=dp), DIMENSION(:), POINTER :: norm_cgf
2799 14024 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: ccon, cphi, scon, sphi
2800 :
2801 14024 : NULLIFY (set_radius, zet)
2802 :
2803 14024 : IF (sort_method == basis_sort_default) RETURN
2804 :
2805 : CALL get_gto_basis_set(gto_basis_set=basis_set, &
2806 : nset=nset, &
2807 : maxshell=maxshell, &
2808 : maxpgf=maxpgf, &
2809 : maxco=maxco, &
2810 : ncgf=ncgf, &
2811 : npgf=npgf, &
2812 : set_radius=set_radius, &
2813 830 : zet=zet)
2814 :
2815 2490 : ALLOCATE (sort_index(nset))
2816 2490 : ALLOCATE (tmp(nset))
2817 : SELECT CASE (sort_method)
2818 : CASE (basis_sort_zet)
2819 5074 : DO iset = 1, nset
2820 11370 : tmp(iset) = MINVAL(basis_set%zet(:npgf(iset), iset))
2821 : END DO
2822 : CASE DEFAULT
2823 830 : CPABORT("Request basis sort criterion not implemented.")
2824 : END SELECT
2825 :
2826 830 : CALL sort(tmp(1:nset), nset, sort_index)
2827 :
2828 830 : ic_max = 0
2829 830 : is_max = 0
2830 5074 : DO iset = 1, nset
2831 4244 : ic = 0
2832 4244 : is = 0
2833 11408 : DO ishell = 1, basis_set%nshell(iset)
2834 24946 : DO ico = 1, nco(basis_set%l(ishell, iset))
2835 18612 : ic = ic + 1
2836 24946 : IF (ic > ic_max) ic_max = ic
2837 : END DO
2838 6334 : lshell = basis_set%l(ishell, iset)
2839 27200 : DO mm = -lshell, lshell
2840 16622 : is = is + 1
2841 22956 : IF (is > is_max) is_max = is
2842 : END DO
2843 : END DO
2844 : END DO
2845 :
2846 830 : icgf = 0
2847 830 : isgf = 0
2848 3320 : ALLOCATE (icgf_set(nset, ic_max))
2849 830 : icgf_set(:, :) = 0
2850 3320 : ALLOCATE (isgf_set(nset, is_max))
2851 830 : isgf_set(:, :) = 0
2852 :
2853 5074 : DO iset = 1, nset
2854 4244 : ic = 0
2855 4244 : is = 0
2856 11408 : DO ishell = 1, basis_set%nshell(iset)
2857 24946 : DO ico = 1, nco(basis_set%l(ishell, iset))
2858 18612 : icgf = icgf + 1
2859 18612 : ic = ic + 1
2860 24946 : icgf_set(iset, ic) = icgf
2861 : END DO
2862 6334 : lshell = basis_set%l(ishell, iset)
2863 27200 : DO mm = -lshell, lshell
2864 16622 : isgf = isgf + 1
2865 16622 : is = is + 1
2866 22956 : isgf_set(iset, is) = isgf
2867 : END DO
2868 : END DO
2869 : END DO
2870 :
2871 2490 : ALLOCATE (cgf_symbol(SIZE(basis_set%cgf_symbol)))
2872 2490 : ALLOCATE (norm_cgf(SIZE(basis_set%norm_cgf)))
2873 2490 : ALLOCATE (lx(SIZE(basis_set%lx)))
2874 2490 : ALLOCATE (ly(SIZE(basis_set%ly)))
2875 2490 : ALLOCATE (lz(SIZE(basis_set%lz)))
2876 3320 : ALLOCATE (cphi(SIZE(basis_set%cphi, 1), SIZE(basis_set%cphi, 2)))
2877 688462 : cphi = 0.0_dp
2878 3320 : ALLOCATE (sphi(SIZE(basis_set%sphi, 1), SIZE(basis_set%sphi, 2)))
2879 607612 : sphi = 0.0_dp
2880 3320 : ALLOCATE (scon(SIZE(basis_set%scon, 1), SIZE(basis_set%scon, 2)))
2881 607612 : scon = 0.0_dp
2882 2490 : ALLOCATE (ccon(SIZE(basis_set%cphi, 1), SIZE(basis_set%cphi, 2)))
2883 688462 : ccon = 0.0_dp
2884 830 : ccon_available = ASSOCIATED(basis_set%ccon)
2885 830 : IF (ccon_available) THEN
2886 : ccon_available = (SIZE(basis_set%ccon, 1) == SIZE(ccon, 1)) .AND. &
2887 724 : (SIZE(basis_set%ccon, 2) == SIZE(ccon, 2))
2888 : END IF
2889 :
2890 2490 : ALLOCATE (sgf_symbol(SIZE(basis_set%sgf_symbol)))
2891 2490 : ALLOCATE (m(SIZE(basis_set%m)))
2892 :
2893 : icgf_new = 0
2894 : isgf_new = 0
2895 5074 : DO iset = 1, nset
2896 42064 : DO ic = 1, ic_max
2897 37820 : icgf_old = icgf_set(sort_index(iset), ic)
2898 37820 : IF (icgf_old == 0) CYCLE
2899 18612 : icgf_new = icgf_new + 1
2900 18612 : norm_cgf(icgf_new) = basis_set%norm_cgf(icgf_old)
2901 18612 : lx(icgf_new) = basis_set%lx(icgf_old)
2902 18612 : ly(icgf_new) = basis_set%ly(icgf_old)
2903 18612 : lz(icgf_new) = basis_set%lz(icgf_old)
2904 687632 : cphi(:, icgf_new) = basis_set%cphi(:, icgf_old)
2905 219340 : IF (ccon_available) ccon(:, icgf_new) = basis_set%ccon(:, icgf_old)
2906 42064 : cgf_symbol(icgf_new) = basis_set%cgf_symbol(icgf_old)
2907 : END DO
2908 35340 : DO is = 1, is_max
2909 30266 : isgf_old = isgf_set(sort_index(iset), is)
2910 30266 : IF (isgf_old == 0) CYCLE
2911 16622 : isgf_new = isgf_new + 1
2912 16622 : m(isgf_new) = basis_set%m(isgf_old)
2913 606782 : sphi(:, isgf_new) = basis_set%sphi(:, isgf_old)
2914 606782 : scon(:, isgf_new) = basis_set%scon(:, isgf_old)
2915 34510 : sgf_symbol(isgf_new) = basis_set%sgf_symbol(isgf_old)
2916 : END DO
2917 : END DO
2918 :
2919 830 : DEALLOCATE (basis_set%cgf_symbol)
2920 830 : basis_set%cgf_symbol => cgf_symbol
2921 830 : DEALLOCATE (basis_set%norm_cgf)
2922 830 : basis_set%norm_cgf => norm_cgf
2923 830 : DEALLOCATE (basis_set%lx)
2924 830 : basis_set%lx => lx
2925 830 : DEALLOCATE (basis_set%ly)
2926 830 : basis_set%ly => ly
2927 830 : DEALLOCATE (basis_set%lz)
2928 830 : basis_set%lz => lz
2929 830 : DEALLOCATE (basis_set%cphi)
2930 830 : basis_set%cphi => cphi
2931 830 : DEALLOCATE (basis_set%sphi)
2932 830 : basis_set%sphi => sphi
2933 830 : DEALLOCATE (basis_set%scon)
2934 830 : basis_set%scon => scon
2935 830 : IF (ASSOCIATED(basis_set%ccon)) DEALLOCATE (basis_set%ccon)
2936 830 : basis_set%ccon => ccon
2937 :
2938 830 : DEALLOCATE (basis_set%m)
2939 830 : basis_set%m => m
2940 830 : DEALLOCATE (basis_set%sgf_symbol)
2941 830 : basis_set%sgf_symbol => sgf_symbol
2942 :
2943 9318 : basis_set%lmax = basis_set%lmax(sort_index)
2944 9318 : basis_set%lmin = basis_set%lmin(sort_index)
2945 9318 : basis_set%npgf = basis_set%npgf(sort_index)
2946 9318 : basis_set%nshell = basis_set%nshell(sort_index)
2947 9318 : basis_set%ncgf_set = basis_set%ncgf_set(sort_index)
2948 9318 : basis_set%nsgf_set = basis_set%nsgf_set(sort_index)
2949 :
2950 25134 : basis_set%n(:, :) = basis_set%n(:, sort_index)
2951 25134 : basis_set%l(:, :) = basis_set%l(:, sort_index)
2952 28138 : basis_set%zet(:, :) = basis_set%zet(:, sort_index)
2953 :
2954 105570 : basis_set%gcc(:, :, :) = basis_set%gcc(:, :, sort_index)
2955 9318 : basis_set%set_radius(:) = basis_set%set_radius(sort_index)
2956 28138 : basis_set%pgf_radius(:, :) = basis_set%pgf_radius(:, sort_index)
2957 :
2958 830 : nc = 0
2959 830 : ns = 0
2960 5074 : DO iset = 1, nset
2961 11408 : DO ishell = 1, basis_set%nshell(iset)
2962 6334 : lshell = basis_set%l(ishell, iset)
2963 6334 : basis_set%first_cgf(ishell, iset) = nc + 1
2964 6334 : nc = nc + nco(lshell)
2965 6334 : basis_set%last_cgf(ishell, iset) = nc
2966 6334 : basis_set%first_sgf(ishell, iset) = ns + 1
2967 6334 : ns = ns + nso(lshell)
2968 10578 : basis_set%last_sgf(ishell, iset) = ns
2969 : END DO
2970 : END DO
2971 :
2972 14854 : END SUBROUTINE sort_gto_basis_set
2973 :
2974 0 : END MODULE basis_set_types
|
