PROGRAM GGOPT implicit real*8(a-h,o-z) implicit integer*4 (i-n) parameter (nat0=1000,nag0=10) DIMENSION r(3,nat0),iz(nat0) CHARACTER*50 FIL CHARACTER*80 FN,ES LOGICAL lzmat,auto,lno CHARACTER*1 OK,oo real*8 XX(3),YY(3),A(3),P(3),E0(3),SSE0E0,SSPP,AD, 1SSAE0,SSPE0,SSXXXX,SSYYYY,SSXXYY,APX,APY,APZ,SIGN, 2CB,CA,BANGLE,ANGLE,PI,SSE0AP dimension itypep(nag0),L0p(nag0),L1p(nag0),L2p(nag0),L3p(nag0) logical lex CHARACTER*10 fnp(nag0) CHARACTER*45 rcs nat=0 inquire(file='AUTO',exist=auto) lno=.true. oo='n' if(auto)then FIL='G98.OUT' lzmat=.true. else if(iargc().eq.2)then call getarg(1,FIL) call getarg(2,OK) else WRITE(*,*)' Full filename of the Gaussian output:' READ(*,'(A)')FIL WRITE(*,*)' Use the Z-matrix or standard orientation (Z/S) ?' READ(*,'(A)')OK endif lzmat=.true. if(ok.eq.'s'.or.ok.eq.'S')lzmat=.false. endif inquire(file='LIST.PAR',exist=lex) if(lex)then write(6,*)'LIST.PAR found' open(45,file='LIST.PAR') open(51,file='LIST.TXT') write(6,*)' Appending LIST.TXT' 78781 read(51,*,end=858,err=858) goto 78781 858 iout=45 read(45,*)nag if(nag.gt.nag0)then write(6,*)'Too many parameters' stop endif do 21 iag=1,nag iout=iout+1 read(45,4500)fnp(iag) write(6,4500)fnp(iag) 4500 format(a10) read(45,*)itypep(iag),L0p(iag),L1p(iag),L2p(iag),L3p(iag) 21 write(6,6005)itypep(iag),L0p(iag),L1p(iag),L2p(iag),L3p(iag) 6005 format(5i6) close(45) endif OPEN(2,FILE=FIL) call foo(29,'RC.TXT') call foo(4,'FILE.x') NG=0 iopt=0 1 READ(2,2000,END=1000)FN 2000 FORMAT(A80) if(FN(1:9).eq.' SCF Done')then ES=FN do istart=1,50 if(FN(istart:istart).eq.'=')goto 2009 enddo 2009 iend=istart+1+17 if(iend.gt.80)iend=80 ieer=1 read(FN(istart+1:iend),*,err=2010)energy ieer=0 2010 continue endif if(FN(1:9).eq.' Energy= ')then ES=FN ieer=1 ieer=0 2011 continue endif if(FN(28:34).eq.'EUMP2 =')then ES=FN ieer=1 read(FN(35:80),*,err=2013)energy ieer=0 2013 continue endif if(FN(35:45).eq.'UMP4(SDTQ)=')then ES(1:50)=FN(31:80) ieer=1 read(FN(46:80),*,err=2012)energy write(6,*)energy ieer=0 2012 continue endif iy=0 iny=0 do iyy=1,28 if(FN(iyy:iyy+22).eq.'! Optimized Parameter')iy=1 if(FN(iyy:iyy+22).eq.'! Non-Optimized Paramet')iny=1 enddo if(iny.eq.1.and.lno)then write(6,6500) 6500 format(' Count "Non-Optimized" structure (n,y,a)? ',$) read(5,'(a)')oo if(oo.eq.'a')lno=.false. endif if(iy.eq.1.or.(iny.eq.1.and.(oo.eq.'y'.or.oo.eq.'a')))then iopt=iopt+1 write(4,4400)FIL(1:20)//ES(1:60) if(.not.auto)write(6,4400)FIL(1:20)//ES(1:60) write(6,*)energy 4400 format(A80) write(4,*)nat do 34 l=1,nat 34 if(iz(l).gt.0)write(4,4000)iz(l),(r(i,l),i=1,3),(0,i=1,7),0.0d0 4000 format(I3,3F12.6,7(1x,i1),f4.1) write(29,291)rcs 291 format(a45) if(lex)then do 221 iag=1,nag itype=itypep(iag) L0=L0p(iag) L1=L1p(iag) L2=L2p(iag) L3=L3p(iag) iout=51 PI=3.141592653589D0 A(1)=r(1,L2)-r(1,L3) A(2)=r(2,L2)-r(2,L3) A(3)=r(3,L2)-r(3,L3) P(1)=r(1,L0)-r(1,L1) P(2)=r(2,L0)-r(2,L1) P(3)=r(3,L0)-r(3,L1) E0(1)=r(1,L1)-r(1,L2) E0(2)=r(2,L1)-r(2,L2) E0(3)=r(3,L1)-r(3,L2) SSE0E0=E0(1)*E0(1)+E0(2)*E0(2)+E0(3)*E0(3) DO 8 KK=1,3 8 E0(KK)=E0(KK)/DSQRT(SSE0E0) SSPP=P(1)*P(1)+P(2)*P(2)+P(3)*P(3) AD=DSQRT(SSPP) SSAE0=A(1)*E0(1)+A(2)*E0(2)+A(3)*E0(3) SSPE0=P(1)*E0(1)+P(2)*E0(2)+P(3)*E0(3) DO 9 KK=1,3 XX(KK)=A(KK)-E0(KK)*SSAE0 9 YY(KK)=P(KK)-E0(KK)*SSPE0 SSXXXX=XX(1)*XX(1)+XX(2)*XX(2)+XX(3)*XX(3) SSYYYY=YY(1)*YY(1)+YY(2)*YY(2)+YY(3)*YY(3) SSXXYY=XX(1)*YY(1)+XX(2)*YY(2)+XX(3)*YY(3) APX=XX(2)*YY(3)-XX(3)*YY(2) APY=XX(3)*YY(1)-XX(1)*YY(3) APZ=XX(1)*YY(2)-XX(2)*YY(1) SSE0AP=APX*E0(1)+APY*E0(2)+APZ*E0(3) SIGN=1.0D0 IF (SSE0AP.NE.0.0D0)SIGN=-SSE0AP/ABS(SSE0AP) CB=0.0D0 IF (AD.NE.0.0D0)CB=-SSPE0/AD CA=0.0D0 IF (SSXXXX.NE.0.0D0.AND.SSYYYY.NE.0.0D0) 1 CA=-SSXXYY/DSQRT(SSXXXX)/DSQRT(SSYYYY) BANGLE=0.0D0 ANGLE=0.0D0 IF (CB.EQ.-1.0D0)BANGLE=PI IF (ABS(CB).LT.1.0D0)BANGLE=ACOS(CB) IF (CA.LE.-1.0D0) ANGLE=PI IF (ABS(CA).LT.1.0D0) ANGLE=ACOS(CA) ANGLE=180.0D0* ANGLE/PI BANGLE=180.0D0*BANGLE/PI ANGLE=SIGN*ANGLE if(ANGLE.lt.-180.0d0)ANGLE=360.0d0+ANGLE c torsion, distance, band angle if(itype.eq.2)WRITE(iout,322)AD if(itype.eq.3)WRITE(iout,322)BANGLE 221 if(itype.eq.4)WRITE(iout,322)ANGLE 322 format(f15.6,$) if(ieer.eq.0)then WRITE(iout,3221)energy 3221 format(f20.8) else WRITE(iout,3222)ES(20:80) 3222 format(a20) endif endif endif IF((lzmat.and.(FN(19:39).EQ.'Z-Matrix orientation:'.OR. 1 FN(26:46).EQ.'Z-Matrix orientation:'.OR. 1 FN(20:37).EQ.'Input orientation:'.OR. 1 FN(27:44).EQ.'Input orientation:')) 1 .OR. 1 ((.not.lzmat).and. 2 (FN(20:40).EQ.'Standard orientation:'.OR. 2 FN(26:46).EQ.'Standard orientation:')))THEN NG=NG+1 ig98=0 if(FN(26:46).EQ.'Z-Matrix orientation:'.OR. 1 FN(27:44).EQ.'Input orientation:'.OR. 1 FN(26:46).EQ.'Standard orientation:')ig98=1 DO 4 I=1,4 4 READ(2,*) l=0 5 READ(2,2000)FN IF(FN(2:4).NE.'---')THEN l=l+1 BACKSPACE 2 if(ig98.eq.0)then READ(2,*)IAdumm,KA,(r(i,l),i=1,3) else READ(2,*)IAdumm,KA,IA98dumm,(r(i,l),i=1,3) endif iz(l)=KA IF(KA.EQ.-1)l=l-1 3000 FORMAT(I5,3F12.6,' 0 0 0 0 0.0') GOTO 5 ENDIF nat=l ENDIF IF(FN(2:13).EQ.'Rotational c')rcs=FN(29:73) GOTO 1 1000 CLOSE(2) close(29) if(lex)close(51) if(.not.auto)then if(ng.eq.0)then write(*,*)'Geometry not found' else WRITE(*,*)' File FILE.X written' write(*,*)ng,' geometries found' write(*,*)iopt,' optimized' write(*,*)nat,' atoms' endif endif STOP END subroutine foo(io,f) logical lex integer*4 io character*(*) f inquire(file=f,exist=lex) if(lex)then OPEN(4,FILE=f,status='old',access='append') write(6,*)'Appending '//f else OPEN(4,FILE=f) write(6,*)'Opening '//f endif return end