      SUBROUTINE ITER  (H, W, WJ, WK, EE, FULSCF,RAND)
      implicit double precision (A-H,O-Z)
      include 'SIZES'
      include 'MOP6FILE'
      double precision MECI
      dimension H(*), W(*), WJ(*), WK(*)
      common /FOKMAT/ F(MPACK), FB(MPACK)
      common /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)
      common /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB)
      common /GRADNT/ DUMY(MAXPAR),GNORM
      common /LAST  / LAST
      common /MESAGE/ IFLEPO,IITER
      common /ATHEAT/ ATHEAT
      common /ENUCLR/ ENUCLR
      common /CITERM/ XI,XJ,XK
      common /PATH  / LATOM,LPARAM,REACT(200)
      common /NUMCAL/ NUMCAL
      common /SCFTYP/ EMIN, LIMSCF
      common /TIME  / TIME0
      logical FULSCF, RAND, LIMSCF
      double precision WJ, WK
C***********************************************************************
C
C     ITER GENERATES A SCF FIELD AND returnS THE ENERGY IN "ENERGY"
C
C THE MAIN ARRAYS USED IN ITER ARE:
C            P      ONLY EVER CONTAINS THE TOTAL DENSITY MATRIX
C            PA     ONLY EVER CONTAINS THE ALPHA DENSITY MATRIX
C            PB     ONLY EVER CONTAINS THE BETA DENSITY MATRIX
C            C      ONLY EVER CONTAINS THE EIGENVECTORS
C            H      ONLY EVER CONTAINS THE ONE-ELECTRON MATRIX
C            F      STARTS OFF CONTAINING THE ONE-ELECTRON MATRIX,
C                   AND IS USED TO HOLD THE FOCK MATRIX
C            W      ONLY EVER CONTAINS THE TWO-ELECTRON MATRIX
C
C THE MAIN INTEGERS CONSTANTS IN ITER ARE:
C
C            LINEAR SIZE OF PACKED TRIANGLE = NORBS*(NORBS+1)/2
C
C THE MAIN INTEGER VARIABLES ARE
C            NITER  NUMBER OF ITERATIONS EXECUTED
C
C  PRINCIPAL REFERENCES:
C
C   ON MNDO: "GROUND STATES OF MOLECULES. 38. THE MNDO METHOD.
C             APPROXIMATIONS AND PARAMETERS."
C             DEWAR, M.J.S., THIEL,W., J. AM. CHEM. SOC.,99,4899,(1977).
C   ON SHIFT: "THE DYNAMIC 'LEVEL SHIFT' METHOD FOR IMPROVING THE
C             CONVERGENCE OF THE SCF PROCEDURE", A. V. MITIN, J. COMP.
C             CHEM. 9, 107-110 (1988)
C   ON HALF-ELECTRON: "MINDO/3 COMPARISON OF THE GENERALIZED S.C.F.
C             COUPLING OPERATOR AND "HALF-ELECTRON" METHODS FOR
C             CALCULATING THE ENERGIES AND GEOMETRIES OF OPEN SHELL
C             SYSTEMS"
C             DEWAR, M.J.S., OLIVELLA, S., J. CHEM. SOC. FARA. II,
C             75,829,(1979).
C   ON PULAY'S CONVERGER: "CONVERGANCE ACCELERATION OF ITERATIVE
C             SEQUENCES. THE CASE OF SCF ITERATION", PULAY, P.,
C             CHEM. PHYS. LETT, 73, 393, (1980).
C   ON CNVG:  IT ENCORPORATES THE IMPROVED ITERATION SCHEME (IIS) BY
C             PIOTR BADZIAG & FRITZ SOLMS. ACCEPTED FOR PUBLISHING
C             IN COMPUTERS & CHEMISTRY
C   ON PSEUDODIAGONALISATION: "FAST SEMIEMPIRICAL CALCULATIONS",
C             STEWART. J.J.P., CSASZAR, P., PULAY, P., J. COMP. CHEM.,
C             3, 227, (1982)
C
C***********************************************************************
      dimension POLD(MPACK), POLD2(MPACK), POLD3(MAXORB+400)
      dimension PBOLD(MPACK), PBOLD2(MPACK), PBOLD3(MAXORB+400)
