PROGRAM GAAT
C   
C     Reads AAT from gaussian long output as well as from archive
C     Petr Bour, UOCHB, Praha
      IMPLICIT INTEGER*4 (I-N) 
      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER (NT0=500,MX3=3*NT0)
      DIMENSION F(MX3,MX3),P(NT0,3,3),X(3,NT0),ALPHA(3,3,MX3),
     1AAT(NT0,3,3),AATE(NT0,3,3),CHAR(NT0),AATN(NT0,3,3)
      CHARACTER*80 filename
      CHARACTER*1 BUFF(140),NUMBER(80),L,LS,LE,OK
      CHARACTER*2 AT(NT0)
      CHARACTER*5 SSTR
      CHARACTER*2 LG,L2
      COMMON/LINE/I
      LOGICAL LABS,LVCD,LGEO,LARCH,auto
      character*2 atsy(89)
      data atsy/'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne',
     3'Na','Mg','Al','Si','P ','S ','Cl','Ar',
     4'K ','Ca','Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu','Zn',
     4          'Ga','Ge','As','Se','Br','Kr',
     5'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd',
     5          'In','Sn','Sb','Te','I ','Xe',
     6'Cs','Ba','La',
     6               'Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho',
     6               'Er','Tm','Yb','Lu',
     6'Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg',
     6          'Tl','Pb','Bi','Po','At','Rn',
     7'Fr','Ra','Ac'/
c
      OPEN(8,FILE='scr',FORM='FORMATTED')
c
      WRITE(*,*)' How many atoms ?'
      READ(*,*)NAT
      N=3*NAT
      NB=70
      LABS=.FALSE.
      LVCD=.FALSE.
      LGEO=.FALSE.
      LS='\\'
      LE='='
      LG='%%'
      L2='\\\\'
      WRITE(*,*)
     1' Geometry looked for after string ',LG,' (only for G94)'
      WRITE(*,*)' Filename ? '
      READ(*,'(A)')filename
      OPEN(7,FILE=FILENAME,STATUS='OLD',FORM='FORMATTED')
C
      LARCH=.FALSE.
5444  READ(7,7000,END=8888)(BUFF(I),I=1,NB)
      READ(7,7000,END=8888)(BUFF(I),I=NB+1,2*NB)
7000  FORMAT(1X,70A1)
      if(BUFF(1).eq.'A'.and.BUFF(2).eq.'A'.and.BUFF(3).eq.'T'.and.
     1   BUFF(5).eq.'('.and.BUFF(6).eq.'t')then
       WRITE(*,*)' Electronic AAT found '
       BACKSPACE 7
       DO 7 IA=1,NAT
       DO 7 IX=1,3
7      READ(7,*)(AATE(IA,IX,IY),IY=1,3)
       goto 5444
      ENDIF
      BACKSPACE 7
      DO 51 I=1,2*NB-5
      DO 52 J=1,5
52    SSTR(J:J)=BUFF(I+J-1) 
      IF(SSTR(1:2).EQ.L2)LARCH=.TRUE.
      IF(SSTR.EQ.'leDer')THEN
       IF(.NOT.LARCH)GOTO 5444
       WRITE(*,*)' Atomic polar tensor found'
       LABS=.TRUE.
       GOTO 6555
      ENDIF
      IF(SSTR(3:5).EQ.'AAT')THEN
       IF(.NOT.LARCH)GOTO 5444
       WRITE(*,*)' Atomic axial tensor found'
       LVCD=.TRUE.
       GOTO 9555
      ENDIF
      IF(SSTR.EQ.'arDer')THEN
       IF(.NOT.LARCH)GOTO 5444
       WRITE(*,*)' Polarization Derivatives found'
       LABS=.TRUE.
       GOTO 8555
      ENDIF
C     NImag for g94, NIMAG for g92
      IF(SSTR.EQ.'NImag'.OR.SSTR.EQ.'NIMAG')THEN
       IF(.NOT.LARCH)GOTO 5444
       WRITE(*,*)' Second derivatives found'
       GOTO 5555
      ENDIF
      IF((.NOT.LGEO).AND.SSTR(1:2).EQ.LG)THEN
       IF(.NOT.LARCH)GOTO 5444
       WRITE(*,*)' Geometry found'
       LGEO=.TRUE.
       GOTO 7555
      ENDIF
51    CONTINUE
      GOTO 5444
C
7555  I=I+1
C     I .. index of the letter to be gotten
      IF(I.GT.NB)THEN
       DO 74 K=1,NB
74     BUFF(K)=BUFF(K+NB)
       I=I-NB
       READ(7,*)
      ENDIF
      DO 73 IA=1,NAT
      AT(IA)(1:1)=' '
      AT(IA)(2:2)=' '
C
C     Get element:
      I=I+1
      CALL GETLET(L,BUFF,NB)
      AT(IA)(1:1)=L
      I=I+1
      CALL GETLET(L,BUFF,NB)
      if(L.ne.',')then
       AT(IA)(2:2)=L
       I=I+1
       CALL GETLET(L,BUFF,NB)
      endif
C
      DO 773 IX=1,3
