Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Print basis sets in CP2K format
10 : !> \par History
11 : !> \author JGH (12.2017)
12 : ! **************************************************************************************************
13 : MODULE basis_set_output
14 : USE basis_set_types, ONLY: get_gto_basis_set,&
15 : gto_basis_set_type
16 : USE cp2k_info, ONLY: compile_revision,&
17 : cp2k_version,&
18 : r_datx,&
19 : r_host_name,&
20 : r_user_name
21 : USE cp_files, ONLY: close_file,&
22 : open_file
23 : USE cp_log_handling, ONLY: cp_get_default_logger,&
24 : cp_logger_get_default_io_unit,&
25 : cp_logger_type
26 : USE input_section_types, ONLY: section_vals_type,&
27 : section_vals_val_get
28 : USE kinds, ONLY: default_string_length,&
29 : dp
30 : USE qs_environment_types, ONLY: get_qs_env,&
31 : qs_environment_type
32 : USE qs_kind_types, ONLY: get_qs_kind,&
33 : qs_kind_type
34 : #include "./base/base_uses.f90"
35 :
36 : IMPLICIT NONE
37 : PRIVATE
38 :
39 : ! Global parameters
40 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'basis_set_output'
41 : PUBLIC :: print_basis_set_file
42 :
43 : ! **************************************************************************************************
44 :
45 : CONTAINS
46 :
47 : ! **************************************************************************************************
48 : !> \brief ...
49 : !> \param qs_env ...
50 : !> \param base_section ...
51 : ! **************************************************************************************************
52 2 : SUBROUTINE print_basis_set_file(qs_env, base_section)
53 :
54 : TYPE(qs_environment_type), POINTER :: qs_env
55 : TYPE(section_vals_type), POINTER :: base_section
56 :
57 : CHARACTER(LEN=2) :: element_symbol
58 : CHARACTER(LEN=default_string_length) :: bname, filename
59 : INTEGER :: ikind, iunit, nkind, ounit
60 : INTEGER, SAVE :: ncalls = 0
61 : TYPE(cp_logger_type), POINTER :: logger
62 : TYPE(gto_basis_set_type), POINTER :: aux_fit_basis, lri_aux_basis, orb_basis, &
63 : p_lri_aux_basis, ri_aux_basis, ri_hfx_basis, ri_hxc_basis, ri_xas_basis, tda_hfx_basis
64 2 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
65 : TYPE(qs_kind_type), POINTER :: qs_kind
66 :
67 0 : IF (ncalls > 0) RETURN
68 2 : ncalls = ncalls + 1
69 :
70 2 : logger => cp_get_default_logger()
71 2 : ounit = cp_logger_get_default_io_unit(logger)
72 :
73 2 : CALL section_vals_val_get(base_section, "FILENAME", c_val=filename)
74 :
75 2 : IF (ounit > 0) THEN
76 1 : WRITE (UNIT=ounit, FMT='(/,(T2,A))') REPEAT("-", 79)
77 1 : WRITE (UNIT=ounit, FMT='((T2,A,A))') "Print Basis Set File: ", TRIM(filename)
78 1 : WRITE (UNIT=ounit, FMT='((T2,A))') REPEAT("-", 79)
79 1 : CALL open_file(filename, unit_number=iunit, file_status="UNKNOWN", file_action="WRITE")
80 : WRITE (UNIT=iunit, FMT="(A8,T11,A)") &
81 1 : "# TITLE ", "Basis set file created by "//TRIM(cp2k_version)//" (revision "//TRIM(compile_revision)//")", &
82 2 : "# AUTHOR", TRIM(r_user_name)//"@"//TRIM(r_host_name)//" "//r_datx(1:19)
83 :
84 : END IF
85 :
86 2 : CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set, nkind=nkind)
87 6 : DO ikind = 1, nkind
88 4 : qs_kind => qs_kind_set(ikind)
89 4 : CALL get_qs_kind(qs_kind, element_symbol=element_symbol)
90 4 : NULLIFY (orb_basis, ri_aux_basis, lri_aux_basis, p_lri_aux_basis, aux_fit_basis)
91 4 : CALL get_qs_kind(qs_kind, basis_set=orb_basis, basis_type="ORB")
92 4 : CALL get_qs_kind(qs_kind, basis_set=ri_aux_basis, basis_type="RI_AUX")
93 4 : CALL get_qs_kind(qs_kind, basis_set=ri_hxc_basis, basis_type="RI_HXC")
94 4 : CALL get_qs_kind(qs_kind, basis_set=ri_hfx_basis, basis_type="RI_HFX")
95 4 : CALL get_qs_kind(qs_kind, basis_set=lri_aux_basis, basis_type="LRI_AUX")
96 4 : CALL get_qs_kind(qs_kind, basis_set=p_lri_aux_basis, basis_type="P_LRI_AUX")
97 4 : CALL get_qs_kind(qs_kind, basis_set=aux_fit_basis, basis_type="AUX_FIT")
98 4 : CALL get_qs_kind(qs_kind, basis_set=ri_xas_basis, basis_type="RI_XAS")
99 4 : CALL get_qs_kind(qs_kind, basis_set=tda_hfx_basis, basis_type="TDA_HFX")
100 6 : IF (ounit > 0) THEN
101 2 : IF (ASSOCIATED(orb_basis)) THEN
102 2 : bname = "local_orbital"
103 2 : CALL basis_out(orb_basis, element_symbol, bname, iunit)
104 : END IF
105 2 : IF (ASSOCIATED(ri_aux_basis)) THEN
106 0 : bname = "local_ri_aux"
107 0 : CALL basis_out(ri_aux_basis, element_symbol, bname, iunit)
108 : END IF
109 2 : IF (ASSOCIATED(ri_hxc_basis)) THEN
110 0 : bname = "local_ri_hxc"
111 0 : CALL basis_out(ri_hxc_basis, element_symbol, bname, iunit)
112 : END IF
113 2 : IF (ASSOCIATED(lri_aux_basis)) THEN
114 2 : bname = "local_lri_aux"
115 2 : CALL basis_out(lri_aux_basis, element_symbol, bname, iunit)
116 : END IF
117 2 : IF (ASSOCIATED(p_lri_aux_basis)) THEN
118 2 : bname = "local_p_lri_aux"
119 2 : CALL basis_out(p_lri_aux_basis, element_symbol, bname, iunit)
120 : END IF
121 2 : IF (ASSOCIATED(aux_fit_basis)) THEN
122 0 : bname = "local_aux_fit"
123 0 : CALL basis_out(aux_fit_basis, element_symbol, bname, iunit)
124 : END IF
125 2 : IF (ASSOCIATED(ri_xas_basis)) THEN
126 0 : bname = "local_ri_xas"
127 0 : CALL basis_out(ri_xas_basis, element_symbol, bname, iunit)
128 : END IF
129 2 : IF (ASSOCIATED(ri_hfx_basis)) THEN
130 0 : bname = "local_ri_hfx"
131 0 : CALL basis_out(ri_hfx_basis, element_symbol, bname, iunit)
132 : END IF
133 2 : IF (ASSOCIATED(tda_hfx_basis)) THEN
134 0 : bname = "local_tda_hfx"
135 0 : CALL basis_out(tda_hfx_basis, element_symbol, bname, iunit)
136 : END IF
137 : END IF
138 : END DO
139 :
140 2 : IF (ounit > 0) THEN
141 1 : CALL close_file(iunit)
142 : END IF
143 :
144 2 : END SUBROUTINE print_basis_set_file
145 :
146 : ! **************************************************************************************************
147 :
148 : ! **************************************************************************************************
149 : !> \brief ...
150 : !> \param basis ...
151 : !> \param element_symbol ...
152 : !> \param bname ...
153 : !> \param iunit ...
154 : ! **************************************************************************************************
155 12 : SUBROUTINE basis_out(basis, element_symbol, bname, iunit)
156 : TYPE(gto_basis_set_type), POINTER :: basis
157 : CHARACTER(LEN=*), INTENT(IN) :: element_symbol, bname
158 : INTEGER, INTENT(IN) :: iunit
159 :
160 : INTEGER :: ipgf, iset, ishell, ll, nset
161 : INTEGER, DIMENSION(0:9) :: lset
162 6 : INTEGER, DIMENSION(:), POINTER :: lmax, lmin, npgf, nshell
163 6 : INTEGER, DIMENSION(:, :), POINTER :: l, n
164 6 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: zet
165 6 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: gcc
166 :
167 6 : WRITE (iunit, "(A1)") "#"
168 6 : WRITE (iunit, "(A2,T5,A)") element_symbol, ADJUSTL(TRIM(bname))
169 :
170 : CALL get_gto_basis_set(basis, nset=nset, npgf=npgf, lmax=lmax, lmin=lmin, &
171 : nshell=nshell, n=n, l=l, &
172 6 : gcc=gcc, zet=zet)
173 :
174 6 : WRITE (iunit, "(I5)") nset
175 58 : DO iset = 1, nset
176 52 : lset = 0
177 246 : DO ishell = 1, nshell(iset)
178 194 : ll = l(ishell, iset)
179 246 : lset(ll) = lset(ll) + 1
180 : END DO
181 52 : WRITE (iunit, "(I5,2I3,I5,2X,10(I3))") n(1, iset), lmin(iset), lmax(iset), npgf(iset), &
182 104 : (lset(ll), ll=lmin(iset), lmax(iset))
183 122 : DO ipgf = 1, npgf(iset)
184 116 : WRITE (iunit, "(F20.10,50(F15.10))") zet(ipgf, iset), (gcc(ipgf, ishell, iset), ishell=1, nshell(iset))
185 : END DO
186 : END DO
187 :
188 6 : END SUBROUTINE basis_out
189 :
190 : ! **************************************************************************************************
191 :
192 : END MODULE basis_set_output
|