************************************************************************
*                                                                      *
*   PACK ALL THE ARRAYS USED BY PULAY INTO A common BLOCK SO THAT THEY *
*   CAN BE USED BY THE C.I. DERIVATIVE, IF NEEDED                      *
*                                                                      *
************************************************************************
      common /WORK3/POLD,POLD2,PBOLD,PBOLD2
      common /WORK1/ AR1,AR2,AR3,AR4,BR1,BR2,BR3,BR4
      dimension  AR1(2*NPULAY), AR2(2*NPULAY), AR3(2*NPULAY),
     1 AR4(2*NPULAY)
      dimension  BR1(2*NPULAY), BR2(2*NPULAY), BR3(2*NPULAY),
     1 BR4(8*NPULAY)
      dimension ESCF0(10)
      common /PRECI / SELCON
      common /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,
     2                NALPHA, NBETA, NCLOSE, NOPEN, NDUMY, FRACT
     3      /MOLORB/ DUMMY(MAXORB),PDIAG(MAXORB)
     4      /KEYWRD/ KEYWRD
     5      /NUMSCF/ NSCF
      character KEYWRD*241, ABPRT(3)*5, GETNAM*80
      logical PRTFOK,PRTEIG,PRTDEN, DEBUG, PRTENG, TIMES, CI
     1       ,UHF, NEWDG, SCF1, HALFE, FORCE, PRT1EL,PRTPL, OKNEWD
     2       ,EXCITD, MINPRT, FRST, BFRST, OKPULY, READY, PRTVEC
     3       ,CAMKIN, ALLCON, MAKEA, MAKEB, INCITR, CAPPS, TIMITR
      save ICALCN, DEBUG, PRTFOK, PRTEIG, PRTDEN, PRTENG, PRT1EL, ABPRT
      save LINEAR, MINPRT, NEWDG, SCFCRT, PRTPL, PRTVEC, PL
      save BSHIFT, PLTEST, ITRMAX, NA2EL, NA1EL, NB2EL,NB1EL
      save IFILL, CAMKIN, CI, OKPULY, UHF, SCF1, OKNEWD, EXCITD, TIMES
      save FORCE, ALLCON, TRANS, HALFE, W1, W2, RANDOM
      data ICALCN/0/, DEBUG/.FALSE./, PRTFOK/.FALSE./
      data PRTEIG/.FALSE./,PRTDEN,PRTENG/.FALSE.,.FALSE./
      data PRT1EL/.FALSE./
      data ABPRT/'     ','ALPHA',' BETA'/
C
C  INITIALIZE
C
      IFILL=0
      IHOMO=MAX(1,NCLOSE+NALPHA)
      IHOMOB=MAX(1,NCLOSE+NBETA)
      EOLD=1.D2
      READY=.FALSE.
      if (ICALCN.NE.NUMCAL) then
         call EPSETA(EPS,ETA)
C
C  ULTIMATE SCF CRITERION: HEAT OF FORMATION CONVERGED WITHIN A FACTOR
C  OF 10 OF THE LIMITING PRECISION OF THE COMPUTER
C
         EPS=23.061D0*EPS*10.D0
         IRRR=5
         SHIFT=0.D0
         ICALCN=NUMCAL
         SHFMAX=20.D0
         LINEAR=(NORBS*(NORBS+1))/2
C
C    DEBUG KEY-WORDS WORKED OUT
C
         DEBUG=( INDEX(KEYWRD,'DEBUG') .NE. 0 )
         MINPRT=(INDEX(KEYWRD,'SADDLE')+
     1      LATOM .EQ.0 .OR. DEBUG)
         PRTEIG=( INDEX(KEYWRD,'EIGS') .NE. 0 )
         PRTPL =( INDEX(KEYWRD,' PL ')  .NE.0 )
         PRT1EL=( INDEX(KEYWRD,'1ELE') .NE.0 .AND. DEBUG)
         PRTDEN=( INDEX(KEYWRD,'DENS').NE.0 .AND. DEBUG)
         PRTFOK=( INDEX(KEYWRD,'FOCK') .NE. 0  .AND. DEBUG)
         PRTVEC=( INDEX(KEYWRD,'VECT') .NE. 0  .AND. DEBUG)
         DEBUG=( INDEX(KEYWRD,'ITER') .NE. 0 )
C
C INITIALIZE SOME logicalS AND CONSTANTS
C
         NEWDG =.FALSE.
         PLCHEK=0.005D0
         PL    =1.D0
         BSHIFT=0.D0
         SHIFT =1.D0
*
* SCFCRT IS MACHINE-PRECISION DEPENDENT
*
         SCFCRT=1.D-4
         ITRMAX = 200
         NA2EL=NCLOSE
         NA1EL=NALPHA+NOPEN
         NB2EL=0
         NB1EL=NBETA+NOPEN
C
C  USE KEY-WORDS TO ASSIGN VARIOUS CONSTANTS
C
         if (INDEX(KEYWRD,'FILL').NE.0)
     1      IFILL=-READA(KEYWRD,INDEX(KEYWRD,'FILL'))
         if (INDEX(KEYWRD,'SHIFT').NE.0)
     1      BSHIFT=-READA(KEYWRD,INDEX(KEYWRD,'SHIFT'))
         if (BSHIFT.NE.0) TEN=BSHIFT
         if (INDEX(KEYWRD,'ITRY').NE.0)
     1      ITRMAX = READA(KEYWRD,INDEX(KEYWRD,'ITRY'))
         CAMKIN=(INDEX(KEYWRD,'KING')+INDEX(KEYWRD,'CAMP') .NE. 0)
         CI=(INDEX(KEYWRD,'MICROS')+INDEX(KEYWRD,'C.I.') .NE. 0)
         OKPULY=.FALSE.
         OKPULY=(INDEX(KEYWRD,'PULAY').NE.0)
         UHF=(INDEX(KEYWRD,'UHF') .NE. 0)
         SCF1=(INDEX(KEYWRD,'1SCF') .NE. 0)
         OKNEWD=ABS(BSHIFT) .LT. 0.001D0
         if (CAMKIN.AND.ABS(BSHIFT).GT.1.D-5) BSHIFT=4.44D0
         EXCITD=(INDEX(KEYWRD,'EXCI') .NE. 0)
         TIMES=(INDEX(KEYWRD,'TIMES') .NE. 0)
         TIMITR=(TIMES.AND.DEBUG)
         FORCE=(INDEX(KEYWRD,'FORCE') .NE. 0)
         ALLCON=(OKPULY.OR.CAMKIN)
