      SUBROUTINE VECPRT (A,NUMM)
      implicit double precision (A-H,O-Z)
      include 'SIZES'
      include 'MOP6FILE'
      dimension  A(*)
      common /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      common /ELEMTS/ ELEMNT(107)
C**********************************************************************
C
C  VECPRT PRINTS A LOWER-HALF TRIANGLE OF A SQUARE MATRIX, THE
C         LOWER-HALF TRIANGLE BEING STORED IN PACKED FORM IN THE
C         ARRAY "A"
C
C ON INPUT:
C      A      = ARRAY TO BE PRINTED
C      NUMM   = SIZE OF ARRAY TO BE PRINTED
C(REF) NUMAT  = NUMBER OF ATOMS IN THE MOLECULE (THIS IS NEEDED TO
C               DECIDE IF AN ATOMIC ARRAY OR ATOMIC ORBITAL ARRAY IS
C               TO BE PRINTED
C(REF) NAT    = LIST OF ATOMIC NUMBERS
C(REF) NFIRST = LIST OF ORBITAL COUNTERS
C(REF) NLAST  = LIST OF ORBITAL COUNTERS
C
C  NONE OF THE ARGUMENTS ARE ALTERED BY THE call OF VECPRT
C
C*********************************************************************
      dimension NATOM(MAXORB)
      character * 6 LINE(21)
      character*2 ELEMNT,ATORBS(9), ITEXT(MAXORB), JTEXT(MAXORB)
      save ATORBS
      data ATORBS/' S','PX','PY','PZ','X2','XZ','Z2','YZ','XY'/
      if (NUMAT.NE.0.AND.NUMAT.EQ.NUMM) then
C
C    PRINT OVER ATOM COUNT
C
         do 10 I=1,NUMAT
            ITEXT(I)='  '
            JTEXT(I)=ELEMNT(NAT(I))
            NATOM(I)=I
   10    continue
      else
         if (NUMAT.NE.0.AND.NLAST(NUMAT) .EQ. NUMM) then
            do 30 I=1,NUMAT
               JLO=NFIRST(I)
               JHI=NLAST(I)
               L=NAT(I)
               K=0
               do 20 J=JLO,JHI
                  K=K+1
                  ITEXT(J)=ATORBS(K)
                  JTEXT(J)=ELEMNT(L)
                  NATOM(J)=I
   20          continue
   30       continue
         else
            NUMB=ABS(NUMM)
            do 40 I=1,NUMB
               ITEXT(I) = '  '
               JTEXT(I) = '  '
   40       NATOM(I)=I
         end if
      end if
      NUMB=ABS(NUMM)
      do 50 I=1,21
   50 LINE(I)='------'
      LIMIT=(NUMB*(NUMB+1))/2
      KK=8
      NA=1
   60 LL=0
      M=MIN0((NUMB+1-NA),6)
      MA=2*M+1
      M=NA+M-1
      write(MIOB,100) (ITEXT(I),JTEXT(I),NATOM(I),I=NA,M)
      write(MIOB,110) (LINE(K),K=1,MA)
      do 80 I=NA,NUMB
         LL=LL+1
         K=(I*(I-1))/2
         L=MIN0((K+M),(K+I))
         K=K+NA
         if ((KK+LL).LE.50) go to 70
         write(MIOB,120)
         write(MIOB,100) (ITEXT(N),JTEXT(N),NATOM(N),N=NA,M)
         write(MIOB,110) (LINE(N),N=1,MA)
         KK=4
         LL=0
   70    write(MIOB,130) ITEXT(I),JTEXT(I),NATOM(I),(A(N),N=K,L)
   80 continue
      if (L.GE.LIMIT) go to 90
      KK=KK+LL+4
      NA=M+1
      if ((KK+NUMB+1-NA).LE.50) go to 60
      KK=4
      write(MIOB,120)
      go to 60
   90 return
C
  100 format(1H0/13X,10(1X,A2,1X,A2,I3,2X))
  110 format(1H ,21A6)
  120 format(1H1)
  130 format(1H ,A2,1X,A2,I5,10F11.6)
C
      end
