program gadf c extracts adf outputs - > Exc. spectra and other things implicit none integer*4 nnuc,N,i,ie,n0,ia,ix,iargc,nt,isqrt,j,nat character*80 FIL,s80 parameter (n0=200) real*8 en,e(n0),b(n0),d(n0),o1 logical lin(10) real*8,allocatable::a(:,:,:),p(:,:,:),f(:,:),w(:),s(:,:),r(:,:) integer*4,allocatable::iz(:) lin=.false. ie=0 N=0 nat=0 nnuc=0 if(iargc().eq.0)then write(6,*)' Usage: gadf ' stop else call getarg(1,FIL) open(9,file=FIL) 1 read(9,80,end=99,err=99)s80 80 format(a80) if(s80(2:25).eq.'Excitation energies E in')then read(9,*) read(9,*) read(9,*) read(9,*) 2 read(9,*,err=88,end=88)en,en ie=ie+1 if(ie.gt.n0)then write(6,*)'too many energies' stop endif e(ie)=en goto 2 88 write(6,*)ie,' energies' goto 1 endif if(s80(18:31).eq.'MCD Parameters')then do 3 i=1,7 3 read(9,*) do 4 i=1,ie read(9,80)s80 4 read(s80(7:len(s80)),*)b(i),b(i),d(i),d(i) write(6,*)' MCD parameters read' goto 99 endif if(s80(1:4).eq.'Nnuc')then read(9,80,end=99,err=99)s80 if(s80(1:4).eq.'Nnuc')read(9,*)nnuc N=nnuc*3 write(6,*)s80(1:4),nnuc endif if(s80(1:6).eq.'Coord.')then read(9,80,end=99,err=99)s80 if(s80(1:6).eq.'Coord.')then read(9,*)nat allocate(iz(nat),r(nat,3)) do 16 ia=1,nat read(9,80)s80 iz(ia)=0 if(s80(1:2).eq.'H ')iz(ia)=1 if(s80(1:2).eq.'C ')iz(ia)=6 if(s80(1:2).eq.'N ')iz(ia)=7 if(s80(1:2).eq.'O ')iz(ia)=8 if(s80(1:2).eq.'S ')iz(ia)=16 if(s80(1:2).eq.'Cd')iz(ia)=48 if(iz(ia).eq.0)write(6,*)s80(1:2),' atom not assigned' 16 read(s80(3:len(s80)),*)(r(ia,ix),ix=1,3) open(91,file='FILE.X') write(91,*)'ADF geometry' write(91,*)nat do 17 ia=1,nat 17 write(91,910)iz(ia),(r(ia,ix),ix=1,3) 910 format(i6,3f12.6,' 0 0 0 0 0 0 0 0.0') close(91) write(6,*)'FILE.X written' endif endif if(nnuc.ne.0.and.s80(1:3).eq.'AAT')then read(9,80,end=99,err=99)s80 if(s80(1:5).eq.'AATel')goto 1 if(s80(1:6).eq.'AATnuc')goto 1 if(s80(1:3).eq.'AAT')then read(9,*) allocate(a(nnuc,3,3)) do 5 ia=1,nnuc do 5 ix=1,3 5 read(9,*)a(ia,ix,1),a(ia,ix,2),a(ia,ix,3) lin(1)=.true. endif endif if(nnuc.ne.0.and.s80(1:3).eq.'APT')then read(9,80,end=99,err=99)s80 if(s80(1:5).eq.'APTel')goto 1 if(s80(1:6).eq.'APTnuc')goto 1 if(s80(1:3).eq.'APT')then read(9,*) allocate(p(nnuc,3,3)) do 6 ia=1,nnuc do 6 ix=1,3 6 read(9,*)p(ia,ix,1),p(ia,ix,2),p(ia,ix,3) lin(2)=.true. endif endif if(s80(1:5).eq.'Freq.')then read(9,80,end=99,err=99)s80 if(s80(1:5).eq.'Freq.')then read(9,*)N nnuc=N/3 allocate(w(N)) read(9,*)w lin(4)=.true. endif endif if(s80(1:4).eq.'mwNM')then read(9,80,end=99,err=99)s80 if(s80(1:4).eq.'mwNM')then read(9,*)nt N=isqrt(nt) nnuc=N/3 allocate(s(N,N)) read(9,*)((s(i,j),i=1,N),j=1,N) lin(5)=.true. o1=0.0d0 do i=1,N o1=o1+s(1,i)*s(2,i) enddo write(6,*)'12',o1 o1=0.0d0 do i=1,N o1=o1+s(1,i)*s(1,i) enddo write(6,*)'11',o1 o1=0.0d0 do i=1,N o1=o1+s(i,1)*s(i,1) enddo write(6,*)'11t',o1 o1=0.0d0 do i=1,N o1=o1+s(i,N)*s(i,N) enddo write(6,*)'NNt',o1 endif endif if(s80(1:18).eq.'Analytical Hessian')then read(9,*)nt N=isqrt(nt) nnuc=N/3 allocate(f(N,N)) read(9,*)f lin(3)=.true. endif goto 1 99 close(9) endif if(ie.gt.0)then open(9,file='MCD.TAB') write(9,900) 900 format(' MCD spectrum from ADF',/, 1 ' transition l(nm) D (debye^2) B (a.u.)',/,80(1h-)) do 7 i=1,ie 7 write(9,60)i,1.0d7/(e(i)*219474.0d0),d(i),b(i) 60 format(i4,f12.2,2f20.10) write(9,901) 901 format(80(1h-)) write(6,*)' MCD.TAB written' endif if(lin(1).and.lin(2))call WRITETEN(nnuc,p,a,lin(1),nnuc) if(lin(3))call WRITEFF(N,N,f) if(lin(4).and.lin(5))call wrs(N,N,N,s,w) end subroutine wrs(N,NI,NAT3,S,w) implicit none integer*4 N,NI,NAT3,NAT,I,J,l,it real*8 s(N,N),X,Y,Z,w(N) OPEN(34,FILE='F.INP') WRITE(34,10)NI,NAT3,NAT3/3 10 FORMAT(3I7) OPEN(35,FILE='FILE.X',STATUS='OLD') READ(35,*) READ(35,*)NAT DO 3 I=1,NAT READ(35,*)it,X,Y,Z 3 WRITE(34,11)it,X,Y,Z 11 FORMAT(I7,3F12.6) CLOSE(35) WRITE(34,14) 14 FORMAT(' Atom Mode X-disp. Y-disp. Z-disp.') DO 1 I=1,NAT DO 1 J=1,NI 1 WRITE(34,15)I,J,(S(3*(I-1)+l,J),l=1,3) 15 FORMAT(2I7,3F11.6) WRITE(34,11)NI do 4 I=1,NI WRITE(34,13)w(I) 13 format(F11.3,$) 4 if(mod(I,6).eq.0)write(34,*) write(34,*) CLOSE(34) write(6,*)' F.INP written' RETURN END function isqrt(u) integer*4 isqrt,u,i i=-1 1 i=i+1 if(i*i.eq.u)then isqrt=i return endif if(i.lt.1000000)goto 1 write(6,*)u,'cannot find a root' stop end SUBROUTINE WRITETEN(N0,P,A,LVCD,NAT) IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8(A-H,O-Z) DIMENSION P(N0,3,3),A(N0,3,3) LOGICAL LVCD c BOHR=0.52917705993d0 Z0=0.0d0 OPEN(15,FILE='FILE.TEN') WRITE(15,1500) NAT,NAT-6,0 1500 FORMAT(3I5) DO 10 L=1,NAT DO 10 J=1,3 10 WRITE(15,1501) (P(L,J,I),I=1,3),L 1501 FORMAT(3F14.8,I5) IF(.NOT.LVCD)THEN DO 220 L=1,NAT DO 220 J=1,3 c write(6,*)L,J,nat 220 WRITE(15,1501) (Z0,I=1,3),L ELSE DO 221 L=1,NAT DO 221 J=1,3 c write(6,*)L,J 221 WRITE(15,1501) (A(L,J,I),I=1,3),L ENDIF DO 230 L=1,NAT DO 230 J=1,3 230 WRITE(15,1501) (Z0,I=1,3),L DO 100 L=1,NAT DO 100 J=1,3 100 WRITE(15,1501) (P(L,J,I),I=1,3),L WRITE(*,*)' Dipole derivatives written into FILE.TEN' CLOSE(15) RETURN END SUBROUTINE WRITEFF(MX3,N,FCAR) IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8(A-H,O-Z) DIMENSION FCAR(MX3,N) C CONST=4.359828/0.5291772**2 OPEN(20,FILE='FILE.FC') CONST=1.0d0 DO 6 I=1,N DO 6 J=1,N 6 FCAR(I,J)=FCAR(I,J)/CONST N1=1 1 N3=N1+4 IF(N3.GT.N)N3=N DO 130 LN=N1,N 130 WRITE(20,17)LN,(FCAR(LN,J),J=N1,MIN(LN,N3)) N1=N1+5 IF(N3.LT.N)GOTO 1 17 FORMAT(I4,5D14.6) CLOSE(20) WRITE(*,*)' FF written into FILE.FC' RETURN END