PROGRAM GNMRCONF implicit integer*4 (i-n) implicit real*8 (a-h,o-z) parameter (NTY0=100) parameter (nat0=3000) DIMENSION NG(NTY0),NA(NTY0,10),st(NTY0),ash(NTY0),rsh(NTY0), 1ave(NTY0),avedev(NTY0) CHARACTER*50 ff CHARACTER*4 s4 CHARACTER*8 lb(NTY0) CHARACTER*80 fn logical ltensor,lgeo real*8 r(3,nat0),sig(3,3) integer*4 iz(nat0) c c extract gaussian nmr data c NCO number of conformations/molecules c NTY number of shifts to be extracted, each can include more c chemically equivalent atoms c read whole tensor, write to SIGMA.TEN: ltensor=.false. c read geometry, write to FILE.X: lgeo=.false. open(2,file='GNMR.OPT') 1 read(2,200,end=999,err=999)s4 200 format(a4) if(s4(1:3).eq.'TEN')read(2,*)ltensor if(s4(1:3).eq.'GEO')read(2,*)lgeo if(s4(1:3).eq.'NCO')read(2,*)NCO if(s4(1:3).eq.'NTY')then read(2,*)NTY if(NTY.gt.NTY0)call report('Too many shifts.') do 3 i=1,NTY read(2,2001)lb(i) 2001 format(a8) c number of same atoms, their list, standard shift: 3 read(2,*)NG(i),(NA(i,j),j=1,NG(i)),st(i) endif goto 1 999 close(2) open(3,file='NAMES.LST') open(8,file='NMR.TAB') if(ltensor)open(10,file='SIGMA.TEN') if(lgeo )open(11,file='FILE.X' ) write(8,8002)(lb(i),i=1,NTY) 8002 format(4x,1000(a10)) do 2 ic=1,NCO read(3,3000)fn 3000 format(a80) iwg=0 IA=0 do 4 is=1,NTY 4 ash(is)=0.0d0 open(2,file=fn) 5 READ(2,2002,END=1000)ff 2002 FORMAT(A50) IF(lgeo)then IF(ff(19:39).EQ.'Z-Matrix orientation:'.OR. 1 ff(26:46).EQ.'Z-Matrix orientation:'.OR. 1 ff(20:37).EQ.'Input orientation:'.OR. 1 ff(27:44).EQ.'Input orientation:'.OR. 2 ff(20:40).EQ.'Standard orientation:'.OR. 2 ff(26:46).EQ.'Standard orientation:'.OR. 1 ff(26:46).EQ.'Z-Matrix orientation:'.OR. 1 ff(27:44).EQ.'Input orientation:'.OR. 1 ff(26:46).EQ.'Standard orientation:') 1 call rdg(2,r,iz,nat,nat0) endif IF(ff(11:21).EQ.'Isotropic =')then c write the last geometry when sigma is found: if(lgeo.and.iwg.eq.0)then call wrg(11,r,iz,fn,nat0,nat) iwg=1 endif IA=IA+1 read(ff(22:32),*)sia do 6 is=1,NTY do 6 ii=1,NG(is) 6 if(NA(is,ii).eq.IA)ash(is)=ash(is)+sia if(ltensor)then call rds( 2,sig) call wrs(10,sig,fn) endif ENDIF GOTO 5 1000 CLOSE(2) do 7 is=1,NTY ash(is)=ash(is)/dble(NG(is)) 7 rsh(is)=st(is)-ash(is) c write(8,8000)ic,(ash(i),rsh(i),i=1,NTY) write(8,8000)ic,(rsh(i),i=1,NTY) 8000 format(i4,1000f10.4) 2 continue close(3) if(ltensor)close(10) if(lgeo)close(11) rewind 8 read(8,*) do 9 i=1,NTY 9 ave(i)=0.0d0 do 8 i=1,NCO read(8,*)rsh(1),(rsh(j),j=1,NTY) do 8 j=1,NTY 8 ave(j)=ave(j)+rsh(j) do 10 j=1,NTY 10 ave(j)=ave(j)/dble(NCO) rewind 8 read(8,*) do 11 i=1,NTY 11 avedev(i)=0.0d0 do 12 i=1,NCO read(8,*)rsh(1),(rsh(j),j=1,NTY) do 12 j=1,NTY 12 avedev(j)=avedev(j)+(rsh(j)-ave(j))**2 do 13 j=1,NTY 13 avedev(j)=dsqrt(avedev(j)/dble(NCO)) write(8,*) write(8,8000)ic,(ave(i),i=1,NTY) write(8,8000)ic,(avedev(i),i=1,NTY) write(8,8000)ic,(avedev(i)/dsqrt(dble(NCO)),i=1,NTY) close(8) STOP END subroutine report(s) character*(*) s write(6,*)s stop end subroutine rds(io,s) implicit none character*80 s80 real*8 s(3,3) integer ix,io do 1 ix=1,3 read(io,80)s80 80 format(a80) read(s80( 7:17),*)s(ix,1) read(s80(24:34),*)s(ix,2) 1 read(s80(41:51),*)s(ix,3) return end subroutine wrs(io,s,fn) implicit none character*80 fn real*8 s(3,3) integer ix,io write(io,90)fn 90 format(a80) do 1 ix=1,3 1 write(io,100)s(ix,1),s(ix,2),s(ix,3) 100 format(3f11.4) return end subroutine rdg(io,r,iz,nat,nat0) implicit none integer*4 io,iz(*),nat,nat0,i,l real*8 r(3,nat0) character*10 FN DO 4 i=1,4 4 READ(2,*) l=0 5 READ(io,2000)FN 2000 format(a10) IF(FN(2:4).NE.'---')THEN l=l+1 if(l.gt.nat0)then write(6,*)'too many atoms' stop endif BACKSPACE 2 READ(io,*)r(1,l),iz(l),r(1,l),(r(i,l),i=1,3) GOTO 5 ENDIF nat=l return END subroutine wrg(io,r,iz,fn,nat0,nat) implicit none integer*4 io,iz(*),nat,nat0,i,l real*8 r(3,nat0) character*80 fn write(io,2000)FN 2000 format(a80) write(io,2001)nat 2001 format(i6,3f12.6) do 1 l=1,nat 1 write(io,2001)iz(l),(r(i,l),i=1,3) return END