PROGRAM GAR_CFOUR
C     this program reads vibrational output of CFOUR
c     and saves Hessian to FILE.FC and geometry to FILE.X
      IMPLICIT none
      integer*4 NT0,MX3,MENDELEV
      PARAMETER (NT0=500,MX3=3*NT0,MENDELEV=89)
      integer*4 nat,i,j,k,nat3,nwv,idum,ii,it,iargc,
     1ix,jx,kx,ia,NV
      real*8 x(NT0,3),e(MX3),s(MX3,MX3),CONSTS,zmass(NT0),d(MX3),
     1uv(3,3),a,b,c,ab,ac,bc,alpha,beta,gamma,pi,ca,sb,cb,cg,sg,
     1o11,o11i,o12,o12i,o22,o22i,o23,o23i,o33,o33i,car,sar,v,o13,o13i,
     1f(MX3,MX3),w2,c1,adum,ram(MX3),alphaq(MX3,3,3),alphac(MX3,3,3),
     1p(NT0,3,3),kind(NT0),w,ai,bohr
      character*80 st,fn,s80
      CHARACTER*2 atsy(MENDELEV),s2
      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'/
      logical lram,lrd,lsm

      lram=.false.
      lrd=.false.
      lsm=.false.
      c1=1302.828d0
      CONSTS=4.359828d0/0.5291772d0/0.5291772d0
      pi=4.0d0*atan(1.0d0)
      nat=0
      nat3=0
      bohr=0.529177d0
c
      open(88,file='FCMFINAL')
      read(88,*)nat,nat3
      if(nat.gt.NT0)call report('Too many atoms')
      read(88,881)((f(i,j),j=1,nat3),i=1,nat3)
881   format(3f20.11)
      close(88)

      open(20,file='FILE.FC')
      call WRITEFF(MX3,nat3,f)
      close(20)
      write(6,*)'FILE.FC written'

      open(88,file='DIPDER')
      do 102 i=1,3
      read(88,*)
      do 102 j=1,nat
102   read(88,*)p(j,1,i),(p(j,ix,i),ix=1,3)
      close(88)

      call WRITETEN(NT0,P,P,.false.,NAT)

      open(88,file='GRD')
      read(88,*)
      do 103 j=1,nat
103   read(88,*)kind(j),(x(j,ix),ix=1,3)
      close(88)

      open(89,file='FILE.X')
      write(89,*)'CFOUR'
      write(89,*)nat
      do 90 i=1,nat
90    write(89,890)int(kind(i)),(x(i,k)*bohr,k=1,3)
890   format(i3,3f12.6,' 0 0 0 0 0 0 0 0.0')
      close(89)
      write(6,*)'FILE.X written'

      open(88,file='vib-harmonic.out')
      nv=0
1     read(88,880,end=99,err=99)s80
880   format(a80)
      if(s80(39:46).eq.'(km/mol)')then
       read(88,*)
2      read(88,880)s80
       if(s80(3:4).eq.'--')goto 99
       read(s80(18:33),*)w
       read(s80(35:48),*)ai
       if(w.gt.1.0d0)then
        nv=nv+1
        e(nv)=w
        d(nv)=ai
       endif
       goto 2
      endif
      goto 1
99    close(88)

      open(85,file='DOG.TAB')
      write(85,891)
891   format('Spectrum from CFOUR',/)
      write(85,892)
892   format(60(1h-))
      do 10 i=1,nv
10    write(85,893)i,e(i),d(i)
893   format(i8,5f15.6)
      write(85,892)
      close(85)
      write(6,*)'DOG.TAB written'
      
      lram=.false.
      if(lram)then
       open(85,file='ROA.TAB')
       write(85,891)
       write(85,892)
       do 11 i=1,nat3
11     if(e(i).gt.1.0d0)write(85,893)i,e(i),ram(i),ram(i),ram(i)
       write(85,892)
       close(85)
       write(6,*)'ROA.TAB written'
      endif
      
      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.0d0
      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 REPORT(RS)
      CHARACTER*(*) RS
      WRITE(6,3000)
3000  FORMAT(/,80(1H*))
      WRITE(6,*)RS
      WRITE(6,3001)
3001  FORMAT(80(1H*),/,/,'PROGRAM STOPPED')
      STOP
      END

      SUBROUTINE WRITETEN(N0,P,A,LVCD,NAT)
      IMPLICIT INTEGER*4 (I-N) 
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION P(N0,3,3),A(N0,3,3)
      LOGICAL LVCD
c     BOHR=0.52917705993d0
      Z0=0.0d0
      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