PROGRAM INVERT_TENSORS
      IMPLICIT none
      integer*4 nat,i,j,ic,k
      character*80 title
      real*8,allocatable::r(:,:),PS(:,:,:),AI(:,:,:),AJ(:,:,:),PV(:,:,:)
     1,ALPHA(:,:,:),A(:,:,:,:),G(:,:,:)
      integer*4,allocatable::ND(:)
      real*8 gt(3,3),g9(9),at(3,3,3),a27(27)
      logical lex
      character*8 fn(2)
      data fn/'FILE.FC ','POL.TTT '/
c
      WRITE(6,3000)
3000  FORMAT(/,
     1       ' Makes enantiomeric files from',/,/,
     9       '       FILE.X     coordinates',/,
     1       '       FILE. FC   force field',/,
     1       '       FILE.TEN   APT and AAT tensors',/,
     3       '       FILE.TTT   ROA tensors',/,
     3       '       POL.TTT    polarizability',/,
     3       '       ORT.TTT    optical rotational tensor',/,
     3       '       G.TTT      G tensor',/,
     3       '       A.TTT      quadrupole polarizability',/,/)

      inquire(FILE='FILE.X',exist=lex)
      if(lex)then
       OPEN(2,FILE='FILE.X',STATUS='OLD')
       read(2,*)
       read(2,*)nat
       rewind 2
       allocate(r(3,nat),ND(nat))
       CALL READRXS(nat,r,ND,title)
       CLOSE(2)
       WRITE(6,*)nat, ' atoms in FILE.X'
       call enax(nat,r)
       OPEN(2,FILE='FILE.X')
       CALL WRITERX(NAT,R,ND,title)
       CLOSE(2)
       call rew('FILE.X  ')
       deallocate(r)
      else
       call report('FILE.X not found!')
      endif
c
      INQUIRE(FILE='FILE.TEN',EXIST=lex)
      IF(lex)then
       allocate(PS(nat,3,3),AI(nat,3,3),AJ(nat,3,3),PV(nat,3,3))
       OPEN(15,FILE='FILE.TEN',STATUS='OLD')
       CALL READTEN(nat,PS,AI,AJ,PV)
       CLOSE(15)
       CALL enap(nat,AI,AJ)
       CALL WRITETEN(nat,PS,AI,AJ,PV)
       call rew('FILE.TEN')
       deallocate(PS,AI,AJ,PV)
      ELSE
       write(6,6002)'FILE.TEN'
      ENDIF

      INQUIRE(FILE='FILE.TTT',EXIST=lex)
      IF(lex)then
       allocate(ALPHA(3*nat,3,3),A(3*nat,3,3,3),G(3*nat,3,3))
       OPEN(15,FILE='FILE.TTT')
       CALL READTTT(nat,ALPHA,A,G)
       CLOSE(15)
       CALL enattt(nat,ALPHA)
       CALL WRITETTT(nat,ALPHA,A,G,'FILE.TTT')
       call rew('FILE.TTT')
       deallocate(ALPHA,A,G)
      else
       write(6,6002)'FILE.TTT'
      endif

      INQUIRE(FILE='GP.TTT',EXIST=lex)
      IF(lex)then
       call readpolg(gt,'GP.TTT')
       CALL enag(gt)
       do 1 i=1,3
       do 1 j=1,3
1      g9(i+3*(j-1))=gt(j,i)
       CALL WRITEPOL(g9,1,'GP.TTT')
       call rew('GP.TTT  ')
      else
       write(6,6002)'GP.TTT  '
      endif

      INQUIRE(FILE='ORT.TTT',EXIST=lex)
      IF(lex)then
       call readpolo(gt,'ORT.TTT')
       CALL enag(gt)
       do 2 i=1,3
       do 2 j=1,i
2      g9(j+3*(i-1))=gt(i,j)
       CALL WRITEPOL(g9,1,'ORT.TTT')
       call rew('ORT.TTT  ')
      else
       write(6,6002)'ORT.TTT  '
      endif

      INQUIRE(FILE='A.TTT',EXIST=lex)
      IF(lex)then
       call readpola(at,'A.TTT')
       CALL enaa(at)
       do 3 i=1,3
       do 3 j=1,3
       do 3 k=1,3
