PROGRAM INTYFC
      IMPLICIT none
      integer*4 NA,NOB,i,j,a,b,NOAT,iold
      real*8 f,av
      real*8,allocatable::BB(:,:),FI(:,:),FC(:,:),T(:,:),sf(:)
      logical lsc

      WRITE(6,600)
600   format('   Internal -> Cartesian Force Field Transformation',/,/,
     112x,' Input:  INTY.FC  Internal FF',/,
     112x,'            B.MAT B-matrix',/,
     112x,'          ASK.LST (optional) scale factors',/,
     112x,'Output: FILEX.FC  Cartesian FF',/)      
      NOB=1
      NA=1
      allocate(BB(NOB,NA))
      call rb(0,NOB,NA,BB)
      deallocate(BB)
      allocate(BB(NOB,NA),FI(NOB,NOB),FC(NA,NA),T(NA,NOB))
      call rb(1,NOB,NA,BB)
      NOAT=NA/3                                                       
      write(6,*)'B.MAT read,',NOAT,' atoms,',NOB,' coordinates'
      call rdfc(FI,NOB)
      write(6,*)'INTY.FC read'
      inquire(file='ASK.LST',exist=lsc)
      if(lsc)then
       write(6,*)'ASK.LST found'
       allocate(sf(NOB))
       open(9,file='ASK.LST')
       iold=0
       sf=1.0d0
       a=0
  101  read(9,*,end=99,err=99)f,i
       a=a+1
       av=0.0d0
       do 3 j=iold+1,i
       av=av+FI(j,j)
  3    sf(j)=abs(f)
       av=av/(i-iold)
       write(6,602)a,iold+1,i,f,av
602    format(i3,': from',i5,' to',i5,f8.3,', <FF>:',f12.4)
       iold=i
       goto 101
  99   close(9)
       write(6,*)a,' scale factors read'
       do 5 i=1,NOB
       do 5 j=i,NOB
       FI(i,j)=FI(i,j)*dsqrt(sf(i)*sf(j))
5      FI(j,i)=FI(i,j)
       write(6,*)'Internal FF scaled'
      endif
      T=0.0d0
      do 1 a=1,NA
      do 1 j=1,NOB
      do 1 i=1,NOB
1     T(a,j)=T(a,j)+BB(i,a)*FI(i,j)
      FC=0.0d0
      do 2 a=1,NA
      do 2 b=1,NA
      do 2 j=1,NOB
2     FC(a,b)=FC(a,b)+BB(j,b)*T(a,j)
      call writeff(NA,FC)
      write(6,*)'FILEX.FC written'
      end

      SUBROUTINE WRITEFF(N,FCAR)
      IMPLICIT INTEGER*4 (I-N) 
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION FCAR(N,N)
      open(20,FILE='FILEX.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 rdfc(FO,NOB)
      implicit none
      integer*4 NOB,N,N1,N3,LN,J,I
      real*8 FO(NOB,NOB)
      OPEN(8,FILE='INTY.FC')
      read(8,*)
      N=0
      N1=1
199   N3=N1+4
      IF(N3.GT.NOB)N3=NOB
      read(8,*)
      DO 1301 LN=N1,NOB
      read(8,*)FO(LN,N1),(FO(LN,J),J=N1,MIN(LN,N3))
1301  N=N+MIN(LN,N3)-N1+1
      N1=N1+5
      IF(N3.LT.NOB)GOTO 199
      close(8)
      DO 31 I=1,NOB  
      DO 31 J=I+1,NOB                                                   
   31 FO(I,J)=FO(J,I) 
      FO=FO/4.3597482D0*(0.529177249D0*0.529177249D0)
      return
      end