IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION FCAR(180,180),PP(120,3,3),R(120,3),Z(120)
      CHARACTER*40 STRING
      CHARACTER*15 S15
      CHARACTER*60 FNAME
      CHARACTER*1 AT(120)
      LOGICAL SECOND,DIPOLE,MAGNET
      WRITE(*,*)'           THIS PROGRAM READS CADPAC5 OUTPUT AND DOES '
      WRITE(*,*)'            A FILE WITH FORCE CONSTANT THAT CAN BE'
      WRITE(*,*)'              PROCESSED BY CTI92.FORTRAN ON CMS'
      WRITE(*,*)'                 AND THE FILE DOG.INP WITH THE '
      WRITE(*,*) '                  POLARIZABILITY TENSORS'
      WRITE(*,*) 
      WRITE(6,6666)
6666  FORMAT(41H                      PETR BOUR'S PROGRAM)
      WRITE(*,*)
      WRITE(*,*)' THE CADPAC5 OUTPUT FILENAME:'
      READ(*,'(A)')FNAME
      WRITE(*,*)' NUMBER OF ATOMS:'
      READ(*,*)IA
      N=3*IA
      OPEN(20,FILE=FNAME,STATUS='OLD')
      WRITE(*,*)'THE FORCE FIELD NEW FILE NAME:'
      READ(*,'(A)')FNAME
      OPEN(21,FILE=FNAME)
      WRITE(*,*)'THE TENSOR FILE NAME :'
      READ(*,'(A)')FNAME
      OPEN(22,FILE=FNAME)
      WRITE(*,*)'THE COORDINATE FILE NAME :'
      READ(*,'(A)')FNAME
      OPEN(23,FILE=FNAME)
      SECOND=.FALSE.
      DIPOLE=.FALSE.
      MAGNET=.FALSE.
  201 READ(20,1111,ERR=60,END=60)STRING
1111  FORMAT(A40)
C                    12345678901234567890
      IF (STRING(26:40).EQ.'New Molecular G')THEN
       WRITE(*,*)' Geometry found'
       READ(20,*)
       READ(20,*)
       DO 4031 I=1,IA
4031   READ(20,21000)AT(I),(R(I,II),II=1,3)
21000 FORMAT(6X,A1,9X,3F20.10)
       DO 4041 I=1,IA
       DO 4041 IX=1,3
4041   R(I,IX)=R(I,IX)*0.5291770599
       WRITE(23,*)
       DO 4051 I=1,IA
       K=0
       IF(AT(I).EQ.'H')K=4
       IF(AT(I).EQ.'C')K=1
       IF(AT(I).EQ.'O')K=2
       IF(AT(I).EQ.'N')K=3
4051   WRITE(23,20001)K,(R(I,II),II=1,3)
       WRITE(23,*)'9999 0.0 0.0 0.0 0 0 0 0 0.0'
      ENDIF
      IF (STRING(1:20).EQ.' Geometry, (in atomi')THEN
       WRITE(*,*)' Geometry found'
       DO 402 I=1,5
402    READ(20,*)
       DO 403 I=1,IA
403    READ(20,20000)S15,Z(I),(R(I,II),II=1,3)
20000 FORMAT(A15,F4.1,F14.8,2F15.8)
       DO 404 I=1,IA
       DO 404 IX=1,3
404    R(I,IX)=R(I,IX)*0.5291770599
       WRITE(23,*)
       DO 405 I=1,IA
       K=0
       IF(INT(Z(I)).EQ.1)K=4
       IF(INT(Z(I)).EQ.6)K=1
       IF(INT(Z(I)).EQ.8)K=2
       IF(INT(Z(I)).EQ.7)K=3
405    WRITE(23,20001)K,(R(I,II),II=1,3)
       WRITE(23,*)'9999 0.0 0.0 0.0 0 0 0 0 0.0'
20001 FORMAT(I4,3F12.7,' 0 0 0 0  0.0')
      ENDIF
      IF (STRING(1:20).EQ.' Total cartesian sec'.OR.
     1    STRING(1:20).EQ.' Cartesian Force Con'    )THEN
       WRITE(*,*)' Second derivatives found ... '
       SECOND=.TRUE.
       DO 202 I=1,7
202    READ(20,*)
       N0C=0
204    NC=6*N0C+1
       MC=NC+5
       IF (MC.GT.N)MC=N
       DO 203 IC=1,N
203    READ(20,270)(FCAR(IC,JC),JC=NC,MC)
270    FORMAT(18X,6F10.5)
       IF(MC.LT.N) THEN
        DO 205 I=1,7
205     READ(20,*)
        N0C=N0C+1
        GOTO 204
       ENDIF
       M=5
       MI=-4
207    MI=MI+5
       MJ=M-4
       IF (M.GT.N) M=N
       DO 206 I=MI,N
       MW=M
       IF (MW.GT.I) MW=I
206    WRITE(21,27)I,(FCAR(I,J),J=MJ,MW)
   27  FORMAT(I4,5(D14.6))
       IF (M.LT.N)THEN
        M=M+5
        GOTO 207
       ENDIF
       CLOSE(21)
      ENDIF
C                    12345678901234567890
      IF (STRING(1:20).EQ.' SCF Dipole derivati')THEN
       DIPOLE=.TRUE.
       WRITE(*,*) ' SCF Dipole derivatives found ...'
       READ(20,*)
       DO 30 I=1,IA
       READ(20,*)
       READ(20,*)
       DO 30 K=1,3
30     READ(20,300)(PP(I,K,J),J=1,3)
300   FORMAT(20X,3F16.8)
       WRITE(22,301)IA,N,0
301   FORMAT(16I5)
       DO 31 I=1,IA
       DO 31 K=1,3
31     WRITE(22,300)(PP(I,K,J),J=1,3)
      ENDIF
C                    12345678901234567890
      IF (STRING(1:20).EQ.' Correlated dipole d')THEN
       WRITE(*,*) ' Correlated dipole derivatives found in Debye/A ...'
       DIPOLE=.TRUE.
       CON=0.20819
       READ(20,*)
       DO 3012 I=1,IA
       READ(20,*)
       READ(20,*)
       DO 3012 K=1,3
3012   READ(20,*)(PP(I,K,J),J=1,3)
       WRITE(22,301)IA,N,0
       DO 312 I=1,IA
       DO 312 K=1,3
312    WRITE(22,300)(PP(I,K,J)*CON,J=1,3)
      ENDIF
C                    12345678901234567890
      IF (STRING(1:20).EQ.' SCF dipole derivati'.AND.(.NOT.DIPOLE))THEN
       WRITE(*,*) ' SCF Dipole derivatives found in debye/A ...'
       CON=0.20819
       READ(20,*)
       DO 3011 I=1,IA
       READ(20,*)
       READ(20,*)
       DO 3011 K=1,3
3011   READ(20,*)(PP(I,K,J),J=1,3)
       WRITE(22,301)IA,N,0
       DO 311 I=1,IA
       DO 311 K=1,3
311    WRITE(22,300)(PP(I,K,J)*CON,J=1,3)
      ENDIF

C                    12345678901234567890
      IF (STRING(1:20).EQ.' Total wavefunction ')THEN
       MAGNET=.TRUE.
       WRITE(*,*)' J and I tensors found'
       DO 48 I=1,4
48     READ(20,*)
       DO 40 I=1,IA
       READ(20,*)
       READ(20,*)
       DO 40 K=1,3
40     READ(20,*)(PP(I,K,J),J=1,3)
       DO 49 I=1,6
49     READ(20,*)
       DO 41 I=1,IA
       READ(20,*)
       READ(20,*)
       DO 41 K=1,3
41     READ(20,*)(PP(IA+I,K,J),J=1,3)
       DO 42 I=1,2*IA
       DO 42 K=1,3
42     WRITE(22,400)(PP(I,K,J),J=1,3)
400   FORMAT(3F16.8,' I,J tensors')
      ENDIF
C                    12345678901234567890
      IF (STRING(1:20).EQ.' ---------------VELO')THEN
       WRITE(*,*)' Dipole velocity derivatives found ...'
       DO 59 I=1,6
59     READ(20,*)
       DO 50 I=1,IA
       READ(20,*)
       READ(20,*)
       READ(20,*)
       DO 50 K=1,3
50     READ(20,*)(PP(I,K,J),J=1,3)
       DO 51 I=1,IA
       DO 51 K=1,3
51     WRITE(22,500)(PP(I,K,J),J=1,3)
500    FORMAT(3F16.8,' PV')
       CLOSE(22)
      ENDIF
      GOTO 201
60    CLOSE(20)
      CLOSE(23)
      WRITE(6,*)' PROGRAM FINISHED OK'
      STOP
      END