program stocart
      implicit none
      integer*4 NA,NOB0,I,J,K
      real*8,allocatable::FI(:,:),B(:,:),F(:,:),T(:,:)
      write(6,600)
600   format(' Internal force field to cartesian',/,
     1       '    Input:  SCALED.FC',/,
     1       '            B.MAT',/,
     1       '    Output: FILEC.FC')
      NOB0=1
      NA=1
      allocate(B(NOB0,NA))
      call rb(0,NOB0,NA,B)
      deallocate(B)
      allocate(FI(NOB0,NOB0),B(NOB0,NA),F(NA,NA),T(NOB0,NA))
      call rb(1,NOB0,NA,B)
      call READFC(NOB0,FI)
      T=0.0d0
c     Fc  = Bt Fi B
      do 1 I=1,NOB0
      do 1 J=1,NA
      do 1 K=1,NOB0
1     T(I,J)=T(I,J)+FI(I,K)*B(K,J)

      F=0.0d0
      do 2 I=1,NA
      do 2 J=1,NA
      do 2 K=1,NOB0
2     F(I,J)=F(I,J)+T(K,J)*B(K,I)
      call WRITEFF(NA,F)
      end

      SUBROUTINE WRITEFF(N,FCAR)
      IMPLICIT INTEGER*4 (I-N) 
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION FCAR(N,N)
      open(20,file='FILEC.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

      subroutine rb(ic,NOB0,NA,B)
      implicit none
      integer*4 ic,NA,i,NOB0,nn,ii,ia,ix
      real*8 b(NOB0,NA)
      open(9,file='B.MAT')
      read(9,*)nob0
      read(9,*)na
      if(ic.eq.0)goto 99
      b=0.0d0
      read(9,*)
      do 13  i=1,nob0
      read(9,*)
      read(9,*)nn
      do 13 ii=1,nn
13    read(9,*)ia,ix,b(i,ix+3*(ia-1))
99    close(9)
      return
      end

      SUBROUTINE READFC(NA,FCAR)
      implicit none
      integer*4 NA,N,NTT,NTE,I,J,NT
      real*8 FCAR(NA,NA)
      OPEN(20,FILE='SCALED.FC',STATUS='OLD')
      READ(20,*)
      READ(20,*)
      READ(20,*)
      N=NA
      NTT= -5
      NTE= 6
      IF (NTE.GT.N) GO TO 120
  110 NTT=NTT+6
      READ(20,*)
      DO 100 I=NTT,N
      NT=I
      IF (NT.GT.NTE) NT=NTE
      READ(20,*) FCAR(I,NTT),(FCAR(I,J),J=NTT,NT)
600   format(6f12.5)
  100 continue
      NTE=NTE+6
      IF (NTE.LE.N) GOTO 110
  120 NTT=NTT+6
      DO 130 I=NTT,N
  130 READ(20,*) FCAR(I,NTT),(FCAR(I,J),J=NTT,I)
      CLOSE(20)                                                       
      DO 31 I=1,N                                                     
      DO 31 J=I+1,N                                                   
   31 FCAR(I,J)=FCAR(J,I)                                             
      DO 6 I=1,N                                                      
      DO 6 J=1,N                                                      
6     FCAR(I,J)=FCAR(I,J)/4.3597482D0*(0.529177249D0*0.529177249D0) 
c     1Hartree=4.3597482e-18 J; 1Bohr=0.529177249A
      return
      end