program getfpc
      implicit none
c
c     rewrites mullican atomic charges from gaussian output
c     or from FILE.TEN
      integer ia,nat,nat0,ic,nc,i,j,N,NM,idum2,idum1
      parameter (nat0=3000)
      integer ix(nat0,nat0)
      real a,b,c,x(nat0),q(nat0),qic,A0,w(3*nat0)
      character*80 fn,s80
      character*1 md
      character*4 s4
c
      write(6,*)'Mulliken or diagonal (m/d) ? '
      read(5,'(a)')md
      if(md.eq.'d'.or.md.eq.'D')then
       open(9,file='FILE.TEN')
       read(9,*)nat
       if(nat.gt.nat0)then
        write(6,*)'Too many atoms'
        stop
       endif
       do ia=1,nat
        read(9,*)a
        read(9,*)b,b
        read(9,*)c,c,c
        q(ia)=(a+b+c)/3.0
       enddo
       close(9)
       write(6,*)nat,' atoms in FILE.TEN'
      else
       write(6,*)'Gaussian output filename:'
       read(5,'(a)')fn
       ic=0
       open(8,file=fn)
1      read(8,800,end=888,err=888)s80
800    format(a80)
       if(s80(2:25).eq.'Mulliken atomic charges:')then
        read(8,*)
2       read(8,800,end=888,err=888)s80
        if(s80(1:4).ne.' Sum')then
         read(s80(11:21),*,end=888,err=888)qic
         ic=ic+1
         if(ic.gt.nat0)then
          write(6,*)'Too many charges'
          stop
         endif
         q(ic)=qic
         goto 2
        else
         goto 888
        endif
       endif
       goto 1
888    close(8)
       nc=ic
       write(6,*)nc,' charges read'
       nat=nc
      endif

      OPEN(7,FILE='FTRY.INP')
      READ(7,80)s80
80    format(a80)
      read(7,*)N
      DO 3 I=1,N
3     read(7,4444)X(I),NM,(IX(I,J),J=1,NM)
4444  FORMAT(F9.6,I3,100I3)
      read(7,444)(X(I),I=1,NAT)
444   FORMAT(6F12.6)
      read(7,*)idum1
      read(7,444)(X(I),I=1,NAT)
      read(7,*)idum2
      read(7,444)(W(I),I=1,3*NAT)
      CLOSE(7)
      OPEN(7,FILE='FTRY.INP')
      write(7,80)s80
      write(7,40)N
40    format(i4)
      DO 31 I=1,N
31    write(7,4444)X(I),NM,(IX(I,J),J=1,NM)
      write(7,444)(Q(I),I=1,NAT)
      write(7,40)idum1
      write(7,444)(X(I),I=1,NAT)
      write(7,40)idum2
      write(7,444)(W(I),I=1,3*NAT)
      CLOSE(7)
      WRITE(6,*)'FTRY.INP overwritten'
      END