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