PROGRAM EATTT IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (MX=1000) DIMENSION ial(MX) DIMENSION P(MX,3,3),A(MX,3,3),AI(MX,3,3),AJ(MX,3,3) DIMENSION ALPHA(3*MX,3,3),G(3*MX,3,3),AA(3*MX,3,3,3) logical lex character*80 s WRITE(*,*)' ZERO-OUT ATOM CONTRIBUTIONS IN FILE.TTT and FILE.TEN' call ropt(f) if(iargc().eq.1)then call getarg(1,s) read(s,*)f write(6,600)f 600 format(' FACTOR: ',f12.6) endif c inquire(file='EA.LST',exist=lex) if(lex)then open(40,file='EA.LST') read(40,*)nae if(abs(nae).gt.MX)call report('too many atoms') read(40,*)(ial(i),i=1,abs(nae)) if(nae.gt.0)then write(6,*)nae,' atoms to be deleted found in EA.LST' else write(6,*)abs(nae),' atoms found in EA.LST will be conserved' endif else write(6,*)'How many atoms to delete:' read(5,*)nae if(nae.gt.MX)call report('too many atoms') write(6,*)'List of the atoms:' read(5,*)(ial(i),i=1,nae) endif inquire(file='FILE.TEN',exist=lex) if(lex)then OPEN(15,FILE='FILE.TEN') CALL READTEN( MX,P,A,AI,AJ,NAT) REWIND 15 CALL WRITETEN(MX,P,A,NAT,nae,ial,f) close(15) write(6,*)'FILE.TEN rewritten' else write(6,*)'FILE.TEN not found' endif inquire(file='FILE.TTT',exist=lex) if(lex)then OPEN(15,FILE='FILE.TTT') CALL READTTT( MX,ALPHA,AA,G,NAT) REWIND 15 CALL WRITETTT(MX,NAT,ALPHA,AA,G,nae,ial,f) close(15) write(6,*)'FILE.TTT rewritten' else write(6,*)'FILE.TTT not found' endif stop end C SUBROUTINE READTEN(MX,P,A,AI,AJ,NAT) IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION P(MX,3,3),A(MX,3,3),AI(MX,3,3),AJ(MX,3,3) C READ(15,*)NAT if(NAT.gt.MX)call report('too many atoms') WRITE(6,*)NAT,' atoms' DO 10 L=1,NAT DO 10 J=1,3 10 READ (15,*) (P(L,J,I),I=1,3) DO 220 L=1,NAT DO 220 J=1,3 220 READ (15,*) (AI(L,J,I),I=1,3) DO 230 L=1,NAT DO 230 J=1,3 230 READ (15,*) (AJ(L,J,I),I=1,3) C C Total axial tensor = electronic + nuclear: DO 4 L=1,NAT DO 4 I=1,3 DO 4 J=1,3 4 A(L,I,J)=AI(L,I,J)+AJ(L,I,J) C RETURN END C SUBROUTINE WRITETEN(MX,P,A,NAT,nae,ial,f) IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION P(MX,3,3),A(MX,3,3),ial(MX) c Z0=0.0d0 if(nae.gt.0)then do 1 L=1,nae do 1 J=1,3 do 1 I=1,3 A(ial(L),J,I)=A(ial(L),J,I)*f 1 P(ial(L),J,I)=P(ial(L),J,I)*f else do 11 L=1,NAT ic=0 do 12 ii=1,abs(nae) 12 if(ial(ii).eq.L)ic=ic+1 if(ic.eq.0)then do 13 J=1,3 do 13 I=1,3 A(L,J,I)=A(L,J,I)*f 13 P(L,J,I)=P(L,J,I)*f endif 11 continue endif 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) DO 220 L=1,NAT DO 220 J=1,3 220 WRITE(15,1501) (A(L,J,I),I=1,3),L 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 RETURN END C SUBROUTINE READTTT(MX,ALPHA,A,G,NAT) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) DIMENSION ALPHA(3*MX,3,3),G(3*MX,3,3),A(3*MX,3,3,3) c READ(15,*) READ(15,*)NAT READ(15,*) READ(15,*) DO 1 I=1,3 READ(15,*) DO 1 L=1,NAT DO 1 IX=1,3 IIND=3*(L-1)+IX 1 READ(15,*)LDUM,IXDUM,(ALPHA(IIND,I,J),J=1,3) READ(15,*) READ(15,*) DO 2 I=1,3 READ(15,*) DO 2 L=1,NAT DO 2 IX=1,3 IIND=3*(L-1)+IX 2 READ(15,*)LDUM,IXDUM,(G(IIND,I,J),J=1,3) READ(15,*) READ(15,*) DO 3 I=1,3 DO 3 J=1,3 READ(15,*) DO 3 L=1,NAT DO 3 IX=1,3 IIND=3*(L-1)+IX 3 READ(15,*)LDUM,IXDUM,(A(IIND,I,J,K),K=1,3) RETURN END C SUBROUTINE WRITETTT(MX,NAT,ALPHA,A,G,nae,ial,f) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) DIMENSION ALPHA(3*MX,3,3),G(3*MX,3,3),A(3*MX,3,3,3),ial(*) C if(nae.gt.0)then do 4 L=1,nae do 4 IX=1,3 IIND=3*(ial(L)-1)+IX do 4 I=1,3 do 4 J=1,3 ALPHA(IIND,I,J)=ALPHA(IIND,I,J)*f G(IIND,I,J) =G(IIND,I,J) *f do 4 K=1,3 4 A(IIND,I,J,K) =A(IIND,I,J,K) *f else do 41 L=1,NAT ic=0 do 12 ii=1,abs(nae) 12 if(ial(ii).eq.L)ic=ic+1 if(ic.eq.0)then do 42 IX=1,3 IIND=3*(L-1)+IX do 42 I=1,3 do 42 J=1,3 ALPHA(IIND,I,J)=ALPHA(IIND,I,J)*f G(IIND,I,J) =G(IIND,I,J) *f do 42 K=1,3 42 A(IIND,I,J,K) =A(IIND,I,J,K) *f endif 41 continue endif c WRITE(15,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(15,2002)I 2002 FORMAT(' Alpha(',I1,',J):') DO 1 L=1,NAT DO 1 IX=1,3 IIND=3*(L-1)+IX 1 WRITE(15,2001)L,IX,(ALPHA(IIND,I,J),J=1,3) 2001 FORMAT(I5,1H ,I1,3g15.7) WRITE(15,2004) 2004 FORMAT(' The electric dipole magnetic dipole polarizability:',/, 1 ' Atom/x jx jy jz') DO 2 I=1,3 WRITE(15,2003)I 2003 FORMAT(' G(',I1,',J):') DO 2 L=1,NAT DO 2 IX=1,3 IIND=3*(L-1)+IX 2 WRITE(15,2001)L,IX,(G(IIND,I,J),J=1,3) WRITE(15,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(15,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(15,2001)L,IX,(A(IIND,I,J,K),K=1,3) RETURN END subroutine report(s) character*(*) s write(6,*)s stop end subroutine ropt(f) implicit none real*8 f logical lex character*4 k f=0.0d0 inquire(file='EATTT.OPT',exist=lex) if(lex)then open(9,file='EATTT.OPT') 1 read(9,80,end=99,err=99)k 80 format(a4) write(6,80)k if(k.eq.'FACT')read(9,*)f goto 1 99 close(9) endif return end