3      a27(i+3*(j-1)+9*(k-1))=at(i,j,k)
       CALL WRITEPOL(a27,1,'A.TTT')
       call rew('A.TTT   ')
      else
       write(6,6002)'A.TTT   '
      endif

      do 4 ic=1,2
      INQUIRE(FILE=fn(ic),EXIST=lex)
      if(lex)then
       write(6,6001)fn(ic)
6001   format(/,20x,a8,' found, but not changed (invariant)',/)
      else
       write(6,6002)fn(ic)
6002   format(a8,' not found')
      endif
4     continue

      STOP
      END
c     ===============================      
      SUBROUTINE WRITEPOL(APOL,ifr,ty)
      IMPLICIT INTEGER*4 (I-N) 
      IMPLICIT REAL*8(A-H,O-Z)
      real*8 APOL(*)
      character*80 filename
      character*1 fchar
      character*(*) ty
      write(fchar,'(i1)')ifr
      if(ifr.eq.1)then
       filename=ty
      else
       filename=ty//'.f'//fchar
      endif
      OPEN(90,FILE=filename)
      if(ty.eq.'A.TTT')then
       write(90,*)'A, dipole-quadrupole polarizability'
       write(90,902)
       do 1 IZ=1,3
1      write(90,900)((
     1 APOL(IY+(IX-1)*3+(IZ-1)*9),IY=1,IX),IX=1,3)
      else
       if(ty.eq.'POL.TTT')then
        write(90,*)'Polarizability'
        write(90,902)
        write(90,900)((APOL(IY+(IX-1)*3),IY=1,IX),IX=1,3)
       else
        if(ty.eq.'ORT.TTT')then
         write(90,*)'Optical rotation tensor'
         write(90,902)
         write(90,900)((APOL(IY+(IX-1)*3),IY=1,IX),IX=1,3)
        else 
         if(ty.eq.'GP.TTT')then
          write(90,*)'G tensor'
          write(90,901)
          write(90,900)((APOL(IY+(IX-1)*3),IY=1,3),IX=1,3)
         else
          write(90,*)'Unspecified polarizability'
          write(90,901)
          write(90,900)((APOL(IY+(IX-1)*3),IY=1,3),IX=1,3)
         endif
        endif
       endif
      endif
901   format(
     1'            XX            XY            XZ            YX',
     2'            YY            YZ            ZX            ZY',
     3'            ZZ')
902   format(
     1'            XX            XY            YY            XZ',
     2'            YZ            ZZ')
900   format(9F14.6)
      close(90)
      return
      end
