PROGRAM DAR C this program reads dalton oputput IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8(A-H,O-Z) PARAMETER (NT0=500,MX3=3*NT0,BOHR=0.529177d0) DIMENSION al(MX3,3,3),G(MX3,3,3),A(MX3,3,3,3), 1ROAAFP(3,3),ROAGNP(3,3),ROAGLP(3,3),ROAAP(3,3,3), 1r(NT0,3) CHARACTER*80 filename,fn,s80 CHARACTER*2 ka CHARACTER*1 lo CHARACTER*4 s4 c WRITE(6,*)' Filename (without _#.out): ' READ(5,'(A)')filename do 8 ll=80,1,-1 8 if(filename(ll:ll).ne.' ')goto 9 9 WRITE(6,*)ll do 10 i=1,80 10 fn(i:i)=' ' fn(1:ll)=filename(1:ll) fn(ll+1:ll+1)='_' WRITE(6,*)' Number of atoms:' READ(5,*)nat WRITE(6,*)' London (y/n) ?' READ(5,'(a)')lo if(lo.eq.'y')lo='Y' step=1.0d3 frequency=1.0d0 c do 4 l=1,3*nat do 4 i=1,3 do 4 j=1,3 al(l,i,j)=0.0d0 G(l,i,j)=0.0d0 do 4 k=1,3 4 A(l,i,j,k)=0.0d0 c do 1 ii=0,6*nat iat=(ii+5)/6 iax=(ii-6*(iat-1)+1)/2 ico=3*(iat-1)+iax i2=ii-6*(iat-1)-2*(iax-1) if(iat.eq.0)iax=0 if(iat.eq.0)i2=0 c open(4,file='scr') write(4,40)ii 40 format(i4) rewind 4 read(4,41)s4(1:4) 41 format(a4) close(4) c if(ii.le.9)i1=1 if(ii.gt.9.and.ii.le.99)i1=2 if(ii.gt.99.and.ii.le.999)i1=3 if(ii.gt.999)i1=4 fn(ll+2:ll+i1+1)=s4(5-i1:4) fn(ll+2+i1:ll+2+i1+3)='.out' write(6,80)fn 80 format(a80) OPEN(7,FILE=FN) 2 read(7,80,end=999,err=999)s80 if(s80(2:7).eq.'ROAAFP')then read(7,9111)((ROAAFP(I,J),J=1,3),I=1,3) 9111 format(3f15.8) read(7,*) c electric index ->, now first in ROAGNP; last magnetic c (different than in dalton !!!!!!!!!!!!!!!!!) read(7,9111)((ROAGNP(J,I),J=1,3),I=1,3) read(7,*) read(7,9111)((ROAGLP(J,I),J=1,3),I=1,3) read(7,*) read(7,9111)(((ROAAP(I,J,K),K=1,3),J=1,3),I=1,3) if(ii.gt.0)then sign=1.0d0 if(i2.eq.2)sign=-1.0d0 do 3 i=1,3 do 3 j=1,3 al(ico,i,j)=al(ico,i,j)+sign*ROAAFP(i,j) if(lo.eq.'Y')then G(ico,i,j)=G(ico,i,j)+sign*ROAGLP(i,j) else G(ico,i,j)=G(ico,i,j)+sign*ROAGNP(i,j) endif do 3 k=1,3 3 A(ico,i,j,k)=A(ico,i,j,k)+sign*ROAAP(i,j,k) endif goto 11 endif if(s80(2:28).eq.' Number of frequencies :')then open(33,file='scr') write(33,333)(s80(i:i),i=29,39) 333 format(11a1) read(33,*)ir if(ir.ne.1)then write(6,*)' nfreq<>1 !' close(7) stop endif endif if(s80(1:28).eq.' Number of frequencies :')then open(33,file='scr') write(33,333)(s80(i:i),i=29,39) rewind 33 read(33,*)ir if(ir.ne.1)then write(6,*)' nfreq<>1 !' close(7) stop endif read(7,80)s80 write(6,80)s80 rewind 33 write(33,333)(s80(i:i),i=29,39) rewind 33 read(33,*)frequency close(33) endif if(s80(26:48).eq.'Molecular geometry (au)')then read(7,*) read(7,*) if(ii.eq.0)then open(8,file='DAL.X') write(8,80)fn write(8,800)nat do 5 i=1,nat read(7,70)ka,(r(i,ix),ix=1,3) 70 format(a2,f22.10,2f24.10) ic=0 if(ka.eq.' H')ic=1 if(ka.eq.' C')ic=6 if(ka.eq.' N')ic=7 if(ka.eq.' O')ic=8 5 write(8,800)ic,(r(i,ix)*BOHR,ix=1,3) 800 format(i4,3f15.6) close(8) write(6,*)'DAL.X written' else do 51 i=1,nat read(7,70)ka,x,y,z if(abs(x-r(i,1)).gt.0.000001)write(6,6009)i,x-r(i,1) if(abs(x-r(i,1)).gt.0.000001.and.step.gt.100.0d0)then step=x-r(i,1) write(6,8888)step 8888 format(' step set to ',f10.5,' au') endif if(abs(y-r(i,2)).gt.0.000001)write(6,6019)i,y-r(i,2) 51 if(abs(z-r(i,3)).gt.0.000001)write(6,6029)i,z-r(i,3) 6009 format(' atom ',i3,' X: ',f10.4,' au') 6019 format(' atom ',i3,' Y: ',f10.4,' au') 6029 format(' atom ',i3,' Z: ',f10.4,' au') endif endif goto 2 11 close(7) 1 continue c do 6 ico=1,3*nat do 6 i=1,3 do 6 j=1,3 al(ico,i,j)=al(ico,i,j)/step/2.0d0 G(ico,i,j)=G(ico,i,j)/step/2.0d0/frequency do 6 k=1,3 6 A(ico,i,j,k)=A(ico,i,j,k)/step/2.0d0 c call WRITETTT(MX3,NAT,AL,A,G) WRITE(*,*)' Tensors written into DAL.TTT' stop 999 write(6,*)'Unexpected end of file' close(7) stop END c ============================================== SUBROUTINE WRITETTT(N30,NAT,ALPHA,A,G) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) DIMENSION ALPHA(N30,3,3),G(N30,3,3),A(N30,3,3,3) c OPEN(2,FILE='DAL.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(IIND,I,J),J=1,3) 2001 FORMAT(I5,1H ,I1,3F13.7) WRITE(2,2004) 2004 FORMAT(' The electric dipole magnetic dipole polarizability:',/, 1 ' Atom/x jx jy jz (magn. index -->)') DO 2 I=1,3 WRITE(2,2003)I 2003 FORMAT(' G(',I1,',J):') DO 2 L=1,NAT DO 2 IX=1,3 IIND=3*(L-1)+IX c (last index magnetic) 2 WRITE(2,2001)L,IX,(G(IIND,I,J),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 IX=1,3 IIND=3*(L-1)+IX 3 WRITE(2,2001)L,IX,(A(IIND,I,J,K),K=1,3) WRITE(2,2007) 2007 FORMAT(' The polarizability ("velocity"):',/, 1 ' Atom/x vx vy vz ') 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(IIND,I,J),J=1,3) CLOSE(2) 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 CONST=1.0 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) RETURN END SUBROUTINE WRITETEN(N0,P,A,LABS,LVCD,X,NAT) IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8(A-H,O-Z) PARAMETER (NT0=500) DIMENSION P(N0,3,3),A(N0,3,3),R(3,NT0),X(3,NAT) LOGICAL LABS,LVCD BOHR=0.52917705993 Z0=0.0 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 C FUNCTION EPS(I,J,K) IMPLICIT INTEGER*4 (I-N) REAL*8 EPS INTEGER*4 I,J,K EPS=0.0 IF (I.EQ.1.AND.J.EQ.2.AND.K.EQ.3)EPS= 1.0 IF (I.EQ.1.AND.J.EQ.3.AND.K.EQ.2)EPS=-1.0 IF (I.EQ.2.AND.J.EQ.3.AND.K.EQ.1)EPS= 1.0 IF (I.EQ.2.AND.J.EQ.1.AND.K.EQ.3)EPS=-1.0 IF (I.EQ.3.AND.J.EQ.1.AND.K.EQ.2)EPS= 1.0 IF (I.EQ.3.AND.J.EQ.2.AND.K.EQ.1)EPS=-1.0 RETURN END C SUBROUTINE VCDD0(VCD,VEL,DIP,C,NAT) C STOLEN FROM CADPAC, INDICES ARE DIFFERENT !!, VEL WITH NUCLEI IMPLICIT REAL*8(A-H,O-Z) IMPLICIT INTEGER*4 (I-N) INTEGER*4 ALPHA,BETA,GAMMA,DELTA,LAMBDA PARAMETER (MX=100) DIMENSION VCD(MX,3,3),VEL(MX,3,3),DIP(MX,3,3), 1C(3,NAT) DO 90 BETA =1,3 DO 90 GAMMA=1,3 DO 90 DELTA=1,3 SKEW=0.25D0*EPS(BETA,GAMMA,DELTA) IF (DABS(SKEW).GT.1.0D-10)THEN DO 80 ALPHA=1,3 DO 80 LAMBDA=1,NAT 80 VCD(LAMBDA,ALPHA,BETA)=VCD(LAMBDA,ALPHA,BETA) 1 -SKEW*C(GAMMA,LAMBDA) 2 *(VEL(LAMBDA,ALPHA,DELTA)-DIP(LAMBDA,ALPHA,DELTA)) ENDIF 90 CONTINUE RETURN END