mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-17 04:00:49 +01:00
943 lines
32 KiB
Fortran
943 lines
32 KiB
Fortran
************************************************************************
|
|
subroutine freqdrv
|
|
************************************************************************
|
|
* Driver for harmonic vibrational frequency calculation
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer natoms,iatoms,jatoms,datoms,i,j,ixyz,ider,ii,jj,ih,iisyev
|
|
integer ntr,nbl,ibl,sigma,nrot,imult,chartab(nirmax,nirmax),nder
|
|
integer chars(nirmax),ndeg,katoms
|
|
real*8 h,fac,ten(3,3),dcoeff(4),gtol,etol,x(3,3),rotconst(3),tmp
|
|
real*8 px,py,pz,dnrm2,ddot,rconst,temp,press,weight,hckt
|
|
real*8 etra,erot,evib,eele,qtra,qrot,qvib,qele,qtot,stra,srot
|
|
real*8 svib,sele,stot,rottemp,freq,tenergy,ezpe,ctra,crot,cvib
|
|
real*8 pggen(3,3,nirmax),vec(3),dip(3)
|
|
integer*4 istat,system,isyev
|
|
character(len=1) xyz(3),fpgrp(8)
|
|
character(len=4) c4,irlab(0:nirmax),molden
|
|
character(len=8) pntgrp,cmpgrp
|
|
character(len=16) ndeps,c16
|
|
equivalence(isyev,iisyev) !For Intel
|
|
equivalence(pntgrp,fpgrp)
|
|
data xyz /'x','y','z'/
|
|
logical lin,lll
|
|
C
|
|
character(len=1),allocatable::imag(:)
|
|
character(len=2),allocatable::atsymbol(:)
|
|
integer,allocatable::modesym(:),symat(:,:),modeir(:,:),lcatoms(:)
|
|
real*8,allocatable::coord(:,:),atmass(:),grad1(:),hessian(:,:)
|
|
real*8,allocatable::vibfreq(:),work(:,:),grad2(:),dvec(:,:),d(:,:)
|
|
real*8,allocatable::mwhess(:,:),redmass(:),dipder(:,:),dipnc(:,:)
|
|
C
|
|
write(iout,*)
|
|
write(iout,"(1x,70('*'))")
|
|
write(iout,*) 'Calculation of harmonic vibrational frequencies'
|
|
C Coefficients of the central differences
|
|
dcoeff=0.d0
|
|
nder=2
|
|
if(nder.eq.2) then
|
|
dcoeff(1)=1.d0/2.d0
|
|
else if(nder.eq.4) then
|
|
dcoeff(1)= 2.d0/3.d0
|
|
dcoeff(2)=-1.d0/12.d0
|
|
else if(nder.eq.6) then
|
|
dcoeff(1)= 3.d0/4.d0
|
|
dcoeff(2)=-3.d0/20.d0
|
|
dcoeff(3)= 1.d0/60.d0
|
|
else if(nder.eq.8) then
|
|
dcoeff(1)= 4.d0/5.d0
|
|
dcoeff(2)=-1.d0/5.d0
|
|
dcoeff(3)= 4.d0/105.d0
|
|
dcoeff(4)=-1.d0/280.d0
|
|
else
|
|
write(iout,*) 'Central difference is not implemented!'
|
|
call dmrccend(1)
|
|
endif
|
|
C Read coordinates
|
|
call getvar('natoms ',natoms)
|
|
call getvar('nir ',nir)
|
|
allocate(atsymbol(natoms),coord(3,natoms),symat(natoms,nir))
|
|
allocate(grad1(3*natoms),grad2(3*natoms),lcatoms(natoms))
|
|
allocate(hessian(3*natoms,3*natoms),atmass(natoms))
|
|
allocate(dipder(3,3*natoms))
|
|
call getvar('coord ',coord)
|
|
call getvar('atmass ',atmass)
|
|
call getvar('pggen ',pggen)
|
|
call getvar('irlab ',irlab(1))
|
|
irlab(0)=' ?? '
|
|
call getvar('chartab ',chartab)
|
|
call getvar('symat ',symat)
|
|
call getvar_c('atsymbol ',atsymbol)
|
|
istat=system('cp MINP MINP.freqinit')
|
|
call getkey('molden',6,molden,4)
|
|
call changekey('dens',4,'2 ',4)
|
|
call changekey('unit',4,'bohr',4)
|
|
call changekey('molden',6,'off ',4)
|
|
call getkey('ndeps',5,ndeps,16)
|
|
read(ndeps,*) h
|
|
call getkey('gtol',4,c4,4)
|
|
read(c4,*) i
|
|
gtol=10.d0**(-i)
|
|
call getvar('pntgrp ',fpgrp)
|
|
call getvar('cmpgrp ',cmpgrp)
|
|
call getkey('mult',4,c4,4)
|
|
read(c4,*) imult
|
|
call getenergy(tenergy,c16)
|
|
open(unit=scrfile1,file='ITER')
|
|
write(scrfile1,*) 0
|
|
close(scrfile1)
|
|
C Build and diagonalize inertial tensor
|
|
call buildinertial(natoms,coord,atmass,x,gtol,etol)
|
|
call dsyev("V","U",3,x,3,rotconst,hessian,9*natoms**2,isyev)
|
|
if(isyev.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the diagonalization of the inertial tensor!'
|
|
call dmrccend(1)
|
|
endif
|
|
j=0
|
|
do i=1,3
|
|
if(dabs(rotconst(i)).gt.etol) then
|
|
j=j+1
|
|
rotconst(j)=planck/
|
|
$(8d-4*pi**2*amutokg*angtobohr**2*rotconst(i))
|
|
endif
|
|
enddo
|
|
if(natoms.eq.1) then
|
|
ntr=3
|
|
nrot=0
|
|
lin=.true.
|
|
ndeg=0
|
|
goto 1234
|
|
else if(j.eq.2) then
|
|
ntr=5
|
|
nrot=2
|
|
lin=.true.
|
|
else
|
|
ntr=6
|
|
nrot=3
|
|
lin=.false.
|
|
endif
|
|
C Build Hessian
|
|
lcatoms=1
|
|
hessian=0.d0
|
|
dipder=0.d0
|
|
ih=0
|
|
do datoms=1,natoms
|
|
c if(.true.) then
|
|
if(lcatoms(datoms).eq.1) then
|
|
lcatoms(datoms)=0
|
|
do ixyz=1,3
|
|
ih=ih+1
|
|
do ider=-nder/2,nder/2
|
|
if(ider.ne.0) then
|
|
coord(ixyz,datoms)=coord(ixyz,datoms)+dble(ider)*h
|
|
open(minpfile,file='MINP')
|
|
write(minpfile,'(a)') 'unit=bohr'
|
|
write(minpfile,'(a)') 'geom=xyz'
|
|
write(minpfile,*) natoms
|
|
write(minpfile,*)
|
|
do iatoms=1,natoms
|
|
write(minpfile,"(a3,3f22.14)") atsymbol(iatoms),
|
|
$(coord(i,iatoms),i=1,3)
|
|
enddo
|
|
close(minpfile)
|
|
istat=system('cat MINP.freqinit >> MINP')
|
|
call spoint(.true.)
|
|
open(scrfile1,file='GRAD',status='old',
|
|
$form='unformatted')
|
|
ii=0
|
|
do iatoms=1,natoms
|
|
read(scrfile1) grad1(ii+1),grad1(ii+2),grad1(ii+3)
|
|
ii=ii+3
|
|
enddo
|
|
close(scrfile1)
|
|
call getvar('ten ',ten)
|
|
call dgemm('t','n',3,natoms,3,1.d0,ten,3,grad1,3,0.d0,
|
|
$grad2,3)
|
|
hessian(1:3*natoms,ih)=hessian(1:3*natoms,ih)+
|
|
$dcoeff(iabs(ider))*dble(isign(1,ider))*grad2(1:3*natoms)/h
|
|
coord(ixyz,datoms)=coord(ixyz,datoms)-dble(ider)*h
|
|
open(scrfile1,file='MOMENT',status='old',
|
|
$form='unformatted')
|
|
read(scrfile1) vec(1:3)
|
|
close(scrfile1)
|
|
call dgemv('t',3,3,1.d0,ten,3,vec,1,0.d0,dip,1)
|
|
dipder(1:3,ih)=dipder(1:3,ih)+
|
|
$dcoeff(iabs(ider))*dble(isign(1,ider))*dip(1:3)/h
|
|
endif
|
|
enddo
|
|
do i=1,nir
|
|
call dgemm('n','n',3,natoms,3,1.d0,pggen(1,1,i),3,
|
|
$hessian(1,ih),3,0.d0,grad1,3)
|
|
call dgemv('n',3,3,1.d0,pggen(1,1,i),3,dipder(1:3,ih),1,
|
|
$0.d0,dip,1)
|
|
iatoms=symat(datoms,i)
|
|
if(lcatoms(iatoms).eq.1) then
|
|
do jatoms=1,natoms
|
|
katoms=symat(jatoms,i)
|
|
grad2((katoms-1)*3+1:(katoms-1)*3+3)=
|
|
$ grad1((jatoms-1)*3+1:(jatoms-1)*3+3)
|
|
enddo
|
|
if(pggen(ixyz,ixyz,i).lt.-gtol) then
|
|
grad2(1:3*natoms)=-grad2(1:3*natoms)
|
|
dip=-dip
|
|
endif
|
|
hessian(1:3*natoms,(iatoms-1)*3+ixyz)=grad2(1:3*natoms)
|
|
dipder(1:3,(iatoms-1)*3+ixyz)=dip
|
|
endif
|
|
enddo
|
|
enddo
|
|
lcatoms(symat(datoms,1:nir))=0
|
|
else
|
|
ih=ih+3
|
|
endif
|
|
enddo
|
|
istat=system('mv MINP.freqinit MINP')
|
|
c write(iout,*)
|
|
c ih=0
|
|
c do iatoms=1,natoms
|
|
c do ixyz=1,3
|
|
c ih=ih+1
|
|
c write(iout,"(i15,1x,a2,1x,a1,5x,1000f11.5)") iatoms,
|
|
c $atsymbol(iatoms),xyz(ixyz),(dipder(j,ih),j=1,3)
|
|
c $atsymbol(iatoms),xyz(ixyz),(hessian(ih,j),j=1,3*natoms)
|
|
c enddo
|
|
c enddo
|
|
C Symmetrize the Hessian
|
|
do i=1,3*natoms
|
|
do j=1,i-1
|
|
tmp=(hessian(i,j)+hessian(j,i))/2.d0
|
|
hessian(i,j)=tmp
|
|
hessian(j,i)=tmp
|
|
enddo
|
|
enddo
|
|
C Mass weight the Hessian
|
|
allocate(vibfreq(3*natoms),work(3*natoms,3*natoms))
|
|
allocate(dvec(3*natoms,6),d(3*natoms,3*natoms))
|
|
ih=0
|
|
do iatoms=1,natoms
|
|
tmp=1.d0/dsqrt(atmass(iatoms))
|
|
do ixyz=1,3
|
|
ih=ih+1
|
|
hessian(1:3*natoms,ih)=tmp*hessian(1:3*natoms,ih)
|
|
hessian(ih,1:3*natoms)=tmp*hessian(ih,1:3*natoms)
|
|
enddo
|
|
enddo
|
|
C Diagonalize Hessian
|
|
write(iout,"(1x,70('*'))")
|
|
allocate(mwhess(3*natoms,3*natoms),imag(3*natoms))
|
|
allocate(redmass(3*natoms),modesym(3*natoms),modeir(nir,3*natoms))
|
|
mwhess=hessian
|
|
call dsyev('N','U',3*natoms,mwhess,3*natoms,vibfreq,work,
|
|
$9*natoms**2,isyev)
|
|
if(isyev.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the diagonalization of the mass-weighted Hessian!'
|
|
call dmrccend(1)
|
|
endif
|
|
imag=' '
|
|
do ih=1,3*natoms
|
|
if(vibfreq(ih).lt.0) imag(ih)='i'
|
|
enddo
|
|
fac=dsqrt(jtoeh*1d9/amutokg)/angtobohr/(2.d0*clight*pi)
|
|
write(iout,*)
|
|
write(iout,*) 'Vibrational frequencies before projection [cm-1]:'
|
|
write(iout,"(7(f9.2,a1))") (fac*dsqrt(dabs(vibfreq(i))),imag(i),
|
|
$i=1,3*natoms)
|
|
C Generate coordinates in the rotating and translating frame
|
|
write(iout,*)
|
|
write(iout,*)
|
|
$'Projecting out translational and rotational modes...'
|
|
write(iout,*)
|
|
dvec=0.d0
|
|
ih=0
|
|
do iatoms=1,natoms
|
|
tmp=dsqrt(atmass(iatoms))
|
|
px=coord(1,iatoms)*x(1,1)+
|
|
$ coord(2,iatoms)*x(2,1)+
|
|
$ coord(3,iatoms)*x(3,1)
|
|
py=coord(1,iatoms)*x(1,2)+
|
|
$ coord(2,iatoms)*x(2,2)+
|
|
$ coord(3,iatoms)*x(3,2)
|
|
pz=coord(1,iatoms)*x(1,3)+
|
|
$ coord(2,iatoms)*x(2,3)+
|
|
$ coord(3,iatoms)*x(3,3)
|
|
do ixyz=1,3
|
|
ih=ih+1
|
|
dvec(ih,ixyz)=tmp
|
|
dvec(ih,4)=(py*x(ixyz,3)-pz*x(ixyz,2))*tmp
|
|
dvec(ih,5)=(pz*x(ixyz,1)-px*x(ixyz,3))*tmp
|
|
dvec(ih,6)=(px*x(ixyz,2)-py*x(ixyz,1))*tmp
|
|
enddo
|
|
enddo
|
|
ii=0
|
|
do i=1,6
|
|
tmp=dnrm2(3*natoms,dvec(1,i),1)
|
|
if(tmp.gt.1d-10) then
|
|
ii=ii+1
|
|
call dscal(3*natoms,1.d0/tmp,dvec(1,i),1)
|
|
call dcopy(3*natoms,dvec(1,i),1,dvec(1,ii),1)
|
|
endif
|
|
enddo
|
|
if(ii.ne.ntr) then
|
|
write(iout,*)
|
|
$'Wrong number of rotational and translational modes!'
|
|
call dmrccend(1)
|
|
endif
|
|
C Generate coordinates for vibrations
|
|
d=0.d0
|
|
ii=0
|
|
do ih=1,3*natoms
|
|
d(ih,ih)=1.d0
|
|
do i=1,ntr
|
|
tmp=ddot(3*natoms,d(1,ih),1,dvec(1,i),1)
|
|
d(1:3*natoms,ih)=d(1:3*natoms,ih)-tmp*dvec(1:3*natoms,i)
|
|
enddo
|
|
do i=1,ii
|
|
tmp=ddot(3*natoms,d(1,ih),1,d(1,i),1)
|
|
d(1:3*natoms,ih)=d(1:3*natoms,ih)-tmp*d(1:3*natoms,i)
|
|
enddo
|
|
tmp=dnrm2(3*natoms,d(1,ih),1)
|
|
if(tmp.gt.1d-10) then
|
|
ii=ii+1
|
|
call dscal(3*natoms,1.d0/tmp,d(1,ih),1)
|
|
call dcopy(3*natoms,d(1,ih),1,d(1,ii),1)
|
|
endif
|
|
enddo
|
|
if(ii.ne.3*natoms-ntr) then
|
|
write(iout,*)
|
|
$'Wrong number of rotational and translational modes!'
|
|
call dmrccend(1)
|
|
endif
|
|
ndeg=3*natoms-ntr
|
|
C Transform Hessian to the new basis
|
|
call dsymm('l','l',3*natoms,ndeg,1.d0,hessian,3*natoms,d,
|
|
$3*natoms,0.d0,work,3*natoms)
|
|
call dgemm('t','n',ndeg,ndeg,3*natoms,1.d0,d,3*natoms,work,
|
|
$3*natoms,0.d0,hessian,3*natoms)
|
|
C Diagonalize transformed Hessian
|
|
vibfreq=0.d0
|
|
call dsyev('V','U',ndeg,hessian,3*natoms,vibfreq,work,
|
|
$9*natoms**2,isyev)
|
|
if(isyev.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the diagonalization of the transformed Hessian!'
|
|
call dmrccend(1)
|
|
endif
|
|
imag=' '
|
|
do ih=1,ndeg
|
|
if(vibfreq(ih).lt.0) imag(ih)='i'
|
|
enddo
|
|
C Transform the eigenvectors back
|
|
call dgemm('n','n',3*natoms,ndeg,ndeg,1.d0,d,3*natoms,hessian,
|
|
$3*natoms,0.d0,mwhess,3*natoms)
|
|
ih=0
|
|
do iatoms=1,natoms
|
|
tmp=1.d0/dsqrt(atmass(iatoms))
|
|
do ixyz=1,3
|
|
ih=ih+1
|
|
call dscal(ndeg,tmp,mwhess(ih,1),3*natoms)
|
|
enddo
|
|
enddo
|
|
C Normalize normal modes
|
|
do ih=1,ndeg
|
|
tmp=dnrm2(3*natoms,mwhess(1,ih),1)
|
|
redmass(ih)=1.d0/tmp**2
|
|
if(tmp.gt.1d-10) call dscal(3*natoms,1.d0/tmp,mwhess(1,ih),1)
|
|
enddo
|
|
C Determine symmetry of normal modes
|
|
if(cmpgrp.ne.'C1 ') then
|
|
modesym=0
|
|
do i=1,nir
|
|
call dgemm('n','n',3,natoms*ndeg,3,1.d0,pggen(1,1,i),3,mwhess,
|
|
$3,0.d0,work,3)
|
|
do ih=1,ndeg
|
|
ii=0
|
|
do iatoms=1,natoms
|
|
jatoms=symat(iatoms,i)
|
|
if(jatoms.gt.iatoms) then
|
|
jj=(jatoms-1)*3
|
|
vec(1:3)=work(ii+1:ii+3,ih)
|
|
work(ii+1:ii+3,ih)=work(jj+1:jj+3,ih)
|
|
work(jj+1:jj+3,ih)=vec(1:3)
|
|
endif
|
|
ii=ii+3
|
|
enddo
|
|
call daxpy(3*natoms,-1.d0,mwhess(1,ih),1,work(1,ih),1)
|
|
tmp=dnrm2(3*natoms,work(1,ih),1)
|
|
if(tmp.lt.gtol*3*natoms) then
|
|
modeir(i,ih)=1
|
|
else if(2.d0-tmp.lt.gtol*3*natoms) then
|
|
modeir(i,ih)=-1
|
|
else
|
|
modeir(i,ih)=0
|
|
endif
|
|
enddo
|
|
enddo
|
|
do ih=1,ndeg
|
|
do i=1,nir
|
|
lll=.true.
|
|
do j=1,nir
|
|
lll=lll.and.modeir(j,ih).eq.chartab(j,i)
|
|
enddo
|
|
if(lll) then
|
|
modesym(ih)=i
|
|
exit
|
|
endif
|
|
enddo
|
|
enddo
|
|
endif
|
|
C Calculate intensities
|
|
allocate(dipnc(3,ndeg))
|
|
call dgemm('n','n',3,ndeg,3*natoms,1.d0,dipder,3,mwhess,
|
|
$3*natoms,0.d0,dipnc,3)
|
|
do ih=1,ndeg
|
|
grad1(ih)=ddot(3,dipnc(1,ih),1,dipnc(1,ih),1)*
|
|
$10.d0*echesu**2*navogadro**2*pi/(3.d0*clight**2)/redmass(ih)
|
|
enddo
|
|
C Print results
|
|
i=mod(ndeg,4)
|
|
nbl=(ndeg-i)/4
|
|
if(i.ne.0) nbl=nbl+1
|
|
write(iout,*)
|
|
write(iout,*)
|
|
$'Normal modes and harmonic frequencies after projection'
|
|
do ibl=1,nbl
|
|
write(iout,*)
|
|
if(cmpgrp.ne.'C1 ')
|
|
$ write(iout,"(' Symmetry: ',4(5x,a4,2x))")
|
|
$(irlab(modesym(i)),i=(ibl-1)*4+1,min(ndeg,ibl*4))
|
|
write(iout,"(' Frequency [cm-1]: ',4(f10.2,a1))") (
|
|
$fac*dsqrt(dabs(vibfreq(i))),imag(i),i=(ibl-1)*4+1,min(ndeg,ibl*4))
|
|
write(iout,"(' IR intensity [km/mol]: ',4(f10.4,1x))")
|
|
$(grad1(i),i=(ibl-1)*4+1,min(ndeg,ibl*4))
|
|
write(iout,"(' Reduced mass [AMU]: ',4(f10.4,1x))")
|
|
$(redmass(i),i=(ibl-1)*4+1,min(ndeg,ibl*4))
|
|
write(iout,"(' Force constant [mDyne/A]:',4(f10.4,1x))")
|
|
$(4.d0*pi**2*fac**2*vibfreq(i)*redmass(i)*clight**2*amutokg*1d-9,
|
|
$i=(ibl-1)*4+1,min(ndeg,ibl*4))
|
|
write(iout,*)
|
|
ih=0
|
|
do iatoms=1,natoms
|
|
do ixyz=1,3
|
|
ih=ih+1
|
|
write(iout,"(i15,1x,a2,1x,a1,5x,4f11.5)") iatoms,
|
|
$atsymbol(iatoms),xyz(ixyz),
|
|
$(mwhess(ih,i),i=(ibl-1)*4+1,min(ndeg,ibl*4))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
1234 continue
|
|
C Calculate thermodynamic proprties
|
|
call getkey('pressure',8,c16,16)
|
|
read(c16,*) i
|
|
press=dble(i)
|
|
call getkey('temp',4,c16,16)
|
|
read(c16,*) temp
|
|
C
|
|
rconst=1d-5*boltz/jtoeh
|
|
weight=0.d0
|
|
do i=1,natoms
|
|
weight=weight+atmass(i)
|
|
enddo
|
|
weight=weight*amutokg*1d-27
|
|
hckt=0.1d0*planck*clight/(boltz*temp)
|
|
write(iout,*)
|
|
write(iout,*)
|
|
write(iout,"(1x,70('*'))")
|
|
write(iout,"(' Calculating thermodynamic functions at',f7.2,
|
|
$' K and',i7,' Pa')") temp,idnint(press)
|
|
write(iout,*)
|
|
C
|
|
if(natoms.eq.1) then
|
|
erot=0.d0
|
|
evib=0.d0
|
|
qrot=1.d0
|
|
qvib=1.d0
|
|
srot=0.d0
|
|
svib=0.d0
|
|
crot=0.d0
|
|
cvib=0.d0
|
|
ezpe=0.d0
|
|
else
|
|
write(iout,*) 'The full molecular point group is ' //
|
|
$trim(pntgrp) // '.'
|
|
if(fpgrp(1).eq.'C'.and.(fpgrp(2).eq.'i'.or.
|
|
$fpgrp(2).eq.'s')) then
|
|
sigma=1 !Ci, Cs
|
|
else if(lin.and.fpgrp(1).eq.'D') then
|
|
sigma=2 !Dxh
|
|
else if(lin.and.fpgrp(1).eq.'C') then
|
|
sigma=1 !Cxh
|
|
else if(fpgrp(1).eq.'I') then
|
|
sigma=60 !I, Ih
|
|
else if(fpgrp(1).eq.'S') then
|
|
read(fpgrp(2),*) sigma
|
|
sigma=sigma/2 !Sn
|
|
else if(fpgrp(1).eq.'T') then
|
|
sigma=12 !T, Td, Th
|
|
else if(fpgrp(1).eq.'C'.and..not.lin) then
|
|
read(fpgrp(2),*) sigma !Cn, Cnv, Cnh
|
|
else if(fpgrp(1).eq.'O') then
|
|
sigma=24 !O, Oh
|
|
else if(fpgrp(1).eq.'D'.and..not.lin) then
|
|
read(fpgrp(2),*) sigma
|
|
sigma=2*sigma !Dn, Dnh, Dnh
|
|
else
|
|
write(iout,*) 'Unable to determine the symmetry number!'
|
|
call dmrccend(1)
|
|
endif
|
|
write(iout,"(' Symmetry number:',i3)") sigma
|
|
write(iout,*)
|
|
qrot=1.d0
|
|
write(iout,*) 'Rotational constant [GHz] ',
|
|
$ 'Rotational temperature [K]'
|
|
do i=1,3
|
|
if(rotconst(i).gt.0.d0) then
|
|
rottemp=1d-2*rotconst(i)*planck/boltz
|
|
write(iout,"(f18.6,f25.2)") rotconst(i),rottemp
|
|
if(lin) then
|
|
qrot=temp/rottemp
|
|
goto 7648
|
|
else
|
|
qrot=qrot*temp/rottemp
|
|
endif
|
|
endif
|
|
enddo
|
|
7648 continue
|
|
if(lin) then
|
|
qrot=qrot/dble(sigma)
|
|
srot=rconst*(dlog(qrot)+1.d0)
|
|
crot=rconst
|
|
else
|
|
qrot=dsqrt(pi*qrot)/dble(sigma)
|
|
srot=rconst*(dlog(qrot)+1.5d0)
|
|
crot=3.d0*rconst/2.d0
|
|
endif
|
|
erot=dble(nrot)*rconst*temp/2.d0
|
|
evib=0.d0
|
|
svib=0.d0
|
|
qvib=1.d0
|
|
ezpe=0.d0
|
|
cvib=0.d0
|
|
write(iout,*)
|
|
write(iout,*) 'Vibrational Vibrational Partition',
|
|
$' Contribution Contribution'
|
|
write(iout,*)
|
|
$' frequency temperature function to energy to entropy
|
|
$'
|
|
write(iout,*) ' [cm-1] [K] ',
|
|
$'[Hartree] [Hartree/K]'
|
|
do i=1,ndeg
|
|
if(vibfreq(i).gt.0.d0) then
|
|
freq=fac*dsqrt(dabs(vibfreq(i)))
|
|
write(iout,"(f10.2,f13.2,d16.6,2f14.10)")
|
|
$freq,0.1d0*planck*clight*freq/boltz,
|
|
$1.d0/(1.d0-dexp(-hckt*freq)),
|
|
$rconst*temp*hckt*freq/(dexp(hckt*freq)-1.d0),
|
|
$rconst*(hckt*freq/(dexp(hckt*freq)-1.d0)-
|
|
$dlog(1.d0-dexp(-hckt*freq)))
|
|
evib=evib+hckt*freq/(dexp(hckt*freq)-1.d0)
|
|
ezpe=ezpe+freq
|
|
svib=svib+hckt*freq/(dexp(hckt*freq)-1.d0)-
|
|
$dlog(1.d0-dexp(-hckt*freq))
|
|
qvib=qvib*1.d0/(1.d0-dexp(-hckt*freq))
|
|
cvib=cvib+
|
|
$dexp(hckt*freq)*(hckt*freq/(dexp(hckt*freq)-1.d0))**2
|
|
endif
|
|
enddo
|
|
evib=rconst*temp*evib
|
|
svib=rconst*svib
|
|
cvib=rconst*cvib
|
|
ezpe=5d-7*ezpe*clight*planck/jtoeh
|
|
endif
|
|
ctra=3.d0*rconst/2.d0
|
|
etra=ctra*temp
|
|
C
|
|
write(iout,*)
|
|
write(iout,"(' Translational contibution to Cv: ',
|
|
$T40,F20.10,' Hartree/K')") ctra
|
|
write(iout,"(' Rotational contibution to Cv: ',T40,F20.10,
|
|
$' Hartree/K')") crot
|
|
write(iout,"(' Vibrational contibution to Cv: ',T40,F20.10,
|
|
$' Hartree/K')") cvib
|
|
write(iout,"(' Total constant volume heat capacity:',T40,F20.10,
|
|
$' Hartree/K')") ctra+crot+cvib
|
|
write(iout,"(' Total constant pressure heat capacity:',
|
|
$T40,F20.10,' Hartree/K')") ctra+crot+cvib+rconst
|
|
C
|
|
write(iout,*)
|
|
write(iout,"(' Zero-point vibrational energy: ',
|
|
$T40,F20.10,' Hartree')") ezpe
|
|
write(iout,*)
|
|
write(iout,"(' Translational temperature correction: ',
|
|
$T40,F20.10,' Hartree')") etra
|
|
write(iout,"(' Rotational temperature correction: ',T40,F20.10,
|
|
$' Hartree')") erot
|
|
write(iout,"(' Vibrational temperature correction: ',T40,F20.10,
|
|
$' Hartree')") evib
|
|
eele=0.d0
|
|
write(iout,"(' Electronic temperature correction: ',T40,F20.10,
|
|
$' Hartree')") eele
|
|
etot=etra+erot+evib+eele
|
|
write(iout,"(' Total temperature correction: ',T40,F20.10,
|
|
$' Hartree')") etot
|
|
etot=etot+ezpe
|
|
C
|
|
write(iout,*)
|
|
qtra=10.d0**44.5d0*
|
|
$(2.d0*pi*weight*boltz*temp/planck**2)**1.5d0*boltz*temp/press
|
|
write(iout,"(' Translational partition function:',T40,d20.6)")
|
|
$qtra
|
|
write(iout,"(' Rotational partition function:',T40,d20.6)")qrot
|
|
write(iout,"(' Vibrational partition function:',T40,d20.6)")qvib
|
|
qele=dble(imult)
|
|
write(iout,"(' Electronic partition function: ',T40,d20.6)")qele
|
|
qtot=qtra*qrot*qvib*qele
|
|
write(iout,"(' Total partition function:',T40,d20.6)") qtot
|
|
write(iout,*)
|
|
C
|
|
stra=rconst*(dlog(qtra)+2.5d0)
|
|
write(iout,"(' Translational contribution to entropy: ',
|
|
$T40,F20.10,' Hartree/K')") stra
|
|
write(iout,"(' Rotational contribution to entropy: ',T40,F20.10,
|
|
$' Hartree/K')") srot
|
|
write(iout,"(' Vibrational contribution to entropy: ',
|
|
$T40,F20.10,' Hartree/K')") svib
|
|
sele=rconst*dlog(qele)
|
|
write(iout,"(' Electronic contribution to entropy: ',T40,F20.10,
|
|
$' Hartree/K')") sele
|
|
stot=stra+srot+svib+sele
|
|
write(iout,"(' Total entropy: ',T40,F20.10,' Hartree/K')")
|
|
$stot
|
|
C
|
|
write(iout,*)
|
|
write(iout,"(' Electronic energy: ',T40,F20.10,' Hartree')")
|
|
$tenergy
|
|
write(iout,"(' Electronic energy + ZPE: ',T40,F20.10,
|
|
$' Hartree')") tenergy+ezpe
|
|
write(iout,"(' Internal energy: ',T40,F20.10,' Hartree')")
|
|
$tenergy+etot
|
|
write(iout,"(' Enthalpy: ',T40,F20.10,' Hartree')")
|
|
$tenergy+etot+rconst*temp
|
|
write(iout,"(' Free energy: ',T40,F20.10,' Hartree')")
|
|
$tenergy+etot-temp*stot
|
|
write(iout,"(' Gibbs free energy: ',T40,F20.10,' Hartree')")
|
|
$tenergy+etot+rconst*temp-temp*stot
|
|
if(lin.and.imult.gt.1) then
|
|
write(iout,*)
|
|
write(iout,*)
|
|
$'Warning: Note that this molecule is linear and may have'
|
|
write(iout,*)
|
|
$'degenerate ground state, however, the spin-orbit splitting is'
|
|
write(iout,*)
|
|
$'considered neither at the calculation of the total energy'
|
|
write(iout,*)
|
|
$'nor at the calculation of the electronic partition function!'
|
|
endif
|
|
C
|
|
open(unit=ifcfile,file='iface',status='old',position='append')
|
|
write(ifcfile,7596)
|
|
$'Gibbs ','free energy ',1,1,imult,
|
|
$tenergy+etot+rconst*temp-temp*stot,0.d0,0.d0
|
|
close(ifcfile)
|
|
7596 format(a8,1x,a15,1x,3(i2,1x),1pe23.15,2(1pe15.8))
|
|
C Write Molden file
|
|
if(molden.ne.'off ') then
|
|
call changekey('molden',6,'on ',4)
|
|
open(moldenfile,file='MOLDEN',status='old',position='append')
|
|
write(moldenfile,"('[FREQ]')")
|
|
do i=1,ndeg
|
|
write(moldenfile,"(f20.10)") fac*dsqrt(dabs(vibfreq(i)))
|
|
enddo
|
|
write(moldenfile,"('[FR-COORD]')")
|
|
do iatoms=1,natoms
|
|
write(moldenfile,"(a2,3f20.10)")
|
|
$atsymbol(iatoms),(coord(j,iatoms),j=1,3)
|
|
enddo
|
|
write(moldenfile,"('[FR-NORM-COORD]')")
|
|
do i=1,ndeg
|
|
write(moldenfile,"('vibration',i8)") i
|
|
ih=0
|
|
do iatoms=1,natoms
|
|
write(moldenfile,"(3f20.10)") (mwhess(j,i),j=ih+1,ih+3)
|
|
ih=ih+3
|
|
enddo
|
|
enddo
|
|
write(moldenfile,"('[INT]')")
|
|
do i=1,ndeg
|
|
write(moldenfile,"(f20.10)") grad1(i)
|
|
enddo
|
|
close(moldenfile)
|
|
endif
|
|
C Deallocate memory
|
|
deallocate(atsymbol,coord,symat,grad1,grad2,lcatoms,hessian)
|
|
deallocate(atmass,dipder)
|
|
if(allocated(vibfreq)) deallocate(vibfreq)
|
|
if(allocated(work )) deallocate(work )
|
|
if(allocated(dvec )) deallocate(dvec )
|
|
if(allocated(d )) deallocate(d )
|
|
if(allocated(mwhess )) deallocate(mwhess )
|
|
if(allocated(imag )) deallocate(imag )
|
|
if(allocated(redmass)) deallocate(redmass)
|
|
if(allocated(modesym)) deallocate(modesym)
|
|
if(allocated(modeir )) deallocate(modeir )
|
|
if(allocated(dipnc )) deallocate(dipnc )
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine num_grad(iout,minpfile,scrfile)
|
|
************************************************************************
|
|
* Calculating numerical gradient
|
|
************************************************************************
|
|
use optim, only: get_last_energy
|
|
implicit none
|
|
integer iout,minpfile,scrfile
|
|
|
|
integer natoms,num_stencil_points,xyz,isp,iatoms,i
|
|
double precision, allocatable :: coord(:,:),coord_new(:,:)
|
|
double precision, allocatable :: grad(:,:),grad_anal(:,:)
|
|
double precision, allocatable :: stencil_points(:),coefs(:)
|
|
double precision sp,step,energy,mean_error,max_error,rms
|
|
character(len=2), allocatable :: atsymbol(:)
|
|
character*4 geom,cgrad
|
|
|
|
call ishell('cp MINP MINP.init')
|
|
|
|
call getvar('natoms ',natoms)
|
|
allocate(coord(3,natoms))
|
|
allocate(atsymbol(natoms))
|
|
call getvar_c('atsymbol ',atsymbol)
|
|
call getvar('coord ',coord)
|
|
call getkey('geom',4,geom,4)
|
|
call changekey('unit',4,'bohr',4)
|
|
|
|
call getkey('dens',4,cgrad,4)
|
|
if(cgrad.eq.'2 ') then
|
|
allocate(grad_anal(3,natoms))
|
|
open(scrfile,file='GRAD',status='old',form='unformatted')
|
|
do i=1,natoms
|
|
read(scrfile) grad_anal(1,i),grad_anal(2,i),grad_anal(3,i)
|
|
enddo
|
|
close(scrfile)
|
|
endif
|
|
|
|
call changekey('dens',4,'0 ',4)
|
|
|
|
call minp_save(minpfile,scrfile,natoms,geom)
|
|
|
|
num_stencil_points=4
|
|
step=0.01d0
|
|
allocate(stencil_points(num_stencil_points))
|
|
allocate(coefs(num_stencil_points))
|
|
call setup_stencil(num_stencil_points,stencil_points,coefs)
|
|
|
|
allocate(coord_new(3,natoms))
|
|
allocate(grad(3,natoms))
|
|
grad=0.0d0
|
|
do iatoms=1,natoms
|
|
do xyz=1,3
|
|
do isp=1,num_stencil_points
|
|
sp=stencil_points(isp)
|
|
call dcopy(3*natoms,coord,1,coord_new,1)
|
|
coord_new(xyz,iatoms)=coord_new(xyz,iatoms)+sp*step
|
|
call build_minp(minpfile,scrfile,atsymbol,coord_new,natoms)
|
|
call spoint(.true.)
|
|
energy=get_last_energy()
|
|
grad(xyz,iatoms)=grad(xyz,iatoms)+coefs(isp)*energy
|
|
enddo
|
|
grad(xyz,iatoms)=grad(xyz,iatoms)/step
|
|
enddo
|
|
enddo
|
|
|
|
write(iout,*)
|
|
write(iout,"(1x,70('*'))")
|
|
write(iout,*)
|
|
write(iout,*) 'Numerical Cartesian gradient [au]:'
|
|
write(iout,
|
|
$"(' x y z')")
|
|
do iatoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') iatoms,atsymbol(iatoms),
|
|
$ grad(1,iatoms),grad(2,iatoms),grad(3,iatoms)
|
|
enddo
|
|
|
|
if(cgrad.eq.'2 ') then
|
|
write(iout,*)
|
|
write(iout,*) 'Analytical Cartesian gradient [au]:'
|
|
do iatoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') iatoms,atsymbol(iatoms),
|
|
$ grad_anal(1,iatoms),grad_anal(2,iatoms),grad_anal(3,iatoms)
|
|
enddo
|
|
call daxpy(3*natoms,-1.0d0,grad,1,grad_anal,1)
|
|
write(iout,*)
|
|
write(iout,*) 'Cartesian gradient difference [au]:'
|
|
do iatoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') iatoms,atsymbol(iatoms),
|
|
$ grad_anal(1,iatoms),grad_anal(2,iatoms),grad_anal(3,iatoms)
|
|
do xyz=1,3
|
|
mean_error=mean_error+dabs(grad_anal(xyz,iatoms))
|
|
max_error=max(max_error,dabs(grad_anal(xyz,iatoms)))
|
|
rms=rms+dabs(grad_anal(xyz,iatoms))**2.0d0
|
|
enddo
|
|
enddo
|
|
mean_error=mean_error/dble(3*natoms)
|
|
rms=dsqrt(rms/dble(3*natoms))
|
|
write(iout,*)
|
|
write(iout,'(1X,A,ES16.8)') 'Max error [au]: ',max_error
|
|
write(iout,'(1X,A,ES16.8)') 'MAE error [au]: ',mean_error
|
|
write(iout,'(1X,A,ES16.8)') 'RMS error [au]: ',rms
|
|
endif
|
|
|
|
call ishell('cp MINP.init MINP')
|
|
|
|
deallocate(coord)
|
|
deallocate(coord_new)
|
|
deallocate(grad)
|
|
deallocate(stencil_points)
|
|
deallocate(coefs)
|
|
deallocate(atsymbol)
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine setup_stencil(npoints,points,coefs)
|
|
************************************************************************
|
|
* Setting up stencil points and coefficients
|
|
************************************************************************
|
|
implicit none
|
|
integer npoints
|
|
double precision points(npoints),coefs(npoints)
|
|
|
|
if(npoints == 2) then
|
|
c Central difference
|
|
points(1)=1.0d0
|
|
coefs(1)=0.5d0
|
|
points(2)=-1.0d0
|
|
coefs(2)=-0.5d0
|
|
elseif(npoints == 4) then
|
|
c five-point stencil
|
|
points(1)=2.0d0
|
|
points(2)=1.0d0
|
|
points(3)=-1.0d0
|
|
points(4)=-2.0d0
|
|
coefs(1)=-1.0d0/12.0d0
|
|
coefs(2)=8.0d0/12.0d0
|
|
coefs(3)=-8.0d0/12.0d0
|
|
coefs(4)=1.0d0/12.0d0
|
|
c Put other stencils here
|
|
endif
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine build_minp(minpfile,scrfile,atsymbol,coord,natoms)
|
|
************************************************************************
|
|
* Building MINP file from MINP.footer, MINP.header and a geometry
|
|
************************************************************************
|
|
integer minpfile,scrfile,natoms
|
|
double precision coord(3,natoms)
|
|
character(len=2) atsymbol(natoms)
|
|
|
|
open(minpfile,file='MINP')
|
|
call build_minp_(minpfile,scrfile,'MINP.header ')
|
|
call write_geom(minpfile,atsymbol,coord,natoms)
|
|
call build_minp_(minpfile,scrfile,'MINP.footer ')
|
|
close(minpfile)
|
|
|
|
contains
|
|
|
|
subroutine build_minp_(minpfile,scrfile,filename)
|
|
integer minpfile,scrfile,l,check
|
|
character*16 filename
|
|
character*512 line
|
|
|
|
open(scrfile,file=trim(filename))
|
|
read(scrfile,'(a512)',iostat=check) line
|
|
do while(check.eq.0)
|
|
l = len_trim(line)
|
|
write(minpfile,'(a)') line(1:l)
|
|
read(scrfile,'(a512)',iostat=check) line
|
|
enddo
|
|
close(scrfile)
|
|
end subroutine
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine minp_save(minpfile,scrfile,natoms,geom)
|
|
************************************************************************
|
|
* Saving MINP file to MINP.header and MINP.footer
|
|
************************************************************************
|
|
implicit none
|
|
integer minpfile,scrfile,natoms
|
|
character*4 geom
|
|
character*512 line
|
|
|
|
open(minpfile,file='MINP')
|
|
rewind(minpfile)
|
|
c saving MINP content before the geometry
|
|
call minp_save_(minpfile,scrfile,'MINP.header ')
|
|
c skipping geometry
|
|
call skip_geom(minpfile,geom,natoms)
|
|
c saving MINP content after the geometry
|
|
call minp_save_(minpfile,scrfile,'MINP.footer ')
|
|
close(minpfile)
|
|
contains
|
|
|
|
subroutine minp_save_(minpfile,scrfile,filename)
|
|
implicit none
|
|
integer minpfile,scrfile,l,check
|
|
character*16 filename
|
|
character*512 line,geom
|
|
|
|
open(scrfile,file=trim(filename))
|
|
read(minpfile,'(a512)',iostat=check) line
|
|
geom=adjustl(trim(line))
|
|
do while(check.eq.0 .and. geom(1:4).ne.'geom')
|
|
l = len_trim(geom)
|
|
write(scrfile,'(a)') geom(1:l)
|
|
read(minpfile,'(a512)',iostat=check) line
|
|
geom=adjustl(trim(line))
|
|
enddo
|
|
close(scrfile)
|
|
|
|
end subroutine
|
|
|
|
subroutine skip_geom(minpfile,geom,natoms)
|
|
integer minpfile,natoms,i,imax
|
|
character*4 geom
|
|
|
|
if(geom.eq.'xyz ') then
|
|
imax=natoms+2
|
|
elseif(geom.eq.'zmat') then
|
|
imax=natoms
|
|
endif
|
|
|
|
do i=1,imax
|
|
read(minpfile,*)
|
|
enddo
|
|
end subroutine
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine write_geom(minpfile,atsymbol,coord,natoms)
|
|
************************************************************************
|
|
* writing molecular geometry to minpfile
|
|
************************************************************************
|
|
implicit none
|
|
integer minpfile,natoms,iatoms,i
|
|
double precision coord(3,natoms)
|
|
character(len=2) atsymbol(natoms)
|
|
|
|
write(minpfile,'(a)') 'unit=bohr'
|
|
write(minpfile,'(a)') 'geom=xyz'
|
|
write(minpfile,*) natoms
|
|
write(minpfile,*)
|
|
do iatoms=1,natoms
|
|
write(minpfile,"(a3,3f22.14)") atsymbol(iatoms),
|
|
$ (coord(i,iatoms),i=1,3)
|
|
enddo
|
|
|
|
end subroutine
|