C
C   do WE NEED A CAPPED ATOM CORRECTION?
C
         J=0
         do 10 I=1,NUMAT
   10    if (NAT(I).EQ.102) J=J+1
         CAPPS=(J.GT.0)
         IITER=1
         TRANS=0.1D0
         if (INDEX(KEYWRD,'RESTART')+INDEX(KEYWRD,'OLDENS')
     1      .NE. 0) then
            if (INDEX(KEYWRD,'OLDENS').NE.0)
     1        open(unit=MIOD,file=GETNAM('FOR010'),
     +             status='UNKNOWN',form='UNFORMATTED')
            rewind MIOD
            read(MIOD) (PA(I),I=1,LINEAR)
            if ( UHF) then
               read(MIOD) (PB(I),I=1,LINEAR)
               do 20 I=1,LINEAR
                  POLD(I)=PA(I)
                  PBOLD(I)=PB(I)
   20          P(I)=PA(I)+PB(I)
            else
               do 30 I=1,LINEAR
                  PB(I)=PA(I)
                  PBOLD(I)=PA(I)
                  POLD(I)=PA(I)
   30          P(I)=PA(I)*2.D0
            end if
         else
            NSCF=0
            do 40 I=1,LINEAR
               P(I)=0.D0
               PA(I)=0.D0
   40       PB(I)=0.D0
            W1=NA1EL/(NA1EL+1.D-6+NB1EL)
            W2=1.D0-W1
            if (W1.LT.1.D-6) W1=0.5D0
            if (W2.LT.1.D-6) W2=0.5D0
C
C  SLIGHTLY PERTURB THE DENSITY MATRIX IN CASE THE SYSTEM IS
C  TRAPPED IN A S**2 = 0 STATE.
C
            RANDOM=1.0D0
            if (UHF.AND.NA1EL.EQ.NB1EL) RANDOM=1.1D0
            do 50 I=1,NORBS
               J=(I*(I+1))/2
               P(J)=PDIAG(I)
               PA(J)=P(J)*W1*RANDOM
               RANDOM=1.D0/RANDOM
   50       PB(J)=P(J)*W2*RANDOM
            do 60 I=1,LINEAR
               PBOLD(I)=PB(I)
   60       POLD(I)=PA(I)
         end if
         HALFE=(NOPEN .NE. NCLOSE.AND.FRACT.NE.2.D0.AND.FRACT.NE.0.D0)
C
C   DETERMINE THE SELF-CONSISTENCY CRITERION
C
         if (INDEX(KEYWRD,'PREC') .NE. 0)
     1                                    SCFCRT=SCFCRT*0.01D0
         if ( INDEX(KEYWRD,'POLAR') + INDEX(KEYWRD,'NLLSQ') +
     1 INDEX(KEYWRD,'SIGMA') .NE. 0)      SCFCRT=SCFCRT*0.001D0
         if (FORCE)                      SCFCRT=SCFCRT*0.0001D0
         if (NOPEN-NCLOSE.GT.4)          SCFCRT=SCFCRT*0.1D0
         SCFCRT=MAX(SCFCRT,1.D-12)
         if (INDEX(KEYWRD,'POLAR').NE.0)  SCFCRT=1.D-11
C
C  THE USER CAN STATE THE SCF CRITERION, IF DESIRED.
C
         I=INDEX(KEYWRD,'SCFCRT')
         if (I.NE.0) then
            SCFCRT = READA(KEYWRD,I)
            write(MIOB,'(''  SCF CRITERION ='',G14.4)') SCFCRT
            if (SCFCRT.LT.1.D-12)
     1 write(MIOB,'(//2X,'' THERE IS A RISK OF INFINITE LOOPING WITH'',
     2                   '' THE SCFCRT LESS THAN 1.D-12'')')
         else
            if (DEBUG)
     1          write(MIOB,'(''  SCF CRITERION ='',G14.4)') SCFCRT
         end if
         if (.NOT.SCF1) LAST=0
C
C   end OF INITIALIZATION SECTION.
C
      else if (FORCE.AND.NSCF.GT.0.AND..NOT.UHF) then
C
C   RESET THE DENSITY MATRIX IF MECI HAS FORMED AN EXCITED STATE.  THIS
C   PREVENTS THE SCF GETTING TRAPPED ON AN EXCITED STATE, PARTICULARLY
C   IF THE PULAY CONVERGER IS USED.
C
         do 70 I=1,LINEAR
   70    P(I)=2.D0*PA(I)
      end if
C
C   INITIALIZATION OPERATIONS DONE EVERY TIME ITER IS CALLED
C
      MAKEA=.TRUE.
      MAKEB=.TRUE.
      IEMIN=0
      IEMAX=0
C
C  TURN OFF SHifT IF NOT A FULL SCF.
C
      if (.NOT.FULSCF) SHIFT=0.D0
      if (NEWDG) NEWDG=(ABS(BSHIFT).LT.0.001D0)
      if (LAST.EQ.1) NEWDG=.FALSE.
