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