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