      SUBROUTINE SWAP(C,N,MDIM,NOCC,IFILL)
      implicit  double precision (A-H,O-Z)
      include 'SIZES'
      include 'MOP6FILE'
      dimension C(MDIM,MDIM)
C******************************************************************
C
C        SWAP ENSURES THAT A NAMED MOLECULAR ORBITAL IFILL IS FILLED
C ON INPUT
C          C = EIGENVECTORS IN A MDIM*MDIM MATRIX
C          N = NUMBER OF ORBITALS
C          NOCC = NUMBER OF OCCUPIED ORBITALS
C          IFILL = FILLED ORBITAL
C******************************************************************
      common /SWAP0/ PSI(MAXORB), STDPSI(MAXORB)
      if (IFILL.GT.0) go to 20
C
C     WE NOW DEFINE THE FILLED ORBITAL
C
      IFILL=-IFILL
      do 10 I=1,N
         STDPSI(I)=C(I,IFILL)
   10 PSI(I)=C(I,IFILL)
      return
   20 continue
C
C     FIRST FIND THE LOCATION OF IFILL
C
      SUM=0.D0
      do 30 I=1,N
   30 SUM=SUM+PSI(I)*C(I,IFILL)
      if (ABS(SUM).GT.0.7071D0) go to 90
C
C     IFILL HAS MOVED!
C
      SUMMAX=0.D0
      do 50 IFILL=1,N
         SUM=0.D0
         do 40 I=1,N
   40    SUM=SUM+STDPSI(I)*C(I,IFILL)
         SUM=ABS(SUM)
         if (SUM.GT.SUMMAX)   JFILL=IFILL
         if (SUM.GT.SUMMAX)   SUMMAX=SUM
         if (SUM.GT.0.7071D0) go to 90
   50 continue
      do 70 IFILL=1,N
         SUM=0.D0
         do 60 I=1,N
   60    SUM=SUM+PSI(I)*C(I,IFILL)
         SUM=ABS(SUM)
         if (SUM.GT.SUMMAX)   JFILL=IFILL
         if (SUM.GT.SUMMAX)   SUMMAX=SUM
         if (SUM.GT.0.7071D0) go to 90
   70 continue
      write(MIOB,80)  SUMMAX,JFILL
   80 format(/,' CAUTION !!! SUM IN SWAP VERY SMALL, SUMMAX =',F10.5,
     1' JFILL=',I3)
      IFILL=JFILL
   90 continue
      if (IFILL.LE.NOCC) return
C
C    ITS EMPTY, SO SWAP IT WITH THE HIGHEST FILLED
C
      do 100 I=1,N
         X=C(I,NOCC)
         C(I,NOCC)=C(I,IFILL)
         C(I,IFILL)=X
  100 continue
      return
      end