c     ============================================================
      SUBROUTINE REPORT(RS)
      IMPLICIT INTEGER*4 (I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*(*) RS
      WRITE(3,3000)
      WRITE(6,3000)
3000  FORMAT(/,80(1H*))
      WRITE(3,*)RS
      WRITE(6,*)RS
      WRITE(3,3001)
      WRITE(6,3001)
3001  FORMAT(80(1H*),/,/,'PROGRAM STOPPED')
      CLOSE(3)
      CLOSE(2)
      STOP
      END
c     ============================================================
      SUBROUTINE enaa(a)
      real*8 a(3,3,3)
      do 1 i=1,3
      do 1 j=1,3
      do 1 k=1,3
1     a(k,j,i)=-a(k,j,i)
      return
      end
c     ============================================================
      SUBROUTINE enag(a)
      real*8 a(3,3)
      do 1 i=1,3
      do 1 j=1,3
1     a(j,i)=-a(j,i)
      return
      end
c     ============================================================
      SUBROUTINE readpolo(a,fn)
      character*(*)fn
      real*8 a(3,3)
      open(90,file=fn)
      read(90,*)
      read(90,*)
      read(90,*)((a(j,i),j=1,i),i=1,3)
      a(2,1)=a(1,2)
      a(3,1)=a(1,3)
      a(3,2)=a(2,3)
      close(90)
      return
      end
c     ============================================================
      SUBROUTINE readpolg(a,fn)
      character*(*)fn
      real*8 a(3,3)
      open(90,file=fn)
      read(90,*)
      read(90,*)
      read(90,*)((a(j,i),i=1,3),j=1,3)
      close(90)
      return
      end
c     ============================================================
      SUBROUTINE readpola(a,fn)
      character*(*)fn
      real*8 a(3,3,3)
      open(90,file=fn)
      read(90,*)
      read(90,*)
      do 1 k=1,3
      read(90,*)((a(i,j,k),i=1,j),j=1,3)
      do 1 j=1,3
      do 1 i=1,j
1     a(j,i,k)=a(i,j,k)
      close(90)
      return
      end
c     ============================================================
      SUBROUTINE READRXS(N,R,ND,title)
      IMPLICIT none
      integer*4 N
      real*8 R(3,N)
      integer*4 ND(N),i,ix
      CHARACTER*80 title
      READ(2,2000) title
2000  FORMAT(A80)
      read(2,*)N
      do 1 i=1,N
1     READ(2,*)ND(i),(R(ix,i),ix=1,3)
      RETURN
      END
c     ============================================================
      SUBROUTINE enax(N,R)
      IMPLICIT none
      integer*4 N,i,ix
      real*8 R(3,N)
      do 1 i=1,N
      do 1 ix=1,3
1     R(ix,i)=-R(ix,i)
      RETURN
      END
c     ============================================================
      SUBROUTINE WRITERX(N,R,ND,title)
      IMPLICIT none
      integer*4 N,ND(*),I
      REAL*8 R(3,N)
      character*80 title
      WRITE(2,2000)title
2000  FORMAT(a80)
      write(2,*)N
      DO 1 I=1,N
1     WRITE(2,2001)ND(I),R(1,I),R(2,I),R(3,I),0,0,0,0,
     10,0,0,0.0
2001  FORMAT(I5,3F12.6,7I5,F8.4)
      RETURN
      END
c     ============================================================
      SUBROUTINE READTEN(NAT,P,AI,AJ,PV)
      IMPLICIT INTEGER*4 (I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION P(NAT,3,3),AI(NAT,3,3),AJ(NAT,3,3),PV(NAT,3,3)
      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)                                   
      DO 100 L=1,NAT                                                 
      DO 100 J=1,3                                                    
100   READ (15,*) (PV(L,J,I),I=1,3)                                   
      RETURN
      END
c     ============================================================
      SUBROUTINE enap(NAT,AI,AJ)
      IMPLICIT INTEGER*4 (I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AI(NAT,3,3),AJ(NAT,3,3)
      DO 220 L=1,NAT                                                 
      DO 220 J=1,3                                                    
      DO 220 I=1,3                                                    
      AJ(L,J,I)=-AJ(L,J,I)
220   AI(L,J,I)=-AI(L,J,I)
      RETURN
      END
c     ============================================================
      SUBROUTINE WRITETEN(NAT,P,A,AI,PV)
      IMPLICIT INTEGER*4 (I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION P(NAT,3,3),A(NAT,3,3),PV(NAT,3,3),AI(NAT,3,3)
      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)
      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) (AI(L,J,I),I=1,3),L
      DO 100 L=1,NAT
      DO 100 J=1,3
100   WRITE(15,1501) (PV(L,J,I),I=1,3),L
      CLOSE(15)
      RETURN
      END
c     ============================================================
      SUBROUTINE READTTT(NAT,ALPHA,A,G)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER*4 (I-N)
      DIMENSION ALPHA(3*NAT,3,3),G(3*NAT,3,3),A(3*NAT,3,3,3)
      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,LDUM,(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,LDUM,(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,LDUM,(A(IIND,I,J,K),K=1,3)
      RETURN
      END
c     ============================================================
      SUBROUTINE enattt(NAT,ALPHA)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER*4 (I-N)
      DIMENSION ALPHA(3*NAT,3,3)
      DO 1 L=1,NAT
      DO 1 IX=1,3
      IIND=3*(L-1)+IX
      DO 1 I=1,3
      DO 1 J=1,3
1     ALPHA(IIND,I,J)=-ALPHA(IIND,I,J)
      return
      END
c     ============================================================
      subroutine rew(s)
      character*8 s
      write(6,1)s
1     format(/,/,20x,a8,' was rewritten !!',/,/)
      return
      end
c     ============================================================
      SUBROUTINE WRITETTT(NAT,ALPHA,A,G,s)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER*4 (I-N)
      DIMENSION ALPHA(3*NAT,3,3),G(3*NAT,3,3),A(3*NAT,3,3,3)
      character*(*)s
      OPEN(2,FILE=s)
      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,3F18.7)
      WRITE(2,2004)
2004  FORMAT(' The electric dipole magnetic dipole polarizability:',/,
     1       ' Atom/x    jx           jy           jz')
      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,(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)
      CLOSE(2)
      RETURN
      END