program convg c extracts Gaussian normal mode cubic and quartic constants into c CQQ.TXT.SCR and DQQ,TXT,SCR IMPLICIT none real*8 CM,a,cqcm,dqcm character*80 s80 logical l2,lram,lroa,labs,lds,lspec integer*4 i,M,N,j,k,l,i1,j1,k1,n3,n4,n7,ifb,io,nb,ic,id, 1nt real*8,allocatable:: e(:),C(:),D(:),wh(:),ds(:), 1ram180(:),roa180(:) c CM=219470.0d0 l2=.false. labs=.false. lds=.false. lram=.false. lroa=.false. lspec=.false. M=0 n3=0 n4=0 ifb=0 io=0 nb=0 ic=0 id=0 nt=0 4 open(9,file='G.OUT',status='old') 1 read(9,900,end=999,err=999)s80 900 format(a80) if(s80(9:49).eq.'QUADRATIC FORCE CONSTANTS IN NORMAL MODES')then call s8 if(.not.l2)then l2=.true. 3 read(9,*,end=88,err=88)a,a,a M=M+1 goto 3 88 close(9) write(6,*)M,' modes ' if(M.gt.0)then allocate(e(M),C(M**3),D(M**3)) do 5 i=1,M 5 e(i)=0.0d0 do 6 i=1,M**3 C(i)=0.0d0 6 D(i)=0.0d0 goto 4 endif stop else do 7 i=1,M read(9,*)e(i),e(i),e(i) 7 e(i)=e(i)/CM endif endif if(s80(11:41).eq.'CUBIC FORCE CONSTANTS IN NORMAL'.and.l2)then call s8 9 read(9,*,end=77,err=77)i,j,k,a c(i+M*(j-1)+M**2*(k-1))=a c(i+M*(k-1)+M**2*(j-1))=a c(j+M*(k-1)+M**2*(i-1))=a c(j+M*(i-1)+M**2*(k-1))=a c(k+M*(i-1)+M**2*(j-1))=a c(k+M*(j-1)+M**2*(i-1))=a n3=n3+1 goto 9 77 write(6,*)n3,' cubic constants ' if(n3.gt.0)then N=M+6 N7=7 open(23,file='CQQ.SCR.TXT') do 64 i=N7,N i1=M-i+7 do 64 j=i,N j1=M-j+7 do 64 k=j,N k1=M-k+7 cqcm=c(i1+M*(j1-1)+M**2*(k1-1)) if(abs(cqcm).eq.0.0d0)goto 64 write(23,2423)I,J,K,cqcm/CM,cqcm 2423 format(3I5,G16.8,' ',F9.1) 64 continue close(23) endif endif if(s80(10:42).eq.'QUARTIC FORCE CONSTANTS IN NORMAL'.and.l2)then call s8 11 read(9,*,end=66,err=66)i,j,k,l,a if(i.eq.j)then i1=i j1=k k1=l else if(i.eq.k)then i1=i j1=j k1=l else if(i.eq.l)then i1=i j1=j k1=k else if(j.eq.k)then i1=j j1=i k1=l else if(j.eq.l)then i1=j j1=i k1=k else if(k.eq.l)then i1=k j1=i k1=j else write(6,*)i,j,k,l,' general quartic not implemented' stop endif endif endif endif endif endif d(i1+M*(j1-1)+M**2*(k1-1))=a d(i1+M*(k1-1)+M**2*(j1-1))=a n4=n4+1 goto 11 66 write(6,*)n4,' quartic constants' if(n4.gt.0)then N=M+6 N7=7 open(23,file='DQQ.SCR.TXT') do 621 i=n7,n i1=M-i+7 do 621 j=n7,n j1=M-j+7 do 621 k=j,n k1=M-k+7 dqcm=d(i1+M*(j1-1)+M**2*(k1-1)) if(abs(dqcm).eq.0.0d0)goto 621 write(23,5333)I,J,K,dqcm/CM,dqcm 5333 format(3I6,G16.8,' ',f9.1) 621 continue close(23) endif endif if(s80(15:46).eq.'Anharmonic Infrared Spectroscopy')then write(6,900)s80 labs=.true. endif if(s80(12:50).eq.'Anharmonic Raman Spectroscopy (Dynamic)')then write(6,900)s80 labs=.false. lram=.true. lroa=.false. id=0 nt=0 endif if(s80(14:46).eq.'Anharmonic Raman Optical Activity')then write(6,900)s80 labs=.false. lram=.false. lroa=.true. id=0 nb=0 endif if(labs.and.s80(9:32).eq.'Dipole strengths (DS) in')then write(6,900)s80 lds=.true. open(11,file='ABS.TXT.SCR') endif if(s80(17:37).eq.'INFORMATION: SCP(90)z')then id =0 nt=0 if(lroa.or.lram)then write(6,900)s80 if(lram)open(11,file='RAM.SCP90z.TXT.SCR') if(lroa)open(11,file='ROA.SCP90z.TXT.SCR') endif endif if(s80(17:37).eq.'INFORMATION: SCP(180)')then id =0 nt=0 if(lroa.or.lram)then write(6,900)s80 close(11) if(lram)open(11,file='RAM.SCP180.TXT.SCR') if(lroa)open(11,file='ROA.SCP180.TXT.SCR') endif endif if(s80(17:39).eq.'INFORMATION: DCP_I(180)')then id =1 nt=0 if(lroa.or.lram)then write(6,900)s80 close(11) if(lroa)open(11,file='ROA.DCPI.TXT.SCR') if(lram)open(11,file='RAM.DCPI.TXT.SCR') endif endif lspec=lroa.or.lram.or.lds if(lspec)then IF(s80(2:18).eq.'Fundamental Bands'.or. 1 s80(2:10).eq.'Overtones'.or. 2 s80(2:18).eq.'Combination Bands')THEN read(9,*) read(9,*) nb=0 if(s80(2:18).eq.'Fundamental Bands')ifb=1 if(s80(2:10).eq.'Overtones')io=1 if(s80(2:18).eq.'Combination Bands')ic=1 goto 1 ENDIF IF(ifb.eq.1.or.io.eq.1.or.ic.eq.1)THEN if(s80(10:13).eq.') ')then write(11,900)s80 nb=nb+1 nt=nt+1 else if(ifb.eq.1)then write(6,*)nb,' fundamental modes' ifb=0 endif if(io.eq.1)then write(6,*)nb,' overtones' io=0 endif if(ic.eq.1)then write(6,*)nb,' combination bands, ',nt,' total' ic=0 if(lds)then close(11) allocate(wh(nt),ds(nt)) call suck('ABS.TXT.SCR',nt,25,36,wh) call suck('ABS.TXT.SCR',nt,48,63,ds) do 201 i=1,nt 201 ds(i)=ds(i)*1.0d-4 call dt('DH.TAB',nt,wh,ds,ds) call suck('ABS.TXT.SCR',nt,38,47,wh) call suck('ABS.TXT.SCR',nt,64,79,ds) do 202 i=1,nt 202 ds(i)=ds(i)*1.0d-4 call dt('DAH.TAB',nt,wh,ds,ds) lds=.false. labs=.false. deallocate(wh,ds) endif if(id.eq.1)then if(lram)lram=.false. if(lroa.and.id.eq.1)then lroa=.false. close(11) allocate(wh(nt),ram180(nt),roa180(nt)) call suck('RAM.SCP180.TXT.SCR',nt,25,36,wh) call suck('RAM.SCP180.TXT.SCR',nt,48,63,ram180) call suck('ROA.SCP180.TXT.SCR',nt,48,63,roa180) do 203 i=1,nt roa180(i)=roa180(i)*wh(i)*0.05932d0 203 ram180(i)=ram180(i)*wh(i)*0.05932d0 call dr('ROAH.TAB',nt,wh,ram180,roa180) call suck('RAM.SCP180.TXT.SCR',nt,38,47,wh) call suck('RAM.SCP180.TXT.SCR',nt,64,79,ram180) call suck('ROA.SCP180.TXT.SCR',nt,64,79,roa180) do 204 i=1,nt roa180(i)=roa180(i)*wh(i)*0.05932d0 204 ram180(i)=ram180(i)*wh(i)*0.05932d0 call dr('ROAAH.TAB',nt,wh,ram180,roa180) endif endif endif endif ENDIF endif goto 1 999 close(9) END subroutine s8 do 2 i=1,8 2 read(9,*) return end subroutine report(s) character*(*) s write(6,*)s stop end subroutine suck(s,N,i,j,x) implicit none character*(*) s integer*4 N,i,j,k,l,ic real*8 x(*) character*80 s80 open(11,file=s) do 1 k=1,N read(11,100)s80 100 format(a80) ic=0 do 2 l=i,j 2 if(s80(l:l).ne.' ')ic=ic+1 if(ic.eq.0)s80(j:j)='0' 1 read(s80(i:j),*)x(k) close(11) return end subroutine dt(s,N,w,d,r) implicit none character*(*) s integer*4 N,I real*8 w(*),d(*),r(*),pi,po pi=4.0d0*atan(1.0d0) po=dsqrt(2.0d0*pi) open(18,file=s) WRITE (18,501) 501 FORMAT (/,' FREQ. ', 1' D [D^2] ',' R [D^-2]DO R - CO I[km/mol]', 2/,'-----------------------------------------------------------') DO 412 I=1,N 412 WRITE (18,523) I,w(I),d(I),r(I),r(I),po*w(I)*d(I) 523 FORMAT(I5,f16.3,4G15.6) WRITE(18,1819) 1819 FORMAT('-------------------------------------------------') CLOSE(18) write(6,*)s//' written' return end subroutine dr(s,N,w,d,r) implicit none character*(*) s integer*4 N,I real*8 w(*),d(*),r(*),YDX,YDY,CID2,CID1,P1,DX,roa1,doc,roa3, 1ram open(4,file=s) WRITE(4,3304) 3304 FORMAT( 1'MODE FREQ Ramx (180) Ramy Ramtot CID90', 2' CID-X CID180 DEP ROA180 RamanDCPI',/, 3' cm-1 A^4/AMU x10^4', 4' x10^4 x10^4 A^5/AMUx1e4 au.10^4', 5/80(1H-)) do 1 I=1,N YDX=d(I) YDY=d(I) ram=d(I) CID2=0.0d0 CID1=0.0d0 P1=1.0d0 DX=0.0d0 roa1=r(I) doc=r(I) roa3=r(I) 1 WRITE(4,3000)I,w(I),YDX,YDY,ram,CID2,DX,CID1,P1,roa1,doc,roa3 3000 FORMAT(I5,f9.2,6g12.3,f6.3,4g12.4) WRITE(4,1819) 1819 FORMAT('-------------------------------------------------') CLOSE(4) write(6,*)s//' written' RETURN END