C
C $Id: wrtvec.F,v 1.3 1998/07/16 16:40:57 jjv5 Exp $
C
C------------------------------------------------------------------------
      SUBROUTINE WRTVEC(NORBS,EVEC1,EVAL1)
C
C-RDC C     WRITES EIGENVECTORS (MOs) TO UNIT IOUT.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
#include "divcon.dim"
#include "divcon.h"
      DIMENSION EVEC1(NORBS,*),EVAL1(NORBS)
C
C
C     LOCAL:
C
      CHARACTER LABEL(4)*2
      DATA LABEL /' S','PX','PY','PZ'/
      SAVE LABEL
      character*1 occ
      dimension occ(6)
      logical found
C
C-RDC       WRITE(IOUT,'(///" FINAL EIGENVECTORS:")')
      iocc = nelec/2
c
c
c MO     ->   IIII       IIII       IIII       IIII       IIII       IIII
c ENERGY -> -FFFF.FFFF -FFFF.FFFF -FFFF.FFFF -FFFF.FFFF -FFFF.FFFF -FFFF.FFFF
C OCC.   ->     Y          Y          N          N          N          N
c
cIIII BR PX -FF.FFFFFF -FF.FFFFFF -FF.FFFFFF -FF.FFFFFF -FF.FFFFFF -FF.FFFFFF

C     since this is only called when doing a standard calculation,
C     nprsub is always 1
      k1 = iorbpt(1)-1
      k2 = iorbpt(2)-1
      j1 = 0
      found = .false.
      do k=k1+1,k2
         j1 = j1 + 1
         if (eval1(k).ge.eprsub(1)) then
            found = .true.
            kk=k
            goto 20
         endif
      enddo
 20   if (found) then
         maxj2 = j1
         do k=kk,k2
            if (eval1(k).gt.eprsub(2)) goto 30
            maxj2 = maxj2 + 1
         enddo
      else
C     .  did not find any eigenvector within the requested energies
C-RDC          write(iout,
C-RDC      $        '(/" NONE FOUND WITHIN THE REQUESTED ENERGY INTERVAL")')
         return
      endif
 30   maxj2=maxj2-1
      nnorbs = maxj2-j1+1
      if (nnorbs.eq.0) then
C-RDC          write(iout,
C-RDC      $        '(/" NONE FOUND WITHIN THE REQUESTED ENERGY INTERVAL")')
         return
      endif
      nblock = nnorbs/6 + min(1,mod(nnorbs,6))

      DO 500 IBLOCK=1,NBLOCK
        IAO = 0
        J2 = MIN(J1+5,maxj2)
        k = 0
        do i=j1,j2
           k = k + 1
           if (i.le.iocc) then
              occ(k) = 'Y'
           else
              occ(k) = 'N'
           endif
        enddo
C-RDC         WRITE(IOUT,'(//" MO         ->   ",I4,5(7X,I4))')
C-RDC      &       (J,J=J1,J2)
C-RDC         write(iout,'(" ENERGY     ->",6(1X,F10.4))')
C-RDC      .       (EVAL1(J),J=J1,J2)
C-RDC         write(iout,'(" OCC.       ->",6(6x,a1,4x))')
C-RDC      $       (occ(j-j1+1),j=j1,j2)
C-RDC         WRITE(IOUT,'("")')
        DO 200 IATM=1,NATOMS
          IAI = IATNUM(IATM)
          NORBSI = NATORB(IAI)
          DO 100 IORB=1,NORBSI
            IAO = IAO + 1
C-RDC             WRITE(IOUT,'(I4,1X,i4,1x,A2,1X,A2,6(1X,F10.7))')
C-RDC      .           IAO,iatm,SYMBOL(IAI),LABEL(IORB),(EVEC1(IAO,J),J=J1,J2)
 100      CONTINUE
 200    CONTINUE
C
        J1 = J1 + 6
 500  CONTINUE
      RETURN
      END