C
C   SELF-CONSISTENCY CRITERIA: SELCON IS IN KCAL/MOL, PLTEST IS
C   A LESS IMPORTANT TEST TO MAKE SURE THAT THE SELCON TEST IS NOT
C   PASSED 'BY ACCIDENT'
C                              if GNORM IS LARGE, MAKE SELCON BIGGER
C
      SELCON=SCFCRT
      if (.NOT. FORCE .AND. .NOT. HALFE) then
         if (GNORM.GT.5.D0)   SELCON=SCFCRT*GNORM*0.2D0
         if (GNORM.GT.200.D0) SELCON=SCFCRT*40.D0
      end if
      PLTEST=0.05D0*SQRT(SELCON)
C
C  SOMETIMES HEAT GOES SCF BUT DENSITY IS STILL FLUCTUATING IN UHF
C  IN WHICH CASE PAY LESS ATTENTION TO DENSITY MATRIX
C
      if (NALPHA.NE.NBETA.AND.UHF) PLTEST=0.001D0
      if (DEBUG) then
         write(MIOB,'(''  SELCON, PLTEST'',3G16.7)') SELCON, PLTEST
      end if
      TITER1=SECOND()
      if (PRT1EL) then
         write(MIOB,
     %       '(//10X,''ONE-ELECTRON MATRIX AT ENTRANCE TO ITER'')')
         call VECPRT(H,NORBS)
      end if
      IREDY=1
   80 NITER=0
      TIME1=SECOND()
      FRST=.TRUE.
      if (CAMKIN) then
         MODEA=1
         MODEB=1
      else
         MODEA=0
         MODEB=0
      end if
      BFRST=.TRUE.
**********************************************************************
*                                                                    *
*                                                                    *
*                START THE SCF LOOP HERE                             *
*                                                                    *
*                                                                    *
**********************************************************************
      INCITR=.TRUE.
   90 INCITR=(MODEA.NE.3.AND.MODEB.NE.3)
      if (INCITR) NITER=NITER+1
      if (TIMITR) then
         TITER=SECOND()
         write(MIOB,*)
         write(MIOB,'(A,F7.2)')
     %     '     TIME FOR ITERATION:', TITER-TITER0
         TITER0=TITER
      end if
      if (NITER.GT.ITRMAX-10.AND..NOT.ALLCON) then
