program mocoefs
c **************** Program MOCOEFS *****************
c This program is designed to read in (from the
c keyboard) the LCAO-MO coefficient matrix and write
c it out to disk.  Alternatively, you can choose to
c have a unit matrix (as your initial guess) put out
c to disk.
c
c Copyright (C) 1992 Jeff Nichols and Jack Simons
c
c **************************************************
      implicit real (a-h,o-z)
      include "limits.h"
      logical yesno
      character*30 dfname, fname, dscrpt
      character*1 ans
c
c     set core needed to:
c         1 square array of order maxorb
c     total = maxorb**2
c
      dimension pcore(maxorb**2),ipntr(10)
c
c     Calculate and show memory use.
c
      itotal = maxorb**2 + 10
      call modinfo('mocoefs     ')
      call shwmem('mocoefs     ',itotal)
      call goon
c     
c     Open the MO-AO coefficient file.
c     
      dscrpt = 'MO-AO coefficients'
      ids = 18
      dfname = 'mocoefs.dat'
      idf = 11
      fname = '                              '
      ifn = 30
      iflnum = 31
      call wfile(fname,ifn,dscrpt,ids,dfname,idf,iflnum,yesno)
   10 continue
      write(*,1010)
      read(*,*)iorb
      if(iorb.gt.maxorb)then
        write(*,1020)maxorb
        goto 10
      endif
      ipntr(1) = 1
      ipntr(2) = ipntr(1) + iorb*iorb
      write(*,*)' Would you like to have a unit matrix '
      write(*,*)' put out to disk as your MO-AO coefficient '
      write(*,*)' matrix? < y or n > '
      read(*,'(a)')ans
      if(ans.eq.'Y'.or.ans.eq.'y')then
        call umtrx(pcore(ipntr(1)),iorb)
      else
        call rdmatu(dscrpt,ids,pcore(ipntr(1)),iorb,iorb)
      endif
      call wtmatu(dscrpt,ids,pcore(ipntr(1)),iorb,iorb)
      if(yesno)then
        call wtmatd(fname,ifn,dscrpt,ids,pcore(ipntr(1)),
     &              iorb,iorb,iflnum)
c
c       Close MO coefficients file.
c
        close(unit=31)
      endif
      call qmexit
      stop
 1010 format(/,' Input the number of orbitals in your system: ')
 1020 format(' Maximum number of orbitals is ',I2,'. ',/,
     &       ' Please try again. ')
      end
      subroutine umtrx(c,n)
      implicit real (a-h,o-z)
      dimension c(n,n)
      do 20 i = 1, n
        DO 10 J = 1, N
          c(i,j) = 0.0e0
          if(i.eq.j)c(i,j) = 1.0e0
   10   continue
   20 continue
      return
      end