C     READ X(IX,IA):
      DO 75 J=1,20
75    NUMBER(J)=' '
      IN=0
7558  IN=IN+1
      I=I+1
      CALL GETLET(L,BUFF,NB)
      NUMBER(IN)=L
      IF(L.NE.','.AND.L.NE.LS)GOTO 7558
      NUMBER(IN)=' '
      REWIND 8
      WRITE(8,*)(NUMBER(J),J=1,20)
      REWIND 8
      READ(8,*)FU
      X(IX,IA)=FU
773   CONTINUE
73    CONTINUE
c
      OPEN(15,FILE='FILE.XYZ')
      WRITE(15,*)' FILE.XYZ from Gaussian output'
      DO 77 IA=1,NAT
      K=0
      IF(AT(IA).EQ.'C ')K=1
      IF(AT(IA).EQ.'O ')K=2
      IF(AT(IA).EQ.'N ')K=3
      IF(AT(IA).EQ.'H ')K=4
      IF(AT(IA).EQ.'S ')K=5
      IF(AT(IA).EQ.'P ')K=9
      IF(AT(IA).EQ.'Fe')K=26
      IF(K.EQ.0)WRITE(*,*)' Unknown atom ',AT(IA)
77    WRITE(15,1500)K,(X(IX,IA),IX=1,3),0,0,0,0,0.0
1500  FORMAT(I4,3F15.8,4I2,F4.1)
      WRITE(15,1500)9999,0.0,0.0,0.0,0,0,0,0,0.0
      CLOSE(15)
      WRITE(*,*)' X written into FILE.XYZ'
c
      OPEN(15,FILE='FILE.X')
      WRITE(15,*)' FILE.X from Gaussian output'
      WRITE(15,*)NAT
      DO 777 IA=1,NAT
      K=0
      do 1 ii=1,89
1     IF(AT(IA).EQ.atsy(ii))K=ii
      IF(K.EQ.0)then
       WRITE(*,*)' Unknown atom ',AT(IA)
       stop
      endif
      CHAR(IA)=DBLE(K)
777   WRITE(15,1502)K,(X(IX,IA),IX=1,3)
1502  FORMAT(I4,3F15.8,' 0 0 0 0 0 0 0 0.0')
      CLOSE(15)
      WRITE(*,*)' X written into FILE.X'
c
      BACKSPACE 7
      GOTO 5444
C
C
C     Polarization derivatives
8555  I=I+J
C     I .. index of the letter to be gotten
      IF(I.GT.NB)THEN
       DO 78 K=1,NB
78     BUFF(K)=BUFF(K+NB)
       I=I-NB
       READ(7,*)
      ENDIF
8556  I=I+1
      CALL GETLET(L,BUFF,NB)
      IF(L.NE.LE)GOTO 8556
      DO 80 IA=1,N
      DO 80 IX=1,3
      DO 80 IY=1,IX
C
C     READ ALPHA(IX,IY,IA)
      DO 79 J=1,20
79    NUMBER(J)=' '
      IN=0
8558  IN=IN+1
      I=I+1
      CALL GETLET(L,BUFF,NB)
      NUMBER(IN)=L
      IF(L.NE.','.AND.L.NE.'\\')GOTO 8558
      NUMBER(IN)=' '
      REWIND 8
      WRITE(8,*)(NUMBER(J),J=1,20)
      REWIND 8
      READ(8,*)FU
      ALPHA(IY,IX,IA)=FU
80    ALPHA(IX,IY,IA)=FU
      CALL WRITETTT(N,NAT,ALPHA)
      WRITE(*,*)' ALPHA written into FILE.TTT'
      BACKSPACE 7
      GOTO 5444
C
C     Dipole derivatives     
6555  I=I+J
C     I .. index of the letter to be gotten
      IF(I.GT.NB)THEN
       DO 54 K=1,NB
54     BUFF(K)=BUFF(K+NB)
       I=I-NB
       READ(7,*)
      ENDIF
6556  I=I+1
      CALL GETLET(L,BUFF,NB)
      IF(L.NE.LE)GOTO 6556
      DO 53 IA=1,NAT
      DO 53 IX=1,3
      DO 53 IY=1,3
C
C     READ P(IA,IX,IY):
      DO 55 J=1,20
55    NUMBER(J)=' '
      IN=0
6558  IN=IN+1
      I=I+1
      CALL GETLET(L,BUFF,NB)
      NUMBER(IN)=L
      IF(L.NE.','.AND.L.NE.'\\')GOTO 6558
      NUMBER(IN)=' '
      REWIND 8
      WRITE(8,*)(NUMBER(J),J=1,20)
      REWIND 8
      READ(8,*)FU
53    P(IA,IX,IY)=FU
      CALL WRITETEN(NT0,P,AAT,LABS,LVCD,X,NAT)
C
      BACKSPACE 7
      GOTO 5444
C
C
C     Magnetic dipole derivatives     
9555  I=I+J-2
C     I .. index of the letter to be gotten
      IF(I.GT.NB)THEN
       DO 56 K=1,NB
56     BUFF(K)=BUFF(K+NB)
       I=I-NB
       READ(7,*)
      ENDIF
