c ****************** Program QMLIB *****************
c This is a library of subroutines and functions
c which are used by the QMIC programs.
c
c Copyright (C) 1992 Jeff Nichols and Jack Simons
c
c **************************************************
      subroutine qmexit
      implicit real (a-h,o-z), integer(i-n)
      character*1 ans
   10 continue
      write(*,1000)
      read(*,'(a)')ans
      if(ans.eq.'Y'.or.ans.eq.'y')then
        stop'qmic'
      else
        goto 10
      endif
      return
 1000 format(//,' Ready to exit and clear the screen? <y or n> ')
      end
      subroutine goon
      implicit real(a-h,o-z)
      character*1 ans
      write(*,*)'  '
      write(*,*)' Ready to continue? <y or n> '
      read(*,'(a)')ans
      if(ans.eq.'Y'.or.ans.eq.'y')then
        return
      else
        call qmexit
      endif
      end
      SUBROUTINE shwlim
      implicit real (a-h,o-z), integer(i-n)
      include "limits.h"
c      write(*,*)'  '
c      write(*,*)' maxorb: ',maxorb
c      write(*,*)' mxosq: ',mxosq
c      write(*,*)' mxo2: ',mxo2
c      write(*,*)' mxo4: ',mxo4
c      write(*,*)' nsh: ',nsh
c      write(*,*)' nprim: ',nprim
c      write(*,*)' mxl: ',mxl
c      write(*,*)' natoms: ',natoms
c      write(*,*)' ntlp1: ',ntlp1
c      write(*,*)' nbits: ',nbits
c      write(*,*)' maxdet: ',maxdet
c      write(*,*)' mxdet2: ',mxdet2
c      write(*,*)' maxact: ',maxact
c      write(*,*)' mmax: ',mmax
c      write(*,*)' maxrow: ',maxrow 
c      write(*,*)' maxcol: ',maxcol
c      write(*,*)'  '
      write(*,*)'  '
      write(*,*)' ********** Current QMIC program limits ********** '
      write(*,*)' Maximum number of atoms: ',natoms
      write(*,*)' Maximum number of orbitals: ',maxorb
      write(*,*)' Maximum number of shells: ',nsh
      write(*,*)' Maximum number of primitives per shell: ',nprim
      write(*,*)' Maximum orbital angular momentum: ',mxl
      write(*,*)' Maximum number of active orbitals in the CI: ',
     &            maxact
      write(*,*)' Maximum number of determinants: ',maxdet
      write(*,*)' Maximum matrix size (row or column): ',mmax
      write(*,*)' ************************************************* '
      write(*,*)'  '
      return
      end
      subroutine rdmatu(dscrpt,ids,array,n,m)
c
c     subroutine to read in a matrix from user input
c     by column.
c
      implicit real (a-h,o-z), integer(i-n)
      character*1 dscrpt(ids)
      character*1 ans
      dimension array(n,m)
c     
c     Read in the matrix (column at a time).
c     
      write(*,*)' Begin reading in the ',(dscrpt(i),i=1,ids),
     &          '. '
      write(*,*)' (Note, this matrix will be read in by columns.) '
      do 30 i = 1,m
   10   continue
        write(*,1000)i,i
        read(*,*)(array(j,i),j=1,n)
        write(*,1010)i
        write(*,*)
        write(*,'(1x,f15.8,/)')(array(j,i),j=1,n)
        write(*,*)
        write(*,*)' Is this correct? <y or n> '
        read(*,'(a)')ans
        if(ans.eq.'Y'.or.ans.eq.'y')then
   20     continue
        else
          goto 10
        endif
   30 continue
      return
 1000 format(' Input vector ',I2,' (column ',I2,') :')
 1010 format(' Input column ',I2,' is: ')
      end
      subroutine wtmatu(dscrpt,ids,array,n,m)
c
C     Subroutine to write a matrix to user output
c
      implicit real (a-h,o-z), integer(i-n)
      character*1 dscrpt(ids)
      dimension array(n,m)
      write(*,*)' The ',(DSCRPT(I),I=1,IDS),': '
      call matout(array,n,m,n)
      return
      end
      subroutine wtmatd(fname,ifn,dscrpt,ids,array,n,m,iflnum)
c
c     Subroutine to write an NxM matrix to disk.
c
      implicit real (a-h,o-z), integer(i-n)
      character*1 dscrpt(ids), fname(ifn)
      dimension array(n,m)
      rewind (unit=iflnum)
      do 10 i = 1,m
        write(iflnum,'(1x,f15.8)')(array(j,i),j=1,n)
   10 continue
      write(*,*)' The ',(DSCRPT(I),I=1,IDS),
     &          ' write completed to file: ',(fname(i),i=1,ifn)
      return
      end
      subroutine rdmatd(fname,ifn,dscrpt,ids,array,n,m,iflnum)
c
c     Subroutine to read an NxM matrix from disk.
c
      implicit real (a-h,o-z), integer(i-n)
      character*1 dscrpt(ids), fname(ifn)
      dimension array(n,m)
      rewind (unit=iflnum)
      do 10 i = 1,m
        read(iflnum,*)(array(j,i),j=1,n)
   10 continue
      write(*,*)' The ',(dscrpt(i),i=1,ids),
     &          ' read completed from file: ',(fname(i),i=1,ifn)
      return
      end
      subroutine matout(a,nr,nc,m)
      implicit real(a-h,o-z), integer(i-n)
c
c     Rectangular array output.
c     input:
c       A    Array to be written to for006.
c       NR   The row order of A.
c       NC   The column order of A.
c       M    The row dimension of A in the calling routine.
c
      character*15 aline
      dimension a(m,nc)
      dimension aline(5)
      data aline /5*' ------------- '/
      maxcol=0
      nsets=(nc-1)/5+1
      do 100 ns=1,nsets
        mincol=maxcol
        if(ns .eq. nsets) then
          numcol=nc-mincol
        else
          numcol=5
        end if
        maxcol=mincol+numcol
        mincol=mincol+1
        write(*,1000)(i,i=mincol,maxcol)
        write(*,1010)(aline(i),i=1,numcol)
        do 90 i=1,nr
          write(*,1020) i,(a(i,j),j=mincol,maxcol)
   90   continue
  100 continue
      write(*,1030)
 1000 format(/,5x,5(6x,i3,6x))
 1010 format(5x,5a15)
 1020 format(1x,i3,1x,5(e14.7,1x))
 1030 format(/)
      return
      end
      subroutine wfile(fname,ifn,dscrpt,ids,dfname,idf,iflnum,
     &                 yesno)
      implicit real (a-h,o-z), integer(i-n)
      logical yesno
      character*30 fname
      character*1 dfname(idf), dscrpt(ids)
      character*1 ans
      yesno = .true.
      write(*,*)' Would you like to have the: ',
     &          (dscrpt(i),i=1,ids),' written '
      write(*,*)' to disk? <y or n>'
      read(*,'(a)')ans
      if(ans.eq.'Y'.or.ans.eq.'y')then
        write(*,*)' Please enter the name of the file in which to '
        write(*,*)' write ( the default will be: ',
     &            (dfname(i),i=1,idf),' ) '
        read(*,'(a)')fname
        ifn = 30
        if(fname.eq.' ')call equivf(fname,ifn,dfname,idf)
        ifn = length(fname,ifn)
        open(unit=iflnum,file=fname,access='sequential',
     &       status='unknown',form = 'formatted')
        write(*,*)' The ',(dscrpt(i),i=1,ids),
     &            ' will be written to file: ',fname
      else
        yesno = .false.
      endif
      return
      end
      subroutine rfile(fname,ifn,dscrpt,ids,dfname,idf,iflnum,
     &                 yesno)
      implicit real (a-h,o-z), integer(i-n)
      logical yesno, doesit
      character*30 fname
      character*1 dfname(idf), dscrpt(ids)
      character*1 ans
   10 continue
      yesno = .true.
      doesit = .false.
      write(*,*)' Would you like to have the: ',
     &          (dscrpt(i),i=1,ids),' read '
      write(*,*)' from disk? <y or n>'
      read(*,'(a)')ans
      if(ans.eq.'Y'.or.ans.eq.'y')then
        write(*,*)' Please enter the name of the file from which to '
        write(*,*)' read ( the default will be: ',
     &            (dfname(i),i=1,idf),' ) '
        read(*,'(a)')fname
        ifn = 30
        if(fname.eq.' ')call equivf(fname,ifn,dfname,idf)
        ifn = length(fname,ifn)
        inquire(file=fname,exist=doesit)
        if(doesit)then
          open(unit=iflnum,file=fname,access='sequential',
     &         status='unknown',form = 'formatted')
          write(*,*)' The ',(dscrpt(i),i=1,ids),
     &              ' will be read from file: ',fname
        else
          write(*,*)' The ',(dscrpt(i),i=1,ids),
     &              ' cannot be read from file: ',fname
          write(*,*)' the file ',fname
          write(*,*)'     ... DOES NOT EXIST!!!!. '
          write(*,*)' Retry? <y or n>'
          read(*,'(a)')ans
          if(ans.eq.'Y'.or.ans.eq.'y')then
            goto 10
          else
            yesno = .false.
          endif
        endif
      else
        yesno = .false.
      endif
      return
      end
      function length(a,lna)
      implicit real (a-h,o-z), integer(i-n)
c
c     This function finds the last nonblank character in a CHARACTER*1
c     array and returns its column number.
c
      character*1 a(lna)
      do 1080 i=lna,1,-1
        if(a(i).ne.' ') then
          length = i
          return
        end if
 1080 continue
      length = 0
      return
      end
      subroutine equivf(s1,is1,s2,is2)
      implicit real (a-h,o-z), integer(i-n)
      character*1 s1(is1), s2(is2)
      do 10 i = 1, is2
        s1(i) = s2(i)
   10 continue
      return
      end
      subroutine diaghe (a,n,e,nroot,p,nrow,sd)
csingle  1
      implicit real*4 (a-h,o-z), integer(i-n)
cdouble  1
c     implicit real*8 (a-h,o-z), integer(i-n)
complex  2
c     implicit complex (a-h,o-z), integer(i-n)
c     real*4 h,e,sd,h
      dimension a((n*(n+1))/2),p(nrow,*),e(n),sd(0:n-1)
      nr1=iabs(nroot)
      isr=nroot/max(nr1,1)
c
c     Householder reduction.
c     Diagonal left in E.
c     Subdiagonal left in SD.
c
      do 2000 n1=n,2,-1
        l=n1*(n1-1)/2
        l1=l+n1-1
        h=0
        do 2010 i=l+1,l1
          h=h+a(i)**2
 2010   continue
        if (h.ne.0) then
c
c         Form the normalized w vector and 
c         store result in sd(1:n1-1) and a(l+1:l1).
c
          h=sign(sqrt(h),a(l1))
          a(l1)=a(l1)+h
          h1=1/sqrt(2*h*a(l1))
          do 2020 i=1,n1-1
            sd(i)=a(l+i)*h1
            a(l+i)=sd(i)
            e(i)=0
 2020     continue
c
c         Form the p vector and store it in e(1:n1-1).
c
          l2=0
          do 2030 i=1,n1-1
            x=0
            y=sd(i)
            do 2040 j=1,i-1
              l2=l2+1
              x=x+a(l2)*sd(j)
              e(j)=e(j)+a(l2)*y
 2040       continue
            l2=l2+1
            e(i)=e(i)+x+a(l2)*y
 2030     continue
c
c         Find the k scalar (call it g here).
c
          g=0
          do 2050 i=1,n1-1
            g=g+sd(i)*e(i)
 2050     continue
          l2=0
c
c         Transform the matrix.
c
          do 2070 i=1,n1-1
            y=sd(i)
            x=2*(g*y-e(i))
            e(i)=x
            do 2080 j=1,i
              l2=l2+1
              a(l2)=a(l2)+x*sd(j)+y*e(j)
 2080       continue
 2070     continue
        endif
        sd(n1-1)=-h
        e(n1)=a(l1+1)
 2000 continue
      e(1)=a(1)
      sd(0)=0
c
c     Accumulate transformation matrices, if desired.
c
      if (nrow.ge.n) then
        p(1,1)=1
        do 2110 n1=1,n-1
          n2=n1+1
          l=n1*(n1+1)/2
          if (sd(n1).ne.0) then
            do 2100 i=1,n1
              x=0
              do 2120 j=1,n1
                x=x+a(l+j)*p(j,i)
 2120         continue
              x=2*x
              do 2140 j=1,n1
                p(j,i)=p(j,i)-a(l+j)*x
 2140         continue
 2100       continue
          endif
c
c         Zero the next row and column of p.
c
          do 2145 i=1,n1
            p(i,n2)=0
            p(n2,i)=0
 2145     continue
          p(n2,n2)=1
 2110   continue
      endif
c
c     Find mean, standard deviation, & upper bound on roots.
c
      se=0
      se2=0
      do 2150 i=1,n
        se=se+e(i)
        se2=se2+e(i)**2+2*sd(i-1)**2
 2150 continue
      amu=se/n
      amseig=se2/n
      x1=amu+isr*sqrt((n-1)*(amseig-amu*amu))
c
c     Set error tolerance (square of machine precision)
c
c      write(*,*)' amseig: ',amseig
csingle  1
      errt=amseig/1e11
cdouble  1
c     errt=amseig/1e26
c      write(*,*)' errt: ',errt
c
c     Find eigenvalues and eigenvectors of the tridiagonal matrix.
c
      do 2160 n1=n,max(n-nr1+1,2),-1
c
c     Find next root.
c
c        write (6,*) 'eigenvalue',n1
   10   x=x1
        r=1
        q1=0
        do 2170 i=1,n1
          sr=sd(i-1)**2/r
          r=x-e(i)-sr
          q=r/((x-e(i))*q1-sr*q2+1)
          x1=x-q
          if (x1*isr.ge.x*isr) goto 20
          q2=q1
          q1=1/q
 2170   continue
c        write (6,*) q
        if (x1*isr.lt.x*isr) goto 10
c  do next massaging transformation
   20   t=0
        s=0
        c=1
        d1=x-e(1)
        sub=sd(1)
        do 2180 i=1,n1-1
c
c         Do plane rotation.  S and C are the sine and cosine values 
c	  in the rotation matrix, S1 and C1 are those of the previous 
c	  rotation, C2 is from the second previous iteration, and T 
c	  is the non-tridiagonal element.  SUB is the original Ith 
c         subdiagonal element (before it was modified by the previous 
c	  plane rotation), and SUB1 is that of the previous rotation.
c	  
          c2=c1
          c1=c
          s1=s
          g=d1*c1-sub1*c2*s1
          r=sub*sub+g*g
          if (r.gt.errt) then
            r=sqrt(r)
            c=g/r
            s=sub/r
          else
            s=1
            c=0
          endif
c
c         The rotation matrix has been determined.  Now do the 
c         rotation itself.
c
          d1=x-e(i+1)
          sub1=sub
          sd(i-1)=sd(i-1)*c-t*s
          if (i.lt.n1-1) then
            sub=sd(i+1)
            t=-sub*s
            sd(i+1)=sub*c
          endif
          csq=c*c
          cs=c*s
          x1=e(i)
          y1=sd(i)*cs
          z1=e(i+1)
          y2=x1-z1
          e(i)=y2*csq+z1-2*y1
          sd(i)=cs*y2+sd(i)*(2*csq-1)
          e(i+1)=2*y1-y2*csq+x1
c
c         Update transformation matrix, if desired.
c
          if ((nrow.ge.n).and.(s.ne.0)) then
            i1=i+1
            do 2190 k=1,n
              x1=p(k,i)
              p(k,i)=x1*c-p(k,i1)*s
              p(k,i1)=x1*s+p(k,i1)*c
 2190       continue
          endif
 2180   continue
c
c       Decide if another iteration of this eigenvalue is necessary.
c
        er=sd(n1-1)**2+(x-e(n1))**2
        if (er.gt.errt) then
          x1=isr*(max(isr*x,isr*e(n1))+sqrt(er))
          goto 10
        endif
        x1=x
 2160 continue
      return
      end
      subroutine tprntd(a,nr)
      implicit real(a-h,o-z), integer(i-n)
      character*15 aline
c
c     This routine writes a triangular packed real array, A,
c     of order NR to standard out.
c
      dimension aline(5)
      dimension a((nr*(nr+1))/2)
      data aline /5*' ------------- '/
      isym2(i,j)=(i*(i-1))/2+j
      maxcol=0
      nsets=(nr-1)/5+1
      do 100 ns=1,nsets
        mincol=maxcol
        if(ns .eq. nsets) then
          numcol=nr-mincol
        else
          numcol=5
        end if
        maxcol=mincol+numcol
        mincol=mincol+1
        write(*,1000)(i,i=mincol,maxcol)
        write(*,1010)(aline(i),i=1,numcol)
        do 90 i=mincol,nr
          mxcol = min0(maxcol,i)
          write(*,1020) i,(a(isym2(i,j)),j=mincol,mxcol)
   90   continue
  100 continue
      write(*,1030)
 1000 format(/,5x,5(6x,i3,6x))
 1010 format(5x,5a15)
 1020 format(1x,i3,1x,5(e14.7,1x))
 1030 format(/)
      return
      end
      subroutine get1e(h,n,n2)
      implicit real (a-h,o-z), integer(i-n)
      dimension h(n2)
c     
c     Read in the one-electron integrals.
c     
      rewind(unit=30)
      il = (n*(n+1))/2
      do 10 i = 1,il
        read(30,*)h(i)
   10 continue
      return
      end
      subroutine get2e(g,n,n4)
      implicit real (a-h,o-z), integer(i-n)
      dimension g(n4)
c     
c     Read in a canonical list of two-electron integrals
c     from unit 30 skipping past the one-electron integrals.
c     
c     Skip past the one-electron integrals.
c     
      rewind(unit=30)
      il = (n*(n+1))/2
      do 10 i = 1,il
        read(30,*)g(i)
   10 continue
c
c     Read in the two-electron integrals.
c
      ind = 0
      do 50 i = 1,n
        do 40 k = 1,i
          do 30 j = 1,i
            lend = j
            if(i.eq.j)lend = k
            do 20 l = 1,lend
              ind = ind + 1
              read(30,*)g(ind)
   20       continue
   30     continue
   40   continue
   50 continue
      return
      end
      function icanon(i,j,k,l)
      implicit real (a-h,o-z), integer(i-n)
c
c     This function finds the canonical two-electron integral
c     index from a generic set of I, J, K and L (12|12)
c     indices.
c
      i1=min0(i,k)
      i2=k
      if(i2.eq.i1)i2=i
      i3=min0(j,l)
      i4=l
      if(i4.eq.i3)i4=j
      if((i4.gt.i2).or.(i2.eq.i4.and.i3.gt.i1))then
        it1=i3
        it2=i4
        i4=i2
        i3=i1
        i2=it2
        i1=it1
      endif
      i12=i2*(i2-1)/2+i1
      i34=i4*(i4-1)/2+i3
      icanon=i12*(i12-1)/2+i34
      return
      end
      subroutine dzero(x,lx)
      implicit  real*8(a-h,o-z), integer(i-n)
      dimension x(lx)
      do 10 l = 1, lx
        x(l) = 0.0d0
   10 continue
      return
      end
      subroutine ezero(a,n)
      implicit real(a-h,o-z), integer(i-n)
      dimension a(n)
      do 10 i = 1,n
        a(i) = 0.0e0
   10 continue
      return
      end
      subroutine izero(ix,lx)
      implicit integer(i-n)
      dimension ix(lx)
      do 10 l = 1, lx
        ix(l) = 0
   10 continue
      return
      end
      subroutine modinfo(module)
      implicit real(a-h,o-z), integer(i-n)
      character*12 module
      if(module(1:8).eq.'integral')then
        write(*,*)' '
        write(*,*)' **************** Program INTEGRAL **************** '
        write(*,*)' This program is designed to calculate one- and '
        write(*,*)' two-electron AO integrals and to write them out to '
        write(*,*)' disk in canonical order (in Dirac <12|12> '
        write(*,*)' convention). It is designed to handle only S and P '
        write(*,*)' orbitals. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:7).eq.'mocoefs')then
        write(*,*)' '
        write(*,*)' **************** Program MOCOEFS ***************** '
        write(*,*)' This program is designed to read in (from the '
        write(*,*)' keyboard) the LCAO-MO coefficient matrix and write '
        write(*,*)' it out to disk.  Alternatively, you can choose to '
        write(*,*)' have a unit matrix (as your initial guess) put out '
        write(*,*)' to disk. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:8).eq.'fnct_mat')then
        write(*,*)' '
        write(*,*)' **************** Program FNCT_MAT *************** '
        write(*,*)' This program is designed to read in a real square '
        write(*,*)' matrix, perform a function on it, and return this '
        write(*,*)' new array.  Possible functions, using X as the '
        write(*,*)' input matrix, are:  '
        write(*,*)'  '
        write(*,*)' (1) X^(-1/2), NOTE: X must be real symmetric,  '
        write(*,*)'                     and positive definite.  '
        write(*,*)'  '
        write(*,*)' (2) X^(+1/2), NOTE: X must be real symmetric,  '
        write(*,*)'                     and positive definite.  '
        write(*,*)'  '
        write(*,*)' (3) X^(-1), NOTE: X must be real symmetric,  '
        write(*,*)'                   and have non-zero eigenvalues. '
        write(*,*)'  '
        write(*,*)' (4) a power series expansion of a matrix  '
        write(*,*)'     to find the transformation matrix:  '
        write(*,*)'     U = exp(X) = 1 + X + X**2/2! + X**3/3! +  '
        write(*,*)'                            ... + X**N/N! + ... '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:4).eq.'fock')then
        write(*,*)' '
        write(*,*)' ****************** Program FOCK ****************** '
        write(*,*)' This program is designed to read in the LCAO-MO '
        write(*,*)' coefficient matrix, the one- and two-electron AO '
        write(*,*)' integrals and to form a CLOSED SHELL Fock matrix '
        write(*,*)' (i.e., a Fock matrix for species with all doubly '
        write(*,*)' occupied orbitals). '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:6).eq.'utmatu')then
        write(*,*)' '
        write(*,*)' ***************** Program UTMATU ***************** '
        write(*,*)' This program is designed to read in a real matrix, '
        write(*,*)' A, a real transformation matrix, B, perform the '
        write(*,*)' transformation:  '
        write(*,*)'        X = B(transpose) * A * B, '
        write(*,*)' and output the result. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:4).eq.'diag')then
        write(*,*)' '
        write(*,*)' ****************** Program DIAG ****************** '
        write(*,*)' This program is designed to read in a real '
        write(*,*)' symmetric matrix (but as a square matrix on '
        write(*,*)' disk), diagonalize it, and return all '
        write(*,*)' eigenvalues and corresponding eigenvectors. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:7).eq.'matxmat')then
        write(*,*)' '
        write(*,*)' ***************** Program MATXMAT **************** '
        write(*,*)' This program is designed to read in two real '
        write(*,*)' matrices; A and B, and to multiply them together:  '
        write(*,*)'             AB = A * B,  '
        write(*,*)' and output the result.  '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:7).eq.'fenergy')then
        write(*,*)' '
        write(*,*)' **************** Program FENERGY ***************** '
        write(*,*)' This program is designed to read in the LCAO-MO '
        write(*,*)' coefficient matrix, the one- and two-electron AO '
        write(*,*)' integrals (in Dirac <12|12> convention), and the '
        write(*,*)' Fock orbital energies.  Upon transformation of the '
        write(*,*)' one- and two-electron integrals from the AO to the '
        write(*,*)' MO basis, the closed shell Hartree - Fock energy '
        write(*,*)' is calculated in two ways.  First, the energy is  '
        write(*,*)' calculated with the MO integrals, '
        write(*,*)'  '
        write(*,*)' Sum(k) 2*<k|h|k> + Sum(k,l) (2*<k,l|k,l> - '
        write(*,*)' <k,l|l,k>) + ZuZv/Ruv. '
        write(*,*)'  '
        write(*,*)' Secondly, the energy is calculated with the Fock '
        write(*,*)' orbital energies and one electron energies in the '
        write(*,*)' MO basis, '
        write(*,*)'  '
        write(*,*)' Sum(k) (eps(k) + <k|h|k>) + ZuZv/Ruv. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:5).eq.'trans')then
        write(*,*)' '
        write(*,*)' ****************** Program TRANS ***************** '
        write(*,*)' This program is designed to read in the LCAO-MO '
        write(*,*)' coefficient matrix, the one- and two-electron AO '
        write(*,*)' integrals (in Dirac <12|12> convention), and to '
        write(*,*)' transform the integrals from the AO to the MO '
        write(*,*)' basis, and write these MO integrals to a file. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:3).eq.'scf')then
        write(*,*)' '
        write(*,*)' ****************** Program SCF ******************* '
        write(*,*)' This program is designed to read in the LCAO-MO '
        write(*,*)' coefficient matrix (or generate one), the one- '
        write(*,*)' and two-electron AO integrals and form a CLOSED '
        write(*,*)' SHELL Fock matrix (i.e., a Fock matrix for species '
        write(*,*)' with all doubly occupied orbitals). It then solves '
        write(*,*)' the Fock equations; iterating until convergence to '
        write(*,*)' six significant figures in the energy expression. '
        write(*,*)' A modified damping algorithm is used to insure '
        write(*,*)' convergence. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:3).eq.'mp2')then
        write(*,*)' '
        write(*,*)' ****************** Program MP2 ******************* '
        write(*,*)' This program is designed to read in the '
        write(*,*)' transformed one- and two-electron integrals and  ' 
        write(*,*)' the Fock orbital energies after which it will '
        write(*,*)' compute the second order Moller Plesset '
        write(*,*)' perturbation theory energy (MP2). '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:8).eq.'hamilton')then
        write(*,*)' '
        write(*,*)' **************** Program HAMILTON **************** '
        write(*,*)' This program is designed to generate or read in a '
        write(*,*)' list of determinants.  You can generate '
        write(*,*)' determinants for a CAS (Complete Active Space) of '
        write(*,*)' orbitals or you can input your own list of '
        write(*,*)' determinants.  Next, if you wish, you may read in '
        write(*,*)' the the one- and two-electron MO integrals and '
        write(*,*)' form a Hamiltonian matrix  over the determinants. '
        write(*,*)' Finally, if you wish, you may diagonalize the '
        write(*,*)' Hamiltonian matrix constructed over the '
        write(*,*)' determinants generated. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:7).eq.'rw_ints')then
        write(*,*)' '
        write(*,*)' **************** Program RW_INTS ***************** '
        write(*,*)' This program is designed to read the one- and two- '
        write(*,*)' electron AO integrals (in Dirac <12|12> '
        write(*,*)' convention) from user input and put them out to '
        write(*,*)' disk in canonical order. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:5).eq.'qmlib')then
        write(*,*)' '
        write(*,*)' ****************** Program QMLIB ***************** '
        write(*,*)' This is a library of subroutines and functions '
        write(*,*)' which are used by the QMIC programs. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:6).eq.'limits')then
        write(*,*)' '
        write(*,*)' ************** "limits.h" include file *********** '
        write(*,*)' This is an include file containing ALL the '
        write(*,*)' parameters which detemine memory requirments '
        write(*,*)' for the QMIC programs. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:8).eq.'Makefile')then
        write(*,*)' '
        write(*,*)' ********************** Makefile ****************** '
        write(*,*)' There are a few versions of Makefiles available: '
        write(*,*)' a generic Makefile (Makefile.gnu) which works with '
        write(*,*)' Gnu make on a unix box, a Makefile (Makefile.486) ' 
        write(*,*)' which was used to make the programs on a 486 PC '
        write(*,*)' using other Gnu utilities like "f2c", "gcc", etc. '
        write(*,*)' and a Makefile (Makefile.mac) which was used on '
        write(*,*)' the Macintosh. '
        write(*,*)' ************************************************** '
        write(*,*)' '
      elseif(module(1:8).eq.'BasisLib')then
        write(*,*)' '
        write(*,*)' ******************* BasisLib ********************* '
        write(*,*)' This is a library file which contains gaussian '
        write(*,*)' atomic orbital basis sets for Hydrogen - Neon. '
        write(*,*)'  '
        write(*,*)' The basis sets available to choose from are: '
        write(*,*)'  '
        write(*,*)'   1.) STO3G by Hehre, Stewart, and Pople '
        write(*,*)'                JCP, 51, 2657 (1969) '
        write(*,*)'   2.) 3-21G by Brinkley, Pople, and Hehre '
        write(*,*)'                JACS, 102, 939 (1980) '
        write(*,*)'   3.) [3s2p] by Dunning and Hay in: '
        write(*,*)'                 Modern Theoretical Chemistry Vol 3.'
        write(*,*)'                 Henry F. Schaefer III, Editor '
        write(*,*)'                 1977, Plenum Press, NY '
        write(*,*)' ************************************************** '
        write(*,*)' '
       else
        write(*,*)' '
        write(*,*)' No descriptional information found about '
        write(*,*)' this module. '
        write(*,*)' '
      endif
      return
      end
      subroutine shwmem(module,itotal)
      implicit real(a-h,o-z), integer(i-n)
      character*12 module
      itotb = itotal*4
      if(itotb.gt.0)then
        write(*,1000)module,itotb
      else
        write(*,2000)module
      endif
 1000 format('  ',a12,' -- memory usage in bytes:  ',i8)
 2000 format('  ',a12,' -- no memory required. ')
      return
      end