PROGRAM EATTT IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8 (A-H,O-Z) integer*4,allocatable::ial(:) real*8,allocatable::P(:,:,:),A(:,:,:),AI(:,:,:),AJ(:,:,:), 1ALPHA(:,:,:),G(:,:,:),AA(:,:,:,:) logical lex,detect character*80 s,s2 WRITE(*,*)' ZERO-OUT ATOM CONTRIBUTIONS IN FILE.TTT and FILE.TEN' call seenat(nat) allocate(ial(nat)) 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.nat)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.nat)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 allocate(P(nat,3,3),A(nat,3,3),AI(nat,3,3),AJ(nat,3,3)) OPEN(15,FILE='FILE.TEN') CALL READTEN( P,A,AI,AJ,NAT) REWIND 15 CALL WRITETEN(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 allocate(ALPHA(6*nat,3,3),G(6*nat,3,3),AA(6*nat,3,3,3)) if(detect('FILE.TTT'))then write(6,*)'Complex polarizabilities detected' CALL READTTT(ALPHA,AA,G,NAT,3,s2) REWIND 15 CALL WRITETTT(NAT,ALPHA,AA,G,nae,ial,f,3,s2) else CALL READTTT( ALPHA,AA,G,NAT,0,s2) REWIND 15 CALL WRITETTT(NAT,ALPHA,AA,G,nae,ial,f,0,s2) endif write(6,*)'FILE.TTT rewritten' else write(6,*)'FILE.TTT not found' endif stop end C SUBROUTINE READTEN(P,A,AI,AJ,NAT) IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION P(nat,3,3),A(nat,3,3),AI(nat,3,3),AJ(nat,3,3) C READ(15,*)NAT 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(P,A,NAT,nae,ial,f) IMPLICIT INTEGER*4 (I-N) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION P(nat,3,3),A(nat,3,3),ial(nat) 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 function detect(s) integer*4 J logical detect character*(*) s character*120 s120 open(15,file=s) do 1 J=1,6 1 READ(15,120)s120 120 format(a120) close(15) i=0 do 2 J=1,len(s120) 2 if(s120(J:J).eq.'.')i=i+1 detect=i.gt.3 return end SUBROUTINE READTTT(ALPHA,A,G,NAT,ic,s2) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) DIMENSION ALPHA(6*nat,3,3),G(6*nat,3,3),A(6*nat,3,3,3) character*80 s2 c OPEN(15,FILE='FILE.TTT') READ(15,*) c read whole line as it night contain excitation frequency: READ(15,80)s2 80 format(a80) READ(s2,*)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), 1(ALPHA(IIND+3*NAT,I,J),J=1,ic) 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), 1(G(IIND+3*NAT,I,J),J=1,ic) 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), 1(A(IIND+3*NAT,I,J,K),K=1,ic) RETURN END C SUBROUTINE WRITETTT(NAT,ALPHA,A,G,nae,ial,f,ic,s2) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) DIMENSION ALPHA(6*nat,3,3),G(6*nat,3,3),A(6*nat,3,3,3),ial(NAT) character*80 s2 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 c c complex: do 46 J=1,ic ALPHA(IIND+3*NAT,I,J)=ALPHA(IIND+3*NAT,I,J)*f 46 G(IIND+3*NAT,I,J) =G(IIND+3*NAT,I,J) *f do 43 J=1,3 do 43 K=1,ic 43 A(IIND+3*NAT,I,J,K) =A(IIND+3*NAT,I,J,K) *f 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 id=0 do 12 ii=1,abs(nae) 12 if(ial(ii).eq.L)id=id+1 if(id.eq.0)then do 42 IX=1,3 IIND=3*(L-1)+IX do 42 I=1,3 c complex: do 44 J=1,ic ALPHA(IIND+3*NAT,I,J)=ALPHA(IIND+3*NAT,I,J)*f 44 G(IIND+3*NAT,I,J) =G(IIND+3*NAT,I,J) *f do 45 J=1,3 do 45 K=1,ic 45 A(IIND+3*NAT,I,J,K) =A(IIND+3*NAT,I,J,K) *f 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,1900) 1900 FORMAT(' ROA tensors, cartesian derivatives') do 1901 ie=len(s2),1,-1 1901 if(s2(ie:ie).ne.' ')goto 1902 1902 do 1903 i=1,ie 1903 write(15,80)s2(i:i) 80 format(a1,$) write(15,*) WRITE(15,2000) 2000 FORMAT(' 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), 1(ALPHA(IIND+3*NAT,I,J),J=1,ic) 2001 FORMAT(I5,1H ,I1,6g15.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), 1(G(IIND+3*NAT,I,J),J=1,ic) 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), 1(A(IIND+3*NAT,I,J,K),K=1,ic) close(15) 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 subroutine seenat(nat) integer*4 nat logical lex nat=0 inquire(file='FILE.TEN',exist=lex) if(lex)then OPEN(15,FILE='FILE.TEN') READ(15,*)NAT close(15) endif inquire(file='FILE.TTT',exist=lex) if(lex)then OPEN(15,FILE='FILE.TTT') READ(15,*) READ(15,*)NAT close(15) endif if(nat.eq.0)call report('No atoms') write(6,*)nat,' atoms' return end