9556  I=I+1
      CALL GETLET(L,BUFF,NB)
      IF(L.NE.LE)GOTO 9556
      DO 58 IA=1,NAT
      DO 58 IX=1,3
      DO 58 IY=1,3
C
C     READ AAT(IA,IX,IY):
      DO 59 J=1,20
59    NUMBER(J)=' '
      IN=0
9558  IN=IN+1
      I=I+1
      CALL GETLET(L,BUFF,NB)
      NUMBER(IN)=L
      IF(L.NE.','.AND.L.NE.'\\')GOTO 9558
      NUMBER(IN)=' '
      REWIND 8
      WRITE(8,*)(NUMBER(J),J=1,20)
      REWIND 8
      READ(8,*)FU
58    AAT(IA,IX,IY)=FU
      CALL WRITETEN(NT0,P,AAT,LABS,LVCD,X,NAT)
      WRITE(*,*)' AAT written into FILE.TEN'
c
      OPEN(15,FILE='AAT.TEN')
      WRITE(15,*)'From archive'
      DO 100 LA=1,NAT
      DO 100 J=1,3
100   WRITE(15,1501) (AAT(LA,J,I),I=1,3),LA
1501  FORMAT(3F14.8,I5)
      WRITE(15,*)'From standard orientation'
      DO 101 LA=1,NAT
      DO 101 J=1,3
101   WRITE(15,1501) (AATE(LA,J,I),I=1,3),LA
      BOHR=0.529177D0
      DO 102 LA=1,NAT
      DO 102 I=1,3
      DO 102 J=1,3
      AATN(LA,J,I)=0.0d0
      DO 102 K=1,3
102   AATN(LA,J,I)=AATN(LA,J,I)+EPS(I,J,K)*X(K,LA)*CHAR(LA)*BOHR
      WRITE(15,*)'Nuclear'
      DO 104 LA=1,NAT
      DO 104 J=1,3
104   WRITE(15,1501) (AATN(LA,J,I),I=1,3),LA
      CLOSE(15)
      WRITE(*,*)'AAT in AAT.TEN'
c
c
      BACKSPACE 7
      GOTO 5444
C
C     Force Field:
5555  I=I+1
C     I .. index of the letter to be gotten
      IF(I.GT.70)THEN
       DO 4 K=1,70
4      BUFF(K)=BUFF(K+70)
       I=I-70
       READ(7,*)
      ENDIF
C     NB .. line length
5556  I=I+1
      CALL GETLET(L,BUFF,NB)
      IF(L.NE.LS)GOTO 5556
5557  I=I+1
      CALL GETLET(L,BUFF,NB)
      IF(L.NE.LS)GOTO 5557
c     write(6,*)'numbers',I
      DO 3 IX=1,N
      DO 3 IY=1,IX
C
C     READ F(IX,IY):
      DO 5 J=1,20
5     NUMBER(J)=' '
      IN=0
5558  IN=IN+1
      I=I+1
      CALL GETLET(L,BUFF,NB)
      NUMBER(IN)=L
      IF(L.NE.','.AND.L.NE.'\\')GOTO 5558
      NUMBER(IN)=' '
      REWIND 8
      WRITE(8,*)(NUMBER(J),J=1,20)
      REWIND 8
      READ(8,*)FU
C     WRITE(9,*)IX,IY,FU
      F(IX,IY)=FU
3     F(IY,IX)=FU
      OPEN(20,FILE='FILE.FC')
      CALL WRITEFF(MX3,N,F)
      CLOSE(20)
      WRITE(*,*)' FF written into FILE.FC'
      BACKSPACE 7
      GOTO 5444
C
C
8888  CLOSE(7)
      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
      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 GETLET(L,BUFF,NB)
      IMPLICIT INTEGER*4 (I-N) 
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER*1 BUFF(140)
      CHARACTER*1 L
      COMMON/LINE/I
      IF(I.GT.NB)THEN
       IF(I.GT.NB+1)THEN
        WRITE(*,*)' Cannot read letter ',I
c       STOP
       ENDIF
       I=1
       READ(7,7000)(BUFF(J),J=1,70)
7000  FORMAT(1X,70A1)
      ENDIF
      L=BUFF(I)
      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
C     =======================================
      SUBROUTINE WRITETTT(N,NAT,ALPHA)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER*4 (I-N)
      DIMENSION ALPHA(3,3,N)
      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 IX=1,3
      IIND=3*(L-1)+IX
2     WRITE(2,2001)L,IX,(0.0,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,(0.0,K=1,3)
      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)
      RETURN
      END

C
C\Version=SGI-G94RevB.3\HF=-966.6745649\RMSD=0.000e+00\RMSF=1.196e-01\D
Cipole=0.,0.,0.\PG=C01 [X(C38H52N16O24P4)]\NImag=84\\0.76752455,0.00053
C432,0.03734306,0.23733561,0.00042079,0.13291623,-0.70920516,0.00065060
C,-0.21702343,1.33224819,0.00170226,-0.03103517,0.00051274,0.02526703,1
C.09059550,-0.21867837,0.00010553,-0.09804719,0.00890088,-0.02513206,1.