1! This file is part of xtb.
2!
3! Copyright (C) 2017-2020 Stefan Grimme
4!
5! xtb is free software: you can redistribute it and/or modify it under
6! the terms of the GNU Lesser General Public License as published by
7! the Free Software Foundation, either version 3 of the License, or
8! (at your option) any later version.
9!
10! xtb is distributed in the hope that it will be useful,
11! but WITHOUT ANY WARRANTY; without even the implied warranty of
12! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13! GNU Lesser General Public License for more details.
14!
15! You should have received a copy of the GNU Lesser General Public License
16! along with xtb.  If not, see <https://www.gnu.org/licenses/>.
17
18subroutine write_tm_basis(iunit,xtbData,nat,at,basis,wfn)
19   use xtb_mctc_accuracy, only : wp
20   use xtb_mctc_symbols, only : toLcSymbol
21   use xtb_type_wavefunction
22   use xtb_type_basisset
23   use xtb_xtb_data
24   implicit none
25   type(TxTBData), intent(in) :: xtbData
26   type(TBasisset),    intent(in) :: basis
27   type(TWavefunction),intent(in) :: wfn
28   integer,intent(in)  :: iunit
29   integer,intent(in)  :: nat
30   integer,intent(in)  :: at(nat)
31   character(1) :: lnam(0:3)
32   integer :: nn(94)
33   integer :: iat,iatyp,ish,icao,ip,iprim,ishtyp
34
35   lnam(0)='s'
36   lnam(1)='p'
37   lnam(2)='d'
38   lnam(3)='f'
39
40   write(iunit,'(a)') '$basis'
41   nn=0
42   do iat = 1, nat
43      nn(at(iat)) = iat
44   enddo
45   write(iunit,'(a)') '*'
46   do iatyp = 1, 86
47      iat = nn(iatyp)
48      if (iat.eq.0) cycle
49      write(iunit,'(a,1x,a)') trim(toLcSymbol(iatyp)),'tbbas'
50      write(iunit,'(a)') '*'
51      do ish = 1, xtbData%nShell(iatyp)
52         ishtyp = xtbData%hamiltonian%angShell(ish,iatyp)
53         icao = basis%caoshell(ish,iat)
54         write(iunit,'(1x,i3,2x,a1,25x,a)') &
55            basis%nprim(icao+1),lnam(ishtyp)
56         do ip = 1, basis%nprim(icao+1)
57            iprim = ip + basis%primcount(icao+1)
58            if (basis%cont(iprim) < 0) then
59               write(iunit,'(2x,g16.11,1x,g17.11)') basis%alp(iprim), basis%cont(iprim)
60            else
61               write(iunit,'(2(2x,g16.11))') basis%alp(iprim), basis%cont(iprim)
62            endif
63         enddo
64      enddo
65      write(iunit,'(a)') '*'
66   enddo
67   write(iunit,'(a)') '$end'
68end subroutine write_tm_basis
69