************************************************************************
*                                                                      *
*                   SWITCH ON ALL CONVERGERS                           *
*                                                                      *
************************************************************************
         write(MIOB,'(//,'' ALL CONVERGERS ARE NOW FORCED ON''/
     %          '' SHifT=10, PULAY ON, CAMP-KING ON''/
     %          '' AND ITERATION COUNTER RESET''//)')
         ALLCON=.TRUE.
         BSHIFT=4.44D0
         IREDY=-4
         EOLD=100.D0
         OKPULY=.TRUE.
         NEWDG=.FALSE.
         CAMKIN=(.NOT.HALFE)
         go to 80
      end if
************************************************************************
*                                                                      *
*                        MAKE THE ALPHA FOCK MATRIX                    *
*                                                                      *
************************************************************************
      if (ABS(SHIFT).GT.1.D-10.AND.BSHIFT .NE. 0.D0) then
         L=0
         if (NITER.GT.1) then
            if (NEWDG.AND..NOT.(HALFE.OR.CAMKIN)) then
C
C  SHIFT WILL APPLY TO THE VIRTUAL ENERGY LEVELS USED IN THE
C  PSEUDODIAGONALIIZATION. IF DIFF IS -VE, GOOD, THEN LOWER THE
C  HOMO-LUMO GAP BY 0.1EV, OTHERWISE INCREASE IT.
               if (DIFF.GT.0) then
                  SHIFT=1.D0
C
C IF THE PSEUDODIAGONALIZATION APPROXIMATION -- THAT THE WAVEFUNCTION
C IS ALMOST STABLE -- IS INVALID, TURN OFF NEWDG
                  if (DIFF.GT.1) NEWDG=.FALSE.
               else
                  SHIFT=-0.1D0
               end if
            else
               SHIFT=TEN+EIGS(IHOMO+1)-EIGS(IHOMO)+SHIFT
            end if
            if (DIFF.GT.0.D0) then
               if (SHIFT.GT.4.D0)   SHFMAX=4.5D0
               if (SHIFT.GT.SHFMAX) SHFMAX=MAX(SHFMAX-0.5D0,0.D0)
            end if
C
C   IF SYSTEM GOES UNSTABLE, LIMIT SHIFT TO THE RANGE -INFINITY - SHFMAX
C   BUT IF SYSTEM IS STABLE, LIMIT SHIFT TO THE RANGE -INFINITY - +20
C
            SHIFT=MAX(-20.D0,MIN(SHFMAX,SHIFT))
            if (ABS(SHIFT-SHFMAX).LT.1.D-5) SHFMAX=SHFMAX+0.01D0
C
C  THE CAMP-KING AND PULAY CONVERGES NEED A CONSTANT SHIFT.
C  IF THE SHIFT IS ALLOWED TO VARY, THESE CONVERGERS WILL NOT
C  WORK PROPERLY.
C
            if (OKPULY.OR.ABS(BSHIFT-4.44D0).LT.1.D-5) then
               SHIFT=-8.D0
               if (NEWDG) SHIFT=0
            end if
            if (UHF) then
               if (NEWDG.AND..NOT.(HALFE.OR.CAMKIN)) then
                  SHIFTB=TEN-TENOLD
               else
                  SHIFTB=TEN+EIGS(IHOMOB+1)-EIGS(IHOMOB)+SHIFTB
               end if
               if (DIFF.GT.0.D0) SHIFTB=MIN(4.D0,SHIFTB)
               SHIFTB=MAX(-20.D0,MIN(SHFMAX,SHIFTB))
               if (OKPULY.OR.ABS(BSHIFT-4.44D0).LT.1.D-5) then
                  SHIFTB=-8.D0
                  if (NEWDG) SHIFT=0
               end if
               do 100 I=IHOMOB+1,NORBS
  100          EIGB(I)=EIGB(I)+SHIFTB
            else
            end if
         end if
         TENOLD=TEN
         if (PL.GT.PLCHEK) then
            SHFTBO = SHIFTB
            SHFTO  = SHIFT
         else
            SHIFTB=SHFTBO
            SHIFT=SHFTO
         end if
         do 110 I=IHOMO+1,NORBS
  110    EIGS(I)=EIGS(I)+SHIFT
         do 130 I=1,NORBS
            do 120 J=1,I
               L=L+1
  120       F(L)=H(L)+SHIFT*PA(L)
  130    F(L)=F(L)-SHIFT
      else if (I.EQ.77.AND.LAST.EQ.0.AND.NITER.LT.2.AND.FULSCF) then
C
C  SLIGHTLY PERTURB THE FOCK MATRIX IN CASE THE SYSTEM IS
C  TRAPPED IN A METASTABLE EXCITED ELECTRONIC STATE
C
         RANDOM=0.001D0
         do 140 I=1,LINEAR
            RANDOM=-RANDOM
  140    F(I)=H(I)+RANDOM
      else
         do 150 I=1,LINEAR
  150    F(I)=H(I)
      end if
  160 continue
      if (TIMITR) then
         T0=SECOND()
         write(MIOB,'(A,F7.2)')  ' LOAD FOCK MAT. INTEGRAL',T0-TITER0
      end if
C#      call TIMER('BEFORE FOCK2')
      call FOCK2(F,P,PA,W, WJ, WK,NUMAT,NFIRST,NMIDLE,NLAST)
C#      call TIMER('AFTER FOCK2')
C#      call TIMER('BEFORE FOCK1')
      call FOCK1(F,P,PA,PB)
C#      call TIMER('AFTER FOCK1')
      if (TIMITR) then
         T0=SECOND()
         TF1=TF1+T0-T1
         write(MIOB,'(2(A,F7.2))')
     %     '  FOCK1:',T0-T1,'INTEGRAL:',T0-TITER0
      end if
************************************************************************
*                                                                      *
*                        MAKE THE BETA FOCK MATRIX                     *
*                                                                      *
************************************************************************
      if (UHF) then
         if (SHIFTB .NE. 0.D0) then
            L=0
            do 180 I=1,NORBS
               do 170 J=1,I
                  L=L+1
  170          FB(L)=H(L)+SHIFTB*PB(L)
  180       FB(L)=FB(L)-SHIFTB
         else if (RAND.AND.LAST.EQ.0.AND.NITER.LT.2.AND.FULSCF) then
            RANDOM=0.001
            do 190 I=1,LINEAR
               RANDOM=-RANDOM
  190       FB(I)=H(I)+RANDOM
         else
            do 200 I=1,LINEAR
  200       FB(I)=H(I)
         end if
         call FOCK2(FB,P,PB,W, WJ, WK,NUMAT,NFIRST,NMIDLE,NLAST)
         call FOCK1(FB,P,PB,PA)
      end if
      if ( .NOT. FULSCF) go to 380
      if (PRTFOK) then
         write(MIOB,210) NITER
  210    format('   FOCK MATRIX ON ITERATION',I3)
         call VECPRT (F,NORBS)
      end if
C
C   CODE THE FOLLOWING LINE IN PROPERLY SOMETIME
C   THIS OPERATION IS BELIEVED TO GIVE RISE TO A BETTER FOCK MATRIX
C   THAN THE CONVENTIONAL GUESS.
C
      if (IRRR.EQ.0) then
         do 220 I=1,NORBS
  220    F((I*(I+1))/2)=F((I*(I+1))/2)*0.5D0
         IRRR=2
      end if
************************************************************************
*                                                                      *
*                        CALCULATE THE ENERGY IN KCAL/MOLE             *
*                                                                      *
************************************************************************
      if (NITER .GE. ITRMAX) then
         if (DIFF.LT.1.D-3.AND.PL.LT.1.D-4.AND..NOT.FORCE) then
            write(MIOB,
     %       '('' """""""""""""""UNABLE TO ACHIEVE SELF-CONSISTEN'',
     %         ''CE, JOB CONTINUING'')')
            go to 380
         end if
         if (MINPRT) write(MIOB,230)
  230    format(//10X,'"""""""""""""UNABLE TO ACHIEVE SELF-CONSISTENCE'
     1,/)
         write(MIOB,240) DIFF,PL
  240    format(//,10X,'DELTAE= ',E12.4,5X,'DELTAP= ',E12.4,///)
         IFLEPO=9
         IITER=2
         call WRITMO(TIME0,ESCF)
         call filclo ! J/M
         stop ' in ITER - unable to get self-consistence'
      end if
      EE=HELECT(NORBS,PA,H,F)
      if (UHF) then
         EE=EE+HELECT(NORBS,PB,H,FB)
      else
         EE=EE*2.D0
      end if
      if (CAPPS) EE=EE+CAPCOR(NAT,NFIRST,NLAST,NUMAT,P,H)
      if (BSHIFT.NE.0.D0)
     1 SCORR=SHIFT*(NOPEN-NCLOSE)*23.061D0*0.25D0*(FRACT*(2.D0-FRACT))
      ESCF=(EE+ENUCLR)*23.061D0+ATHEAT+SCORR
      if (INCITR) then
         DIFF=ESCF-EOLD
         if (DIFF.GT.0) then
            TEN=TEN-1.D0
         else
            TEN=TEN*0.975D0+0.05D0
         end if
C
C MAKE SURE SELF-CONSISTENCY TEST IS NOT MORE STRINGENT THAN THE
C COMPUTER CAN HANDLE
C
         SELLIM=MAX(SELCON,EPS*MAX(ABS(EE),1.D0))
C
C SCF TEST:  CHANGE IN HEAT OF FORMATION IN KCAL/MOL SHOULD BE
C            LESS THAN SELLIM.  THE OTHER TESTS ARE SAFETY MEASURES
C
         if (.NOT.(NITER.GT.4.AND.(PL.EQ.0.D0.OR.PL.LT.PLTEST.AND.
     1   ABS(DIFF).LT.SELLIM) .AND. READY)) go to 270
************************************************************************
*                                                                      *
*          SELF-CONSISTENCY TEST, EXIT MODE FROM ITERATIONS            *
*                                                                      *
************************************************************************
  250    if (ABS(SHIFT) .LT. 1.D-10) go to 380
         SHIFT=0.D0
         SHIFTB=0.D0
         do 260 I=1,LINEAR
  260    F(I)=H(I)
         MAKEA=.TRUE.
         MAKEB=.TRUE.
         go to 160
  270    continue
***********************************************************************
***********************************************************************
         if (LIMSCF.AND.EMIN.NE.0.D0.AND..NOT.(CI.OR.HALFE)) then
C
C  THE FOLLOWING TESTS ARE INTendED TO ALLOW A FAST EXIT FROM ITER
C  if THE RESULT IS 'GOOD ENOUGH' FOR THE CURRENT STEP IN THE GEOMETRY
C  OPTIMIZATION
C
            if (ESCF.LT.EMIN) then
C
C  THE ENERGY IS LOWER THAN THE PREVIOUS MINIMUM.  NOW CHECK THAT
C  IT IS CONSISTENTLY LOWER.
C
               IEMAX=0
               IEMIN=MIN(5,IEMIN+1)
               do 280 I=2,IEMIN
  280          ESCF0(I-1)=ESCF0(I)
               ESCF0(IEMIN)=ESCF
C
C  IS THE DIFFERENCE IN ENERGY BETWEEN TWO ITERATIONS LESS THAN 5%
C  OF THE ENERGY GAIN FOR THIS GEOMETRY RELATIVE TO THE PREVIOUS
C  MINIMUM.
C
               if (IEMIN.GT.3) then
                  do 290 I=2,IEMIN
                     if (ABS(ESCF0(I)-ESCF0(I-1)) .GT.
     1                             0.05D0*(EMIN-ESCF)) go to 320
  290             continue
C
C IS GOOD ENOUGH -- RAPID EXIT
C
                  if (DEBUG) write(MIOB,*)
     1' RAPID EXIT BECAUSE ENERGY IS CONSISTENTLY LOWER'
                  go to 250
               end if
            else
C
C  THE ENERGY HAS RISEN ABOVE THAT OF THE PREVIOUS MINIMUM.
C  WE NEED TO CHECK WHETHER THIS IS A FLUKE OR IS THIS REALLY
C  A BAD GEOMETRY.
C
               IEMIN=0
               IEMAX=MIN(5,IEMAX+1)
               do 300 I=2,IEMAX
  300          ESCF0(I-1)=ESCF0(I)
               ESCF0(IEMAX)=ESCF
C
C  IS THE DIFFERENCE IN ENERGY BETWEEN TWO ITERATIONS LESS THAN 5%
C  OF THE ENERGY LOST FOR THIS GEOMETRY RELATIVE TO THE PREVIOUS
C  MINIMUM.
C
               if (IEMAX.GT.3) then
                  do 310 I=2,IEMAX
                     if (ABS(ESCF0(I)-ESCF0(I-1)).GT.
     1                            0.05D0*(ESCF-EMIN)) go to 320
  310             continue
C
C IS GOOD ENOUGH -- RAPID EXIT
C
                  if (DEBUG) write(MIOB,*)
     1              ' RAPID EXIT BECAUSE ENERGY IS CONSISTENTLY HIGHER'
                  go to 250
               end if
            end if
         end if
  320    READY=(IREDY.GT.0.AND.(ABS(DIFF).LT.SELLIM*10.D0.OR.PL.EQ.0.D0)
     1)
         IREDY=IREDY+1
      end if
      if (PRTPL.OR.DEBUG.AND.NITER.GT.ITRMAX-20) then
         if (ABS(ESCF).GT.99999.D0) ESCF=SIGN(9999.D0,ESCF)
         if (ABS(DIFF).GT.9999.D0) DIFF=0.D0
         if (INCITR)
     1    write(MIOB,'('' ITERATION'',I3,'' PLS='',2E10.3,'' ENERGY  '',
     2      F14.7,'' DELTAE'',F13.7)') NITER,PL,PLB,ESCF,DIFF
      end if
      if (INCITR) EOLD=ESCF
************************************************************************
*                                                                      *
*                        INVOKE THE CAMP-KING CONVERGER                *
*                                                                      *
************************************************************************
      if (NITER.GT.2 .AND. CAMKIN .AND. MAKEA)
     1call INTERP(NORBS,NA1EL,NORBS-NA1EL, MODEA, ESCF/23.061D0,
     2F, C, AR1, AR2, AR3, AR4, AR1)
      MAKEB=.FALSE.
      if (MODEA.EQ.3) go to 340
      MAKEB=.TRUE.
      if (TIMITR) then
         T0=SECOND()
         write(MIOB,'(2(A,F7.2))') ' ADJUST DAMPER  INTEGRAL',T0-TITER0
      end if
      if ( NEWDG ) then
************************************************************************
*                                                                      *
*                        INVOKE PULAY'S CONVERGER                      *
*                                                                      *
************************************************************************
         if (OKPULY.AND.MAKEA.AND.IREDY.GT.1)
     1call PULAY(F,PA,NORBS,POLD,POLD2,POLD3,JALP,IALP,MPACK,FRST,PL)
************************************************************************
*                                                                      *
*           DIAGONALIZE THE ALPHA OR RHF SECULAR DETERMINANT           *
* WHERE POSSIBLE, USE THE PULAY-STEWART METHOD, OTHERWISE USE BEPPU'S  *
*                                                                      *
************************************************************************
         if (HALFE.OR.CAMKIN) then
            call HQRII(F,NORBS,NORBS,EIGS,C)
         else
C#      call TIMER('BEFORE DIAG')
            call DIAG (F,C,NA1EL,EIGS,NORBS,NORBS)
C#      call TIMER('AFTER DIAG')
         end if
      else
C#      call TIMER('BEFORE HQRII')
         call HQRII(F,NORBS,NORBS,EIGS,C)
C#      call TIMER('AFTER HQRII')
         if (TIMITR) then
            T1=SECOND()
            write(MIOB,'(2(A,F7.2))')
     %         '  HQRII:',T1-T0,' INTEGRAL',T1-TITER0
         end if
      end if
      J=1
      if (PRTVEC) then
         J=1
         if (UHF) J=2
         write(MIOB,'(//10X,A,
     %'' EIGENVECTORS AND EIGENVALUES ON ITERATION'',I3)')
     %   ABPRT(J),NITER
         call MATOUT(C,EIGS,NORBS,NORBS,NORBS)
      else
         if (PRTEIG) write(MIOB,330) ABPRT(J),NITER,(EIGS(I),I=1,NORBS)
      end if
  330 format(10X,A,'  EIGENVALUES ON ITERATION',I3,/10(6G13.6,/))
  340 if (IFILL.NE.0) call SWAP(C,NORBS,NORBS,NA2EL,IFILL)
************************************************************************
*                                                                      *
*            CALCULATE THE ALPHA OR RHF DENSITY MATRIX                 *
*                                                                      *
************************************************************************
      if (UHF) then
         call DENSIT( C,NORBS, NORBS, NA2EL,NA1EL, FRACT, PA, 1)
         if (MODEA.NE.3.AND..NOT. (NEWDG.AND.OKPULY))
     1    call CNVG(PA, POLD, POLD2, NORBS, NITER, PL)
      else
C#      call TIMER('BEFORE DENSIT')
         call DENSIT( C,NORBS, NORBS, NA2EL,NA1EL, FRACT, P, 1)
C#      call TIMER('AFTER DENSIT')
         if (MODEA.NE.3.AND..NOT. (NEWDG.AND.OKPULY)) then
C#      call TIMER('BEFORE CNVG')
            call CNVG(P, POLD, POLD2, NORBS, NITER, PL)
C#      call TIMER('AFTER CNVG')
         end if
      end if
************************************************************************
*                                                                      *
*                       UHF-SPECIFIC CODE                              *
*                                                                      *
************************************************************************
      if ( UHF ) then
************************************************************************
*                                                                      *
*                        INVOKE THE CAMP-KING CONVERGER                *
*                                                                      *
************************************************************************
         if (NITER.GT.2 .AND. CAMKIN .AND. MAKEB )
     1     call INTERP(NORBS,NB1EL,NORBS-NB1EL, MODEB, ESCF/23.061D0,
     2                    FB, CBETA, BR1, BR2, BR3, BR4, BR1)
         MAKEA=.FALSE.
         if (MODEB.EQ.3) go to 350
         MAKEA=.TRUE.
         if ( NEWDG ) then
************************************************************************
*                                                                      *
*                        INVOKE PULAY'S CONVERGER                      *
*                                                                      *
************************************************************************
            if ( OKPULY.AND.MAKEB.AND.IREDY.GT.1)
     1         call PULAY(FB,PB,NORBS,PBOLD,PBOLD2,
     2                    PBOLD3,JBET,IBET,MPACK,BFRST,PLB)
************************************************************************
*                                                                      *
*           DIAGONALIZE THE ALPHA OR RHF SECULAR DETERMINANT           *
* WHERE POSSIBLE, USE THE PULAY-STEWART METHOD, OTHERWISE USE BEPPU'S  *
*                                                                      *
************************************************************************
            if (HALFE.OR.CAMKIN) then
               call HQRII(FB,NORBS,NORBS,EIGB,CBETA)
            else
               call DIAG (FB,CBETA,NB1EL,EIGB,NORBS,NORBS)
            end if
         else
            call HQRII(FB,NORBS,NORBS,EIGB,CBETA)
         end if
         if (PRTVEC) then
            write(MIOB,'(//10X,A,'' EIGENVECTORS AND EIGENVALUES ON '',
     %        ''ITERATION'',I3)') ABPRT(3),NITER
            call MATOUT(CBETA,EIGB,NORBS,NORBS,NORBS)
         else
            if (PRTEIG) write(MIOB,330)
     1                    ABPRT(3),NITER,(EIGB(I),I=1,NORBS)
         end if
************************************************************************
*                                                                      *
*                CALCULATE THE BETA DENSITY MATRIX                     *
*                                                                      *
************************************************************************
  350    call DENSIT( CBETA,NORBS, NORBS, NB2EL, NB1EL, FRACT, PB, 1)
         if ( .NOT. (NEWDG.AND.OKPULY))
     1          call CNVG(PB, PBOLD, PBOLD2, NORBS, NITER, PLB)
      end if
************************************************************************
*                                                                      *
*                   CALCULATE THE TOTAL DENSITY MATRIX                 *
*                                                                      *
************************************************************************
      if (UHF) then
         do 360 I=1,LINEAR
  360    P(I)=PA(I)+PB(I)
      else
         do 370 I=1,LINEAR
            PA(I)=P(I)*0.5D0
  370    PB(I)=PA(I)
      end if
      if (PRTDEN) then
         write(MIOB,'('' DENSITY MATRIX ON ITERATION'',I4)') NITER
         call VECPRT (P,NORBS)
      end if
      OKNEWD=(PL.LT.SELLIM .OR. OKNEWD)
      NEWDG=(PL.LT.TRANS .AND. OKNEWD .OR. NEWDG)
      if (PL.LT.TRANS*0.3333D0) OKNEWD=.TRUE.
      go to 90
**********************************************************************
*                                                                    *
*                                                                    *
*                      end THE SCF LOOP HERE                         *
*                NOW CALCULATE THE ELECTRONIC ENERGY                 *
*                                                                    *
*                                                                    *
**********************************************************************
*          SELF-CONSISTENCE ACHEIVED.
*
  380 EE=HELECT(NORBS,PA,H,F)
      if (UHF) then
         EE=EE+HELECT(NORBS,PB,H,FB)
      else
         EE=EE*2.D0 +
     1SHIFT*(NOPEN-NCLOSE)*23.061D0*0.25D0*(FRACT*(2.D0-FRACT))
      end if
      if (CAPPS) EE=EE+CAPCOR(NAT,NFIRST,NLAST,NUMAT,P,H)
C
C   NORMALLY THE EIGENVALUES ARE INCORRECT BECAUSE THE
C   PSEUDODIAGONALIZATION HAS BEEN USED.  IF THIS
C   IS THE LAST SCF, then do AN EXACT DIAGONALIZATION
      if ( NSCF.EQ.0 .OR. LAST.EQ.1 .OR. CI .OR. HALFE ) then
C
C  PUT F AND FB INTO POLD IN ORDER TO NOT DESTROY F AND FB
C  AND do EXACT DIAGONALISATIONS
         do 390 I=1,LINEAR
  390    POLD(I)=F(I)
         call HQRII(POLD,NORBS,NORBS,EIGS,C)
         if (UHF) then
            do 400 I=1,LINEAR
  400       POLD(I)=FB(I)
            call HQRII(POLD,NORBS,NORBS,EIGB,CBETA)
            do 410 I=1,LINEAR
  410       POLD(I)=PA(I)
         else
            do 420 I=1,LINEAR
  420       POLD(I)=P(I)
         end if
         if (CI.OR.HALFE) then
C#        call TIMER('BEFORE MECI')
            SUM=MECI(EIGS,C)
C#        call TIMER('AFTER MECI')
            EE=EE+SUM
            if (PRTPL) then
               ESCF=(EE+ENUCLR)*23.061 +ATHEAT
               write(MIOB,'(27X,''AFTER MECI, ENERGY  '',F14.7)') ESCF
            end if
         end if
      end if
      NSCF=NSCF+1
      TITER2=SECOND()
      if (DEBUG) write(MIOB,'('' NO. OF ITERATIONS ='',I6)') NITER
C            if (FORCE)  SCFCRT=1.D-5
      if (ALLCON.AND.ABS(BSHIFT-4.44D0).LT.1.D-7) then
         CAMKIN=.FALSE.
         ALLCON=.FALSE.
         NEWDG=.FALSE.
         BSHIFT=-10.D0
         OKPULY=.FALSE.
      end if
      SHIFT=1.D0
      if (EMIN.EQ.0.D0) then
         EMIN=ESCF
      else
         EMIN=MIN(EMIN,ESCF)
      end if
      return
      end
