PROGRAM DARE
C     this program reads dalton 2 oputput
      IMPLICIT INTEGER*4 (I-N) 
      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER (nat0=500,MX3=3*nat0,BOHR=0.529177d0)
      DIMENSION r(nat0,3),FCAR(MX3,MX3),iz(nat0)
      CHARACTER*80 filename,s80
      CHARACTER*2 sy
c
      WRITE(6,*)' Dalton output reading'
      WRITE(6,*)
      WRITE(6,*)' Filename: '
      READ(5,'(A)')filename
      
     
      OPEN(7,FILE=filename)
      nat=0
2     read(7,80,end=999,err=999)s80      
80    format(a80)
      if(s80(3:30).eq.'Total number of coordinates:')then
       read(s80(31:40),*)nat
       nat=nat/3
       write(6,*)nat,' atoms'
       if(nat.gt.nat0)then
        write(6,*)'too many atoms'
        stop
       endif
      endif
      if(s80(26:48).eq.'Molecular geometry (au)')then
       read(7,*)
       read(7,*)
       do 1 ia=1,nat
       read(7,80)s80
       sy=s80(1:2)
       read(s80(10:80),*)(r(ia,ix),ix=1,3)
       iz(ia)=0
       if(sy.eq.' H')iz(ia)=1 
       if(sy.eq.' N')iz(ia)=7 
       if(sy.eq.' O')iz(ia)=8 
       if(sy.eq.' C')iz(ia)=6 
       if(iz(ia).eq.0)then
        write(6,*)'unknown atom'
        stop
       endif
1      continue
       write(6,*)'geometry read'
       open(8,file='FILE.X')
       write(8,80)filename
       write(8,*)nat
       do 5 i=1,nat 
5      write(8,800)iz(i),(r(i,ix)*BOHR,ix=1,3)
800    format(i4,3f15.6,' 0 0 0 0 0 0 0 0.0')
       close(8)
       write(6,*)'FILE.X written'
      endif
      if(s80(27:48).eq.'Molecular Hessian (au)')then

c
c      get rid of the symmetry nonsense:
       idp3=0
       idp2=0
       idp1=0
       is3=0
       is2=0
       is1=0
       ic3=0
       ic2=0
       ic1=0
       il=0
901    read(7,80,err=999,end=999)s80
       il=il+1
       ic3=ic2
       ic2=ic1
       ic1=ic
       is3=is2
       is2=is1
       is1=is
       idp3=idp2
       idp2=idp1
       idp1=idp
       idp=0
       is=0
       ic=0
       if(s80(12:19).eq.'Symmetry')ic=1
       do 902 i=1,80
       if(s80(i:i).ne.' ')is=is+1
902    if(s80(i:i).eq.'.')idp=idp+1
       if(idp1+idp+idp2+idp3.eq.0.and.is+is2.eq.0.
     1 and.ic3+ic2+ic1+ic.eq.0.and.il.ge.4.and.is1.ne.0)then
        backspace 7
        backspace 7
        backspace 7
        backspace 7
       else
        goto 901
       endif
        
       read(7,*)
       N=3*nat

       N1=1
11     N3=N1+5
       IF(N3.GT.N)N3=N
       i4=0
       read(7,*)
       read(7,*)
       read(7,*)
       DO 130 LN=N1,N
       i4=i4+1
       read(7,80)s80
       read(s80(10:80),*)(FCAR(LN,J),J=N1,MIN(LN,N3))
       if(i4.eq.3)then
        i4=0
        read(7,*)
       endif
130    continue
       N1=N1+6
       IF(N3.LT.N)GOTO 11

       write(6,*)'Hessian read'
       call WRITEFF(MX3,N,FCAR)
       write(6,*)'FILE.FC written'

      endif
      goto 2
999   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)
      open(20,file='FILE.FC')
      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)
      close(20)
      RETURN
      END