PROGRAM AAR C this program reads the archive of the ADF output C Petr Bour, UOCHB, Praha implicit none INTEGER*4 NT0,MX3,NAT,IL,ia,ix,iy,iz,i,N,j,nn,nt,ja,jx PARAMETER (NT0=500,MX3=3*NT0) REAL*8 F(MX3,MX3),P(NT0,3,3),X(3,NT0),ALPHA(3,3,MX3), 1AAT(NT0,3,3),GTENS(3,3,MX3),ATENS(3,3,3,MX3),Q(NT0) INTEGER*4 IQ(NT0),order1(NT0),order2(NT0),ifragment(NT0), 1ITYPE(NT0) CHARACTER*80 filename CHARACTER*30 s301,s302 LOGICAL LVCD,LGEO,auto,LAL,LFF c LVCD=.FALSE. LGEO=.FALSE. LAL=.FALSE. LFF=.FALSE. NAT=0 IL=0 nt=0 INQUIRE(file='AUTO',exist=auto) if(auto)then FILENAME='FRE.OUT' else WRITE(6,600) 600 format(' Filename: ',$) READ(*,'(A)')filename endif OPEN(7,FILE=FILENAME,STATUS='OLD',FORM='FORMATTED') 5444 READ(7,7000,END=8888)s301 7000 FORMAT(A30) IL=IL+1 if(S301(1:8).eq.'Geometry')THEN READ(7,7000,END=8888)s302 IL=IL+1 if(S302(1:11).eq.'nr of atoms')then read(7,*) read(7,*)NAT write(6,*)NAT,' atoms in Geometry' N=3*NAT if(NAT.gt.NT0)call report('too many atoms') do 101 i=1,N IQ(i)=0 do 101 ix=1,3 do 101 iy=1,3 ALPHA(ix,iy,i)=0.0d0 AAT(i,ix,iy)=0.0d0 P(i,ix,iy)=0.0d0 GTENS(ix,iy,i)=0.0d0 do 101 iz=1,3 101 ATENS(ix,iy,iz,i)=0.0d0 endif if(S302(1:16).eq.'atom order index')then read(7,*)N write(6,*)N/2,' atoms for order' read(7,*)(order1(ia),ia=1,N/2),(order2(ia),ia=1,N/2) LGEO=.true. endif if(S302(1:15).eq.'nr of atomtypes')then read(7,*) read(7,*)nt write(6,*)nt,' atomic types' endif if(S302(1:8).eq.'charge ')then read(7,*) read(7,*)(Q(i),i=1,nt) write(6,*)nt,' atomic charges' endif if(S302(1:6).eq.'xyz ')then read(7,*)N write(6,*)N/3,' atoms for xyz in Geometry' do 1 ia=1,N/3 1 read(7,*)(X(ix,order2(ia)),ix=1,3) LGEO=.true. endif if(S302(1:14).eq.'xyz InputOrder')then read(7,*)N write(6,*)N/3,' atoms for xyz in Geometry InputOrder' do 4 ia=1,N/3 4 read(7,*)(X(ix,ia),ix=1,3) LGEO=.true. endif if(S302(1:27).eq.'fragment and atomtype index')then read(7,*)nn read(7,*)(ifragment(ia),ia=1,nn/2),(itype(ia),ia=1,nn/2) write(6,*)nn/2,' atoms types read' endif ENDIF if(S301(1:4).eq.'Freq')THEN READ(7,7000,END=8888)s302 IL=IL+1 if(S302(1:6).eq.'xyz ')then read(7,*)N write(6,*)N/3,' atoms for xyz in Freq' do 5 ia=1,N/3 5 read(7,*)(X(ix,order2(ia)),ix=1,3) LGEO=.true. endif if(s302(1:13).eq.'nr of atoms ')then read(7,*) read(7,*)NAT write(6,*)NAT,' atoms in Freq nr of atoms' N=3*NAT endif if(s302(1:23).eq.'Dipole derivatives_CART')then read(7,*)nn NAT=nn/9 write(6,*)nn/9,' atoms in dipder' c read(7,*)(((P(order2(ia),ix,iy),iy=1,3),ia=1,NAT),ix=1,3) read(7,*)(((P(ia,ix,iy),ix=1,3),ia=1,NAT),iy=1,3) LVCD=.true. endif if(s302(1:18).eq.'Polbty derivatives')then read(7,*)nn write(6,*)nn/18,' atoms in polder' do 3 ia=1,nn/18 do 3 ix=1,3 i=3*(ia-1)+ix read(7,*)ALPHA(1,1,i),ALPHA(1,2,i),ALPHA(1,3,i), 1 ALPHA(2,2,i),ALPHA(2,3,i),ALPHA(3,3,i) ALPHA(2,1,i)=ALPHA(1,2,i) ALPHA(3,1,i)=ALPHA(1,3,i) 3 ALPHA(3,2,i)=ALPHA(2,3,i) LAL=.true. endif c if(s302(1:19).eq.'Force constants ')then if(s302(1:12).eq.'Hessian_CART')then read(7,*)nn NAT=nint(dsqrt(DBLE(nn))/3.0d0) N=3*NAT write(6,*)NAT,' atoms in Hessian' do 8 ia=1,NAT do 8 ix=1,3 c i=3*(order2(ia)-1)+ix i=3*(ia-1)+ix do 8 ja=1,NAT 8 read(7,*)(F(i,3*(ja-1)+jx),jx=1,3) c read(7,*)(F(i,3*(order2(ja)-1)+jx),jx=1,3) LFF=.true. endif ENDIF goto 5444 8888 close(7) write(6,*)IL,' lines' c if(LGEO)then do 6 ia=1,NAT 6 IQ(order2(ia))=nint(Q(itype(ia))) call writex('FILE.X',X,NAT,NT0,'ADF',IQ) endif if(LAL)CALL WRITETTT(NAT,ALPHA,GTENS,ATENS,MX3) C if(LVCD)CALL WRITETEN(NT0,P,AAT,LVCD,NAT) C if(LFF)CALL WRITEFF(MX3,N,F) C STOP 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(6,*)'FILE.FC written' RETURN 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(6,*)'FILE.TEN written' CLOSE(15) RETURN END SUBROUTINE WRITETTT(NAT,ALPHA,GTENS,ATENS,MX3) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) DIMENSION ALPHA(3,3,MX3),GTENS(3,3,MX3),ATENS(3,3,3,MX3) OPEN(2,FILE='FILE.TTT') WRITE(2,2000)NAT 2000 FORMAT(' ROA tensors, cartesian derivatives',/,I4,' atoms',/, 1' The electric-dipolar electric-dipolar polarizability:',/, 2' Atom/x jx jy jz') DO 1 I=1,3 WRITE(2,2002)I 2002 FORMAT(' Alpha(',I1,',J):') DO 1 L=1,NAT DO 1 IX=1,3 IIND=3*(L-1)+IX 1 WRITE(2,2001)L,IX,(ALPHA(I,J,IIND),J=1,3) 2001 FORMAT(I5,1H ,I1,3F15.7) WRITE(2,2004) 2004 FORMAT(' The electric dipole magnetic dipole polarizability:',/, 1 ' Atom/x jx(Bx) jy(By) jz(Bz)') DO 2 I=1,3 WRITE(2,2003)I 2003 FORMAT(' G(',I1,',J):') DO 2 L=1,NAT DO 2 K=1,3 2 WRITE(2,2001)L,K,(GTENS(I,J,3*(L-1)+K),J=1,3) WRITE(2,2005) 2005 FORMAT(' The electric dipole electric quadrupole polarizability:', 2/, ' Atom/x kx ky kz') DO 3 I=1,3 DO 3 J=1,3 WRITE(2,2006)I,J 2006 FORMAT(' A(',I1,',',I1,',K):') DO 3 L=1,NAT DO 3 M=1,3 3 WRITE(2,2007)L,M,(ATENS(K,J,I,3*(L-1)+M)*3.00d0/2.0d0,K=1,3), 1L,M,I,J 2007 FORMAT(I5,1H ,I1,3F15.7,' ',4i3) write(2,*) write(2,*)'dummy alpha v:' DO 4 I=1,3 WRITE(2,2002)I DO 4 L=1,NAT DO 4 IX=1,3 IIND=3*(L-1)+IX 4 WRITE(2,2001)L,IX,(ALPHA(I,J,IIND),J=1,3) CLOSE(2) WRITE(6,*)'FILE.TTT written' RETURN END subroutine report(s) character*(*)s write(6,*)s stop end subroutine writex(fn,x,nat,NT0,n,IQ) implicit none character*(*)fn,n integer*4 IQ(*),IA,IX,nat,NT0 REAL*8 x(3,NT0),bohr bohr=0.529177d0 OPEN(15,FILE=fn) WRITE(15,*)n WRITE(15,*)NAT DO 777 IA=1,NAT 777 WRITE(15,1501)IQ(IA),(X(IX,IA)*bohr,IX=1,3) 1501 FORMAT(I4,3F15.8,' 0 0 0 0 0 0 0 0.0') CLOSE(15) WRITE(6,*)fn//' writen' return end