C 11 APR 08 - HPTI - TRANSPOSE LCAO MATRIX BEFORE CALLING DFT ROUTINES
C  4 MAR 08 - SS  - TOTAL KINETIC ENERGY DENSITY
C 20 AUG 07 - DGF - SYNCHRONISE FMOOPT AND FMORUN
C 24 MAR 07 - MWS - PAD FRGINF COMMON BLOCK
C 22 DEC 06 - DGF - SYNCHRONISE MP2PAR
C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION AND GDDI COMMON BLOCK
C  7 SEP 06 - MWS - RHFELG,UHFELG: UPDATE SVPE CALLS
C  8 MAY 06 - FLG - FULLY TESTED VERSION
C 29 MAR 06 - FLG - SCF ROUTINES FOR ELONGATION METHOD
C
C*MODULE ELGSCF  *DECK  BMCL_UHF
      SUBROUTINE BMCL_UHF(CBA,CBMA,NAAO,JWW,NHB,
     *                    NWA,NWM,NOCCB,NOCCM,NVACM)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION CBA(NAAO,JWW),CBMA(NWA,NWM)
C
      NVACB = JWW - NOCCB
C
        CALL VCLR(CBMA,1,NWA*NWM)
C
C   FOR OCC PART
C
      JJJ = 0
      DO J=1,NOCCB
         JJJ = JJJ + 1
         DO I=1,NAAO-NHB
            CBMA(I,JJJ) = CBA(I,J)
         ENDDO
      ENDDO
C
C  REMEMBER HERE: TERMINAL GROUP SHOULD BE REMOVED
C
      DO J=1,NOCCM
         JJJ = JJJ + 1
         II = 0
         DO I=NAAO-NHB+1,NWA
            II = II + 1
            IF(II.EQ.J) THEN
               CBMA(I,JJJ) = 1.0D+00
            ENDIF
         ENDDO
      ENDDO
C---------------------------------------------------------------
C
C   FOR VIRT PART
C
      DO J=1,NVACB
         JJJ = JJJ + 1
         DO I=1,NAAO-NHB
            CBMA(I,JJJ) = CBA(I,NOCCB+J)
         ENDDO
      ENDDO
C
      DO J=1,NVACM
         JJJ = JJJ + 1
         II = 0
         DO I=NOCCM+NAAO-NHB+1,NWA
            II = II + 1
            IF(II.EQ.J) THEN
               CBMA(I,JJJ) = 1.0D+00
            ENDIF
         ENDDO
      ENDDO
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ELGUHF
      SUBROUTINE ELGUHF(NAAO,NWA,NWM,JXX,NUM,LS,LFA,LVA,
     *                  LSW,LCBMA,LCXAL,MJBIG,MBIG,
     *                  MSLMO,MFLMO,MWRK1,MTMP,LAD,LSM,LFM,
     *                  MEIG,LSDG,MVEC,NOCAA,
     *                  NOCAB,NOCBMA,NOCBMB,ITER,MOPAC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON /FMCOM / X(1)
      LOGICAL LCUT
      COMMON /ELGIDX/ LCUT
C----------------------------------------------------------------------
C    1-0. GET CL(B+M) BY INITIAL GUESS MOS IN M-REGION
C----------------------------------------------------------------------
      IF(ITER.EQ.1) THEN
         IF(.NOT.LCUT) CALL NRM(X(LCXAL),X(LS),X(LSW),NUM,NAAO,JXX)
         CALL NRM(X(LCBMA),X(LS),X(LSW),NUM,NWA,NWM)
      END IF
C----------------------------------------------------------------------
C    2. TRANSFORM S(AO) AND F(AO)-MAT TO LMO BASIS
C----------------------------------------------------------------------
         IF(ITER.LE.1)
     *   CALL TFTRI(X(MSLMO),X(LS),X(LCBMA),X(MWRK1),NWM,NWA,NWA)
         CALL TFTRI(X(MFLMO),X(LFA),X(LCBMA),X(MWRK1),NWM,NWA,NWA)
C----------------------------------------------------------------------
         CALL ELGDIAG(NWM,X(MSLMO),X(MFLMO),X(LAD),X(MJBIG),X(MBIG),
     *                X(LSM),X(LFM),X(MEIG),X(LSDG),X(MVEC),ITER,MOPAC)
C----------------------------------------------------------------------
C    3. GO TO AO BASIS FROM LMO BASIS, OBTAIN WHOLE SYSTEM C
C----------------------------------------------------------------------
          CALL MOAORO(X(MVEC),X(LCBMA),X(LCXAL),X(MTMP),X(LVA),
     *        NUM,NAAO,JXX,NOCAA,NOCBMA,NOCAB,NOCBMB,ITER)
C----------------------------------------------------------------------
       RETURN
       END
C
C*MODULE ELGSCF  *DECK ELGDIAG
      SUBROUTINE ELGDIAG(NWM,SLMO,FLMO,AD,JBIG,BIG,X,FM,EM,
     *      SDIAG,CM,ITER,MOPAC)
C
C     DIAGONALIZATION OF MO BASIS F-MAT FOR ELONGATION METHOD
C        RE-WRITTEN BY F.L. GU, JUNE 2004
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      DATA UHF/8HUHF     /
      DIMENSION AD(NWM,NWM),SDIAG(NWM),FM(NWM,NWM),X(NWM,NWM)
      DIMENSION EM(NWM),CM(NWM,NWM),JBIG(NWM*8),BIG(NWM)
      DIMENSION SLMO(NWM*(NWM+1)/2),FLMO(NWM*(NWM+1)/2)
C
      IF(MOPAC.NE.0) GOTO 30
      CALL CPYTSQ(FLMO,FM,NWM,1)
C===============================================================
C    FOR AB INITIO CASE:
C===============================================================
C     1. DIAGONALIZE S-MAT
C
C       WRITE(6,*)'SLMO-MAT IN ELGDIAG, ITER=',ITER
C        CALL PRTRIL(SLMO,NWM)
C
      IF(ITER.LE.1.OR.SCFTYP.EQ.UHF) THEN
      CALL GLDIAG(NWM,NWM,NWM,SLMO,JBIG,SDIAG,AD,IERR,BIG)
C
C     2. CONSTRUCT X, X=V * S(-1/2) * V(DAGGER)
C
      DO I=1,NWM
        DO J=1,NWM
          X(I,J) = 0.0D+00
          DO K=1,NWM
            X(I,J) = X(I,J) + AD(I,K)*(1.0D+00/SQRT(SDIAG(K)))*AD(J,K)
          ENDDO
        ENDDO
      ENDDO
      ENDIF
C
C     3. TRANSFER F-MAT USING X, F'=XFX^+
C
      CALL DGEMM('T','N',NWM,NWM,NWM,1.0D+00,X ,NWM,
     *            FM,NWM,0.0D+00,AD,NWM)
      CALL DGEMM('N','N',NWM,NWM,NWM,1.0D+00,AD,NWM,
     *            X ,NWM,0.0D+00,FM,NWM)
C
C     4. DIAGONALIZE F'-MAT
C
      CALL LINEAR(FM,FLMO,NWM,NWM)
      CALL GLDIAG(NWM,NWM,NWM,FLMO,JBIG,EM,AD,IERR,BIG)
C
C     5. TRANSFER BACK, C=XC'
C
      CALL DGEMM('N','N',NWM,NWM,NWM,1.0D+00,X,NWM,
     *            AD,NWM,0.0D+00,CM,NWM)
C===============================================================
C    FOR SEMI-EMPIRICAL CASE:
C===============================================================
 30   IF(MOPAC.NE.0) CALL GLDIAG(NWM,NWM,NWM,FLMO,JBIG,EM,CM,IERR,BIG)
      RETURN
      END
C
C*MODULE ELGSCF  *DECK  NRM
      SUBROUTINE NRM(CA,ST,SW,NUM,NWA,NWM)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION ST(NUM*(NUM+1)/2),SW(NUM,NUM)
      DIMENSION CA(NWA,NWM)
C
      CALL CPYTSQ(ST,SW,NUM,1)
C
      DO I=1,NWM
         FCOR = 0.0D+00
         DO K=1,NWA
            DO L=1,NWA
               FCOR=FCOR + CA(K,I)*SW(K,L)*CA(L,I)
            ENDDO
         ENDDO
C
         DO K=1,NWA
            CA(K,I) = CA(K,I)/SQRT(FCOR)
         ENDDO
      ENDDO
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK HSTELG
      SUBROUTINE HSTELG(D,F,XX,IX,NINTMX,IA,NOPK)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
*I32  CHARACTER*8 INAOFL
C
      DIMENSION D(*),F(*),IA(*),XX(NINTMX),IX(*)
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /ORDOPT/ NORDER(7)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
C
      PARAMETER (HALF=0.5D+00)
C
C     INDICES IN AO INTEGRAL LABELS ARE IN STANDARD ORDER,
C               I.GE.J , K.GE.L , (IJ).GE.(KL)
C
      IF(LABSIZ.EQ.1) CALL ABRT
      IF(NORDER(7).EQ.1) CALL ABRT
C
      NRECRD = 1
*I32  NFILE = 1
*I32  INAOFL = 'AOINTS  '
C
C-------------------------------------------------------------------
C   NOW 2E- PART OF CURRENT FRAGMENT (WITHOUT CUT-OFF PART) IS BUILT
C-------------------------------------------------------------------
C
      CALL SEQREW(IS)
C
      NUMTRI = (NUM*NUM+NUM)/2
      CALL VCLR(F,1,NUMTRI)
      I = 0
      J = 0
      K = 0
      L = 0
      NXX = 0
C
      IF(DFTTYP(3) .NE. 1.0D+00) GO TO 400
      IF(NOPK .NE. 1) GO TO 300
C
C     ----- INTEGRALS ARE IN STANDARD -J- LIST (NOPK=.TRUE.) -----
C
  210 CONTINUE
C
      CALL PREAD(IS,XX,IX,NXX,NINTMX)
C
      IF(NXX .EQ. 0) GO TO 290
      NINT = IABS(NXX)
      IF(NINT .GT. NINTMX) CALL ABRT
C
      DO 260 M = 1,NINT
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL = IX( 2*NPACK - 1 )
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND(  LABEL, 65535 )
*I32        LABEL = IX( 2*NPACK     )
*I32        KPACK = ISHFT( LABEL, -16 )
*I32        LPACK = IAND(  LABEL, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK =       ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND(        LABEL,        255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         ENDIF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
         VAL = XX(M)
C--------------------------------------------------------------------JGK
         NIJ = IA(I)+J
         NKL = IA(K)+L
         NIK = IA(I)+K
         NIL = IA(I)+L
         IF(J .LT. K) GO TO 220
         NJK = IA(J)+K
         NJL = IA(J)+L
         GO TO 240
C
  220    NJK = IA(K)+J
         IF(J .LT. L) GO TO 230
         NJL = IA(J)+L
         GO TO 240
C
  230    NJL = IA(L)+J
C
  240    CONTINUE
         VAL4 = (VAL+VAL)+(VAL+VAL)
         F(NIJ) = F(NIJ)+VAL4*D(NKL)
         F(NKL) = F(NKL)+VAL4*D(NIJ)
         F(NIK) = F(NIK)-VAL*D(NJL)
         F(NIL) = F(NIL)-VAL*D(NJK)
         F(NJK) = F(NJK)-VAL*D(NIL)
         F(NJL) = F(NJL)-VAL*D(NIK)
  260 CONTINUE
C
C-------------------------------------------------------------------
      NRECRD = NRECRD + 1
*I32  IF(NRECRD.GT.888650) THEN
*I32    NRECRD = 1
*I32    NFILE = NFILE + 1
*I32    CALL SEQCLO(IS,'KEEP')
*I32    IF(NFILE.GT.9) THEN
*I32     WRITE(INAOFL(7:8),'(I2)') NFILE
*I32    ELSE
*I32     WRITE(INAOFL(7:8),'(I1,1H )') NFILE
*I32    ENDIF
*I32    CALL SEQOPN(IS,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32    CALL SEQREW(IS)
*I32  ENDIF
C-------------------------------------------------------------------
      IF(NXX.GT.0) GO TO 210
C-------------------------------------------------------------------
*I32  IF(NFILE.GT.1) THEN
*I32   CALL SEQCLO(IS,'KEEP')
*I32   CALL SEQOPN(IS,INAOFL(1:6),'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32   CALL SEQREW(IS)
*I32  ENDIF
C------------------------------------------------------------------
C
C------------------------------------------------------------------
C      NOW 2-ELECTRON INTERACTION PART [A(CUT-OFF) ---- B+M IS READ
C      BY CONSTRUCTION FIRST INDEX I CORRESPOND TO CUT-OFF FRAGMENT
C      OTHER INDICES: J,K,L BELONG TO B+M OR ONE OF THEM IS FROM A.
C------------------------------------------------------------------
C
      CALL SEQREW(NEG7)
      NRECRD = 1
*I32  NFILE = 1
*I32  INAOFL = 'EGINTA  '
C
 310  CONTINUE
      CALL PREAD(NEG7,XX,IX,NXX,NINTMX)
C
      IF(NXX .EQ. 0) GO TO 290
      NINT = IABS(NXX)
      IF(NINT .GT. NINTMX) CALL ABRT
C
       DO 360 M = 1,NINT
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL = IX( 2*NPACK - 1 )
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND(  LABEL, 65535 )
*I32        LABEL = IX( 2*NPACK     )
*I32        KPACK = ISHFT( LABEL, -16 )
*I32        LPACK = IAND(  LABEL, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK =       ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND(        LABEL,        255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         ENDIF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
         VAL = XX(M)
         VAL4 = (VAL+VAL)+(VAL+VAL)
C
         IF(J.GT.NUMOLD) THEN
C
C          -------- I,J > NUMOLD;  K,L < NUMOLD --------
C
           NKL = IA(K)+L
           NIJ = IA(I)+J
           F(NKL) = F(NKL) + VAL4*D(NIJ)
C
         ELSEIF(K.GT.NUMOLD) THEN
C
C          -------- I,K > NUMOLD;  J,L < NUMOLD --------
C
            NIK = IA(I)+K
            IF(J.GT.L) THEN
              NJL = IA(J) + L
            ELSE
              NJL = IA(L) + J
            ENDIF
            F(NJL) = F(NJL) - VAL*D(NIK)
         ELSE
C
C          -------- I > NUMOLD;  J,K,L < NUMOLD --------
C
            NIJ = IA(I)+J
            NIK = IA(I)+K
            NIL = IA(I)+L
            NKL = IA(K)+L
            IF(J.GT.K) THEN
              NJK=IA(J)+K
            ELSE
              NJK=IA(K)+J
            ENDIF
            IF(J.GT.L) THEN
              NJL=IA(J)+L
            ELSE
              NJL=IA(L)+J
            ENDIF
            F(NKL) = F(NKL)+VAL4*D(NIJ)
            F(NJK) = F(NJK)-VAL*D(NIL)
            F(NJL) = F(NJL)-VAL*D(NIK)
         ENDIF
C
 360   CONTINUE
C
C--------------------------------------------------------------------
      NRECRD = NRECRD + 1
*I32  IF(NRECRD.GT.888650) THEN
*I32    NRECRD = 1
*I32    NFILE = NFILE + 1
*I32    CALL SEQCLO(NEG7,'KEEP')
*I32    IF(NFILE.GT.9) THEN
*I32     WRITE(INAOFL(7:8),'(I2)') NFILE
*I32    ELSE
*I32     WRITE(INAOFL(7:8),'(I1,1H )') NFILE
*I32    ENDIF
*I32    CALL SEQOPN(NEG7,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32    CALL SEQREW(NEG7)
*I32  ENDIF
C--------------------------------------------------------------------JGK
C
       IF(NXX.GT.0) GO TO 310
C--------------------------------------------------------------------JGK
*I32  IF(NFILE.GT.1) THEN
*I32   CALL SEQCLO(NEG7,'KEEP')
*I32   CALL SEQOPN(NEG7,INAOFL(1:6),'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32   CALL SEQREW(NEG7)
*I32  ENDIF
C--------------------------------------------------------------------JGK
C
C     DONE CONSTRUCTING MATRIX, OFF DIAGONAL ELEMENTS NEED HALVING
C
  290 CONTINUE
      CALL DSCAL(NUMTRI,HALF,F,1)
      II = 0
      DO I=1,NUM
         II = II + I
         F(II) = F(II)+F(II)
      ENDDO
      CALL SEQREW(IS)
      RETURN
C     ******
C
  300 CONTINUE
      IF(MASWRK)
     *  WRITE(6,*) 'SUPERMATRIX FORMULATION NOT USED FOR ELONGATION'
      CALL ABRT
      RETURN
C     ******
C
C     ----- INTEGRALS ARE IN STANDARD -J- LIST (NOPK=.TRUE.) -----
C     ----- DOING SPECIAL DFT CASE WHERE EXCHANGE CONTRIBUTION  -----
C     ----- IS MULTIPLIED BY SOME NUMBER BETWEEN ZERO AND ONE   -----
C
  400 CONTINUE
      IF(MASWRK)
     *  WRITE(6,*)'DFT (HYBRID FUNCTIONALS) ARE NOT USED FOR ELONGATION'
      CALL ABRT
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ADDTWO
      SUBROUTINE ADDTWO(D,F,XX,IX,NINTMX,IA,NTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      CHARACTER*8 INAOFL
C
      DIMENSION D(*),F(*),IA(*),XX(NINTMX),IX(*)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /ELGFIL/ NFILE,INAOFL
C
      PARAMETER (HALF=0.5D+00)
C
      IF(LABSIZ.EQ.1) CALL ABRT
C
      IF(MASWRK) WRITE(6,*)' ------------SUBROUTINE ADDTWO ------------'
      NUMTRI = (NTOT*NTOT+NTOT)/2
      CALL VCLR(F,1,NUMTRI)
C----------------------------------------------------------------
C PART ONE (INTERACTIONS WITH MONOMER - PRACTICALLY ONLY COULOMB)
C----------------------------------------------------------------
        CALL SEQREW(NEG7)
        NRECRD = 1
        NFILE = 1
        INAOFL = 'EGINTA  '
C
 310    CONTINUE
      CALL PREAD(NEG7,XX,IX,NXX,NINTMX)
C
      IF(NXX .EQ. 0) GO TO 290
      NINT = IABS(NXX)
      IF(NINT .GT. NINTMX) CALL ABRT
C
       DO 360 M = 1,NINT
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL = IX( 2*NPACK - 1 )
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND(  LABEL, 65535 )
*I32        LABEL = IX( 2*NPACK     )
*I32        KPACK = ISHFT( LABEL, -16 )
*I32        LPACK = IAND(  LABEL, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK =       ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND(        LABEL,        255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         ENDIF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
         VAL = XX(M)
         VAL4 = (VAL+VAL)+(VAL+VAL)
C
C ONLY I < 0; J < 0 OR J > 0; K > 0; L > 0;
C
           NIJ = IA(I) + J
           NIK = IA(I) + K
           NIL = IA(I) + L
           NKL = IA(K) + L
C
         IF(J.GT.NUMOLD) THEN
           NJK = IA(J) + K
           NJL = IA(J) + L
           F(NIJ) = F(NIJ)+ VAL4*D(NKL)
           F(NIK) = F(NIK) - VAL*D(NJL)
           F(NIL) = F(NIL) - VAL*D(NJK)
           F(NJK) = F(NJK) - VAL*D(NIL)
           F(NJL) = F(NJL) - VAL*D(NIK)
         ELSEIF(K.GT.NUMOLD) THEN
           NJK = IA(K) + J
           IF(J.GT.L) THEN
            NJL = IA(J) + L
           ELSE
            NJL = IA(L) + J
           ENDIF
           F(NIJ) = F(NIJ)+ VAL4*D(NKL)
           F(NKL) = F(NKL)+ VAL4*D(NIJ)
           F(NIK) = F(NIK) - VAL*D(NJL)
           F(NIL) = F(NIL) - VAL*D(NJK)
           F(NJK) = F(NJK) - VAL*D(NIL)
         ELSE
           IF(J.GT.K) THEN
            NJK = IA(J) + K
           ELSE
            NJK = IA(K) + J
           ENDIF
           IF(J.GT.L) THEN
            NJL = IA(J) + L
           ELSE
            NJL = IA(L) + J
           ENDIF
           F(NIJ) = F(NIJ)+ VAL4*D(NKL)
           F(NIK) = F(NIK) - VAL*D(NJL)
           F(NIL) = F(NIL) - VAL*D(NJK)
         ENDIF
C
 360   CONTINUE
C-------------------------------------------------------------------
      NRECRD = NRECRD + 1
*I32  IF(NRECRD.GT.888650) THEN
*I32    NRECRD = 1
*I32    NFILE = NFILE + 1
*I32    CALL SEQCLO(NEG7,'KEEP')
*I32    IF(NFILE.GT.9) THEN
*I32     WRITE(INAOFL(7:8),'(I2)') NFILE
*I32    ELSE
*I32     WRITE(INAOFL(7:8),'(I1,1H )') NFILE
*I32    ENDIF
*I32    CALL SEQOPN(NEG7,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32    CALL SEQREW(NEG7)
*I32  ENDIF
C-------------------------------------------------------------------
       IF(NXX.GT.0) GO TO 310
C-------------------------------------------------------------------
*I32  IF(NFILE.GT.1) THEN
*I32   CALL SEQCLO(NEG7,'KEEP')
*I32   CALL SEQOPN(NEG7,INAOFL(1:6),'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32   CALL SEQREW(NEG7)
*I32  ENDIF
C-------------------------------------------------------------------
C
 290    CONTINUE
C-------------------------------------------------------------------
C PART 2 (THREE OR FOUR NEGATIVE INDICES)
C
        CALL SEQREW(NEG8)
        NFILE = 1
        NRECRD = 1
        INAOFL = 'EGINTB'
 410    CONTINUE
      CALL PREAD(NEG8,XX,IX,NXX,NINTMX)
C
      IF(NXX .EQ. 0) GO TO 390
      NINT = IABS(NXX)
      IF(NINT .GT. NINTMX) CALL ABRT
C
       DO 460 M = 1,NINT
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL = IX( 2*NPACK - 1 )
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND(  LABEL, 65535 )
*I32        LABEL = IX( 2*NPACK     )
*I32        KPACK = ISHFT( LABEL, -16 )
*I32        LPACK = IAND(  LABEL, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK =       ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND(        LABEL,        255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         ENDIF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
         VAL = XX(M)
         VAL4 = (VAL+VAL)+(VAL+VAL)
C
           NIJ = IA(I) + J
           NIK = IA(I) + K
           NIL = IA(I) + L
           NKL = IA(K) + L
           IF(J.GT.K) THEN
            NJK = IA(J) + K
           ELSE
            NJK = IA(K) + J
           ENDIF
           IF(J.GT.L) THEN
            NJL = IA(J) + L
           ELSE
            NJL = IA(L) + J
           ENDIF
C
         F(NIJ) = F(NIJ)+VAL4*D(NKL)
         F(NKL) = F(NKL)+VAL4*D(NIJ)
         F(NIK) = F(NIK)- VAL*D(NJL)
         F(NIL) = F(NIL)- VAL*D(NJK)
         F(NJK) = F(NJK)- VAL*D(NIL)
         F(NJL) = F(NJL)- VAL*D(NIK)
C
 460   CONTINUE
C------------------------------------------------------------------
      NRECRD = NRECRD + 1
*I32  IF(NRECRD.GT.888650) THEN
*I32    NRECRD = 1
*I32    NFILE = NFILE + 1
*I32    CALL SEQCLO(NEG8,'KEEP')
*I32    IF(NFILE.GT.9) THEN
*I32     WRITE(INAOFL(7:8),'(I2)') NFILE
*I32    ELSE
*I32     WRITE(INAOFL(7:8),'(I1,1H )') NFILE
*I32    ENDIF
*I32    CALL SEQOPN(NEG8,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32    CALL SEQREW(NEG8)
*I32  ENDIF
C------------------------------------------------------------------
       IF(NXX.GT.0) GO TO 410
C
 390    CONTINUE
C
C------------------------------------------------------------------
C-----TO MAKE PARALLEL CUT-OFF WITH ELGTOT POSSIBLE-----MMK
        IF(GOPARR) THEN
        CALL DDI_GSUMF(2007,F(1),NUMTRI)
        ENDIF
C-------------------------------------------------------MMK
C
C     DONE CONSTRUCTING MATRIX, OFF DIAGONAL ELEMENTS NEED HALVING
C
      CALL DSCAL(NUMTRI,HALF,F,1)
      II = 0
      DO I=1,NTOT
         II = II + I
         F(II) = F(II)+F(II)
      ENDDO
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK HSTEGU
      SUBROUTINE HSTEGU(DA,FA,DB,FB,XX,IX,NINTMX,IA,NOPK)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000)
*I32  CHARACTER*8 INAOFL
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /ORDOPT/ NORDER(7)
      COMMON /PCKLAB/ LABSIZ
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
C
      DIMENSION DA(*),FA(*),DB(*),FB(*),IA(*)
      DIMENSION XX(NINTMX),IX(NINTMX)
C
      PARAMETER (HALF=0.5D+00)
C
      IF(LABSIZ.EQ.1) CALL ABRT
      IF(NORDER(7).EQ.1) CALL ABRT
C
      NUMSCF = NUM
      NUMTRI = (NUMSCF*NUMSCF+NUMSCF)/2
      CALL VCLR(FA,1,NUMTRI)
      CALL VCLR(FB,1,NUMTRI)
      I = 0
      J = 0
      K = 0
      L = 0
      NXX = 0
      IF(DFTTYP(3) .NE. 1.0D+00) GO TO 500
      IF(NOPK.NE.1) GO TO 400
C
C     ----- INTEGRALS ARE NOT IN SUPERMATRIX FORM (NOPK=.TRUE.)
C
      NRECRD = 1
*I32  NFILE = 1
*I32  INAOFL = 'AOINTS  '
      CALL SEQREW(IS)
C
C-------------------------------------------------------------------
C   NOW 2E- PART OF CURRENT FRAGMENT (WITHOUT CUT-OFF PART) IS BUILT
C-------------------------------------------------------------------
C
  120 CONTINUE
      CALL PREAD(IS,XX,IX,NXX,NINTMX)
      IF(NXX.EQ.0) GO TO 210
      NINT = IABS(NXX)
      IF(NINT.GT.NINTMX) CALL ABRT
      DO 200 M = 1,NINT
               NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL = IX( 2*NPACK - 1 )
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND(  LABEL, 65535 )
*I32        LABEL = IX( 2*NPACK     )
*I32        KPACK = ISHFT( LABEL, -16 )
*I32        LPACK = IAND(  LABEL, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK =       ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND(        LABEL,        255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         ENDIF
C
                I = IPACK
                J = JPACK
                K = KPACK
                L = LPACK
C
      VAL = XX(M)
      VAL2 = VAL+VAL
      VAL4 = VAL2+VAL2
C
         NIJ = IA(I)+J
         NKL = IA(K)+L
         NIK = IA(I)+K
         NIL = IA(I)+L
         IF(J.LT.K) GO TO 140
         NJK = IA(J)+K
         NJL = IA(J)+L
         GO TO 180
C
  140    NJK = IA(K)+J
         IF(J.LT.L) GO TO 160
         NJL = IA(J)+L
         GO TO 180
C
  160    NJL = IA(L)+J
  180    CONTINUE
         DUM = VAL4*(DA(NKL)+DB(NKL))
         FA(NIJ) = FA(NIJ)+DUM
         FB(NIJ) = FB(NIJ)+DUM
         DUM = VAL4*(DA(NIJ)+DB(NIJ))
         FA(NKL) = FA(NKL)+DUM
         FB(NKL) = FB(NKL)+DUM
         FA(NIK) = FA(NIK)-VAL2*DA(NJL)
         FB(NIK) = FB(NIK)-VAL2*DB(NJL)
         FA(NIL) = FA(NIL)-VAL2*DA(NJK)
         FB(NIL) = FB(NIL)-VAL2*DB(NJK)
         FA(NJK) = FA(NJK)-VAL2*DA(NIL)
         FB(NJK) = FB(NJK)-VAL2*DB(NIL)
         FA(NJL) = FA(NJL)-VAL2*DA(NIK)
         FB(NJL) = FB(NJL)-VAL2*DB(NIK)
C
  200 CONTINUE
       NRECRD = NRECRD + 1
*I32   IF(NRECRD.GT.888650) THEN
*I32      NRECRD = 1
*I32      NFILE = NFILE + 1
*I32      CALL SEQCLO(IS,'KEEP')
*I32     IF(NFILE.GT.9) THEN
*I32      WRITE(INAOFL(7:8),'(I2)') NFILE
*I32     ELSE
*I32      WRITE(INAOFL(7:8),'(I1,1H )') NFILE
*I32     ENDIF
*I32      CALL SEQOPN(IS,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32      CALL SEQREW(IS)
*I32   ENDIF
      IF(NXX .GT. 0) GO TO 120
C
  210 CONTINUE
*I32   IF(NFILE.GT.1) THEN
*I32    CALL SEQCLO(IS,'KEEP')
*I32    CALL SEQOPN(IS,INAOFL(1:6),'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32    CALL SEQREW(IS)
*I32   ENDIF
C--------------------------------------------------------------------
C      NOW 2-ELECTRON INTERACTION PART [A(CUT-OFF) ---- B+M IS READ
C      BY CONSTRUCTION FIRST INDEX I CORRESPOND TO CUT-OFF FRAGMENT
C      OTHER INDICES: J,K,L BELONG TO B+M OR ONE OF THEM IS FROM A.
C--------------------------------------------------------------------
        CALL SEQREW(NEG7)
        NRECRD = 1
*I32    NFILE = 1
*I32    INAOFL = 'EGINTA  '
C
  220   CONTINUE
        CALL PREAD(NEG7,XX,IX,NXX,NINTMX)
        IF(NXX .EQ. 0) GO TO 300
        NINT = IABS(NXX)
        IF(NINT .GT. NINTMX) CALL ABRT
C
        DO 260 M = 1,NINT
           NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL = IX( 2*NPACK - 1 )
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND(  LABEL, 65535 )
*I32        LABEL = IX( 2*NPACK     )
*I32        KPACK = ISHFT( LABEL, -16 )
*I32        LPACK = IAND(  LABEL, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK =       ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND(        LABEL,        255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         ENDIF
C
           I = IPACK
           J = JPACK
           K = KPACK
           L = LPACK
C
          VAL = XX(M)
          VAL2 = VAL+VAL
          VAL4 = VAL2+VAL2
C
         IF(J.GT.NUMOLD) THEN
C
C          -------- I,J > NUMOLD;  K,L < NUMOLD --------
C
          NIJ = IA(I)+J
          NKL = IA(K)+L
C
          DUM = VAL4*(DA(NIJ)+DB(NIJ))
          FA(NKL) = FA(NKL)+DUM
          FB(NKL) = FB(NKL)+DUM
C
         ELSEIF(K.GT.NUMOLD) THEN
C
C          -------- I,K > NUMOLD;  J,L < NUMOLD --------
C
          NIK = IA(I)+K
          NJL = IA(J)+L
          IF(J.LT.L) NJL = IA(L)+J
          FA(NJL) = FA(NJL)-VAL2*DA(NIK)
          FB(NJL) = FB(NJL)-VAL2*DB(NIK)
C
         ELSE
C
C          -------- I > NUMOLD;  J,K,L < NUMOLD --------
C
          NIJ = IA(I)+J
          NKL = IA(K)+L
          NIK = IA(I)+K
          NIL = IA(I)+L
C
          IF(J.LT.K) THEN
           NJK = IA(K)+J
           NJL = IA(J)+L
           IF(J.LT.L) NJL = IA(L)+J
          ELSE
           NJK = IA(J)+K
           NJL = IA(J)+L
          ENDIF
C
          DUM = VAL4*(DA(NIJ)+DB(NIJ))
          FA(NKL) = FA(NKL)+DUM
          FB(NKL) = FB(NKL)+DUM
          FA(NJK) = FA(NJK)-VAL2*DA(NIL)
          FB(NJK) = FB(NJK)-VAL2*DB(NIL)
          FA(NJL) = FA(NJL)-VAL2*DA(NIK)
          FB(NJL) = FB(NJL)-VAL2*DB(NIK)
         ENDIF
C
  260  CONTINUE
C
       NRECRD = NRECRD + 1
*I32   IF(NRECRD.GT.888650) THEN
*I32      NRECRD = 1
*I32      NFILE = NFILE + 1
*I32     CALL SEQCLO(NEG7,'KEEP')
*I32     IF(NFILE.GT.9) THEN
*I32      WRITE(INAOFL(7:8),'(I2)') NFILE
*I32     ELSE
*I32      WRITE(INAOFL(7:8),'(I1,1H )') NFILE
*I32     ENDIF
*I32      CALL SEQOPN(NEG7,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32      CALL SEQREW(NEG7)
*I32   ENDIF
C
       IF(NXX.GT.0) GO TO 220
C
*I32   IF(NFILE.GT.1) THEN
*I32    CALL SEQCLO(NEG7,'KEEP')
*I32    CALL SEQOPN(NEG7,INAOFL(1:6),'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32    CALL SEQREW(NEG7)
*I32   ENDIF
C
C     DONE FORMING FOCK MATRIX, HALVE THE OFF DIAGONAL ELEMENTS
C
  300 CONTINUE
      L2 = (NUM*NUM+NUM)/2
      CALL DSCAL(L2,HALF,FA,1)
      CALL DSCAL(L2,HALF,FB,1)
      II = 0
      DO I=1,NUM
         II = II + I
         FA(II) = FA(II)+FA(II)
         FB(II) = FB(II)+FB(II)
      ENDDO
      CALL SEQREW(IS)
      CALL SEQREW(NEG7)
      RETURN
C     ******
  400 CONTINUE
      IF(MASWRK)
     *  WRITE(6,*) 'SUPERMATRIX FORMULATION NOT USED FOR ELONGATION'
      CALL ABRT
      RETURN
C     ******
  500 CONTINUE
      IF(MASWRK)
     *  WRITE(6,*) 'HYBRID FUNCTIONALS ARE NOT AVAILABLE FOR ELONGATION'
      CALL ABRT
      RETURN
C     ******
      END
C
C*MODULE ELGSCF  *DECK ADDUHF
      SUBROUTINE ADDUHF(DA,FA,DB,FB,XX,IX,NINTMX,IA,NTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      CHARACTER*8 INAOFL
C
      DIMENSION DA(*),FA(*),IA(*),XX(NINTMX),IX(*)
      DIMENSION DB(*),FB(*)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /ELGFIL/ NFILE,INAOFL
C
      PARAMETER (HALF=0.5D+00)
C
      IF(LABSIZ.EQ.1) CALL ABRT
C
      NUMTRI = (NTOT*NTOT+NTOT)/2
      CALL VCLR(FA,1,NUMTRI)
      CALL VCLR(FB,1,NUMTRI)
C----------------------------------------------------------------
C PART ONE (INTERACTIONS WITH MONOMER - PRACTICALLY ONLY COULOMB)
C----------------------------------------------------------------
        CALL SEQREW(NEG7)
        NRECRD = 1
        NFILE = 1
        INAOFL = 'EGINTA  '
C
 310    CONTINUE
      CALL PREAD(NEG7,XX,IX,NXX,NINTMX)
C
      IF(NXX .EQ. 0) GO TO 290
      NINT = IABS(NXX)
      IF(NINT .GT. NINTMX) CALL ABRT
C
       DO 360 M = 1,NINT
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL = IX( 2*NPACK - 1 )
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND(  LABEL, 65535 )
*I32        LABEL = IX( 2*NPACK     )
*I32        KPACK = ISHFT( LABEL, -16 )
*I32        LPACK = IAND(  LABEL, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK =       ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND(        LABEL,        255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         ENDIF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
         VAL = XX(M)
         VAL2 = VAL+VAL
         VAL4 = VAL2+VAL2
C
C ONLY I < 0; J < 0 OR J > 0; K > 0; L > 0;
C
           NIJ = IA(I) + J
           NIK = IA(I) + K
           NIL = IA(I) + L
           NKL = IA(K) + L
C
         IF(J.GT.NUMOLD) THEN
           NJK = IA(J) + K
           NJL = IA(J) + L
           DUM = VAL4*(DA(NKL)+DB(NKL))
           FA(NIJ) = FA(NIJ)+DUM
           FB(NIJ) = FB(NIJ)+DUM
           FA(NIK) = FA(NIK)-VAL2*DA(NJL)
           FB(NIK) = FB(NIK)-VAL2*DB(NJL)
           FA(NIL) = FA(NIL)-VAL2*DA(NJK)
           FB(NIL) = FB(NIL)-VAL2*DB(NJK)
           FA(NJK) = FA(NJK)-VAL2*DA(NIL)
           FB(NJK) = FB(NJK)-VAL2*DB(NIL)
           FA(NJL) = FA(NJL)-VAL2*DA(NIK)
           FB(NJL) = FB(NJL)-VAL2*DB(NIK)
         ELSEIF(K.GT.NUMOLD) THEN
           NJK = IA(K) + J
           IF(J.GT.L) THEN
            NJL = IA(J) + L
           ELSE
            NJL = IA(L) + J
           ENDIF
           DUM = VAL4*(DA(NKL)+DB(NKL))
           FA(NIJ) = FA(NIJ)+DUM
           FB(NIJ) = FB(NIJ)+DUM
           DUM = VAL4*(DA(NIJ)+DB(NIJ))
           FA(NKL) = FA(NKL)+DUM
           FB(NKL) = FB(NKL)+DUM
           FA(NIK) = FA(NIK)-VAL2*DA(NJL)
           FB(NIK) = FB(NIK)-VAL2*DB(NJL)
           FA(NIL) = FA(NIL)-VAL2*DA(NJK)
           FB(NIL) = FB(NIL)-VAL2*DB(NJK)
           FA(NJK) = FA(NJK)-VAL2*DA(NIL)
           FB(NJK) = FB(NJK)-VAL2*DB(NIL)
         ELSE
           IF(J.GT.K) THEN
            NJK = IA(J) + K
           ELSE
            NJK = IA(K) + J
           ENDIF
           IF(J.GT.L) THEN
            NJL = IA(J) + L
           ELSE
            NJL = IA(L) + J
           ENDIF
           DUM = VAL4*(DA(NKL)+DB(NKL))
           FA(NIJ) = FA(NIJ)+DUM
           FB(NIJ) = FB(NIJ)+DUM
           FA(NIK) = FA(NIK)-VAL2*DA(NJL)
           FB(NIK) = FB(NIK)-VAL2*DB(NJL)
           FA(NIL) = FA(NIL)-VAL2*DA(NJK)
           FB(NIL) = FB(NIL)-VAL2*DB(NJK)
         ENDIF
C
 360   CONTINUE
C---------------------------------------------------------------------
      NRECRD = NRECRD + 1
*I32  IF(NRECRD.GT.888650) THEN
*I32    NRECRD = 1
*I32    NFILE = NFILE + 1
*I32    CALL SEQCLO(NEG7,'KEEP')
*I32    IF(NFILE.GT.9) THEN
*I32     WRITE(INAOFL(7:8),'(I2)') NFILE
*I32    ELSE
*I32     WRITE(INAOFL(7:8),'(I1,1H )') NFILE
*I32    ENDIF
*I32    CALL SEQOPN(NEG7,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32    CALL SEQREW(NEG7)
*I32  ENDIF
C--------------------------------------------------------------------
       IF(NXX.GT.0) GO TO 310
C--------------------------------------------------------------------
*I32  IF(NFILE.GT.1) THEN
*I32   CALL SEQCLO(NEG7,'KEEP')
*I32   CALL SEQOPN(NEG7,INAOFL(1:6),'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32   CALL SEQREW(NEG7)
*I32  ENDIF
C--------------------------------------------------------------------
C
 290    CONTINUE
C--------------------------------------------------------------------
C PART 2 (THREE OR FOUR NEGATIVE INDICES)
C
        CALL SEQREW(NEG8)
        NFILE = 1
        NRECRD = 1
        INAOFL = 'EGINTB'
 410    CONTINUE
      CALL PREAD(NEG8,XX,IX,NXX,NINTMX)
C
      IF(NXX .EQ. 0) GO TO 390
      NINT = IABS(NXX)
      IF(NINT .GT. NINTMX) CALL ABRT
C
       DO 460 M = 1,NINT
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL = IX( 2*NPACK - 1 )
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND(  LABEL, 65535 )
*I32        LABEL = IX( 2*NPACK     )
*I32        KPACK = ISHFT( LABEL, -16 )
*I32        LPACK = IAND(  LABEL, 65535 )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -48 )
*I64        JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64        LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK =       ISHFT( LABEL, -24 )
*I32        JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32        KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32        LPACK = IAND(        LABEL,        255 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64           LPACK = IAND( LABEL, 255 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -56 )
*I64           JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64           KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64           LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64        END IF
         ENDIF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
         VAL = XX(M)
         VAL2 = VAL+VAL
         VAL4 = VAL2+VAL2
C
           NIJ = IA(I) + J
           NIK = IA(I) + K
           NIL = IA(I) + L
           NKL = IA(K) + L
           IF(J.GT.K) THEN
            NJK = IA(J) + K
           ELSE
            NJK = IA(K) + J
           ENDIF
           IF(J.GT.L) THEN
            NJL = IA(J) + L
           ELSE
            NJL = IA(L) + J
           ENDIF
C
           DUM = VAL4*(DA(NKL)+DB(NKL))
           FA(NIJ) = FA(NIJ)+DUM
           FB(NIJ) = FB(NIJ)+DUM
           DUM = VAL4*(DA(NIJ)+DB(NIJ))
           FA(NKL) = FA(NKL)+DUM
           FB(NKL) = FB(NKL)+DUM
           FA(NIK) = FA(NIK)-VAL2*DA(NJL)
           FB(NIK) = FB(NIK)-VAL2*DB(NJL)
           FA(NIL) = FA(NIL)-VAL2*DA(NJK)
           FB(NIL) = FB(NIL)-VAL2*DB(NJK)
           FA(NJK) = FA(NJK)-VAL2*DA(NIL)
           FB(NJK) = FB(NJK)-VAL2*DB(NIL)
           FA(NJL) = FA(NJL)-VAL2*DA(NIK)
           FB(NJL) = FB(NJL)-VAL2*DB(NIK)
C
 460   CONTINUE
C---------------------------------------------------------------------
      NRECRD = NRECRD + 1
*I32  IF(NRECRD.GT.888650) THEN
*I32    NRECRD = 1
*I32    NFILE = NFILE + 1
*I32    CALL SEQCLO(NEG8,'KEEP')
*I32    IF(NFILE.GT.9) THEN
*I32     WRITE(INAOFL(7:8),'(I2)') NFILE
*I32    ELSE
*I32     WRITE(INAOFL(7:8),'(I1,1H )') NFILE
*I32    ENDIF
*I32    CALL SEQOPN(NEG8,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
*I32    CALL SEQREW(NEG8)
*I32  ENDIF
C--------------------------------------------------------------------
       IF(NXX.GT.0) GO TO 410
C
 390    CONTINUE
C
C-----------TO MAKE PARALLEL CUT WITH ELGTOT POSSIBLE----------------
        IF(GOPARR) THEN
        CALL DDI_GSUMF(2008,FA(1),NUMTRI)
        CALL DDI_GSUMF(2009,FB(1),NUMTRI)
        ENDIF
C
C     DONE CONSTRUCTING MATRIX, OFF DIAGONAL ELEMENTS NEED HALVING
C
      CALL DSCAL(NUMTRI,HALF,FA,1)
      CALL DSCAL(NUMTRI,HALF,FB,1)
      II = 0
      DO I=1,NTOT
         II = II + I
         FA(II) = FA(II)+FA(II)
         FB(II) = FB(II)+FB(II)
      ENDDO
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK MOTRAO
      SUBROUTINE MOTRAO(U,CW,CX,WORK,VEC,NUM,
     *           NAAO,JXX,NOCC,NOCCA,NOCCB,NOCBM,ITER)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /ELGINF/ NNAAO,NCUTP,NCUT,NCUTT,NLATOT,NLBTOT,NLA,NLB,
     *                IMOCUT,IMOCUTT,NWA,NWM,NWMT,NHB
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      DIMENSION U(NWM,NWM),CW(NWA,NWM),CX(NAAO,JXX)
      DIMENSION WORK(NUM,NUM),VEC(NUM,NUM)
      LOGICAL OPTELG
      COMMON /ELGOPT/ OPTELG
C-------------------------------------------------------------------
C REVERSE THE NEW MO'S TO THE LMO'S ON THE BASES OF ATOMIC ORBITALS
C         NEW CWALPH AND CWBETA LMO'S ARE OBTAINED
C-------------------------------------------------------------------
      IF(ITER.LE.1) THEN
        IF(MASWRK) THEN
         WRITE(6,*)'ENTER MOTRAO'
         WRITE(6,'(''NWA,NWM,NAAO,JXX,NOCC,NOCCA,NOCCB,NOCBM='',
     *   8(I4,1X))') NWA,NWM,NAAO,JXX,NOCC,NOCCA,NOCCB,NOCBM
        END IF
C      WRITE(6,*)'C0W-MAT IN MOTRAO FOR ITER=',ITER
C      CALL WRITN4(NWM,NWA,CW,NWM,NWA)
      ENDIF
C
      CALL DGEMM('N','N',NWA,NWM,NWM,1.0D+00,CW,NWA,U,NWM,0.0D+00,
     *           WORK,NUM)
C---------------------------------------------------------------------
C MAKING THE TOTAL LMO'S (A+B REEGION) FOR DENSITY MATRIX CALCULATIONS
C        INCORPORATE THE CX LMO'S (B REGION LMO'S)
C         NEW CALPHA AND CBETA LMO'S ARE OBTAINED
C---------------------------------------------------------------------
CCC   FOR CLOSED SHELL SYSTEMS
C
      IF(ITER.LE.1.AND.(.NOT.OPTELG)) THEN
        CALL VCLR(VEC,1,NUM*NUM)
C
         DO 30 I=1,JXX
            IF(I.LE.NOCCA) THEN
               II = I
            ELSE
               II = NOCBM + I
            ENDIF
            DO 30 J=1,NAAO
               VEC(J,II) = CX(J,I)
 30      CONTINUE
      ENDIF
C---------------------------
      DO 40 I=1,NWM
         IF(I.LE.NOCBM) THEN
            II = NOCCA + I
         ELSE
            II = JXX + I
         ENDIF
         DO 40 J=1,NWA
 40   VEC(J,II) = WORK(J,I)
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK MOAORO
      SUBROUTINE MOAORO(C,CW,CX,WORK,VEC,NUM,NAAO,JXX,
     *           NOCA_A,NOCBM_A,NOCA_B,NOCBM_B,ITER)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /ELGINF/ NNAAO,NCUTP,NCUT,NCUTT,NLATOT,NLBTOT,NLA,NLB,
     *                IMOCUT,IMOCUTT,NWA,NWM,NWMT,NHB
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      DIMENSION CW(NWA,NWM),C(NWM,NWM),CX(NAAO,JXX)
      DIMENSION WORK(NUM,NUM),VEC(NUM,NUM)
      LOGICAL OPTELG                                               !JGK
      COMMON /ELGOPT/ OPTELG                                       !JGK
C-------------------------------------------------------------------
C REVERSE THE NEW MO'S TO THE LMO'S ON THE BASES OF ATOMIC ORBITALS
C         NEW CWALPH AND CWBETA LMO'S ARE OBTAINED
C-------------------------------------------------------------------
      IF(ITER.LE.1) THEN
        IF(MASWRK) THEN
         WRITE(6,*)
         WRITE(6,*)'------------ENTER MOAORO------------'
         WRITE(6,*)
         WRITE(6,'('' NWA,NWM,NAAO,JXX ='',4(I4,1X))') NWA,NWM,NAAO,JXX
         WRITE(6,*)
         WRITE(6,*)' NUMBER OF OCCUPIED ALPHA MO IN'
         WRITE(6,'('' FROZEN PART: '',I4,''  ACTIVE PART: '',I4)')
     *                NOCA_A,NOCBM_A
         WRITE(6,*)
         WRITE(6,*)'NUMBER OF OCCUPIED  BETA MO IN'
         WRITE(6,'('' FROZEN PART: '',I4,''  ACTIVE PART: '',I4)')
     *                NOCA_B,NOCBM_B
         WRITE(6,*)
        END IF
      ENDIF
C
      CALL DGEMM('N','N',NWA,NWM,NWM,1.0D+00,CW,NWA,C,NWM,0.0D+00,
     *           WORK,NUM)
C---------------------------------------------------------------------
C MAKING THE TOTAL LMO'S (A+B REEGION) FOR DENSITY MATRIX CALCULATIONS
C        INCORPORATE THE CX LMO'S (B REGION LMO'S)
C         NEW CALPHA AND CBETA LMO'S ARE OBTAINED
C---------------------------------------------------------------------
      NOCA  = MIN(NOCA_A,NOCA_B)
      NAREM = ABS(NOCA_A-NOCA_B)
      NOCBM = MAX(NOCBM_A,NOCBM_B)
      IF(ITER.LE.1) THEN
        IF(MASWRK) THEN
         WRITE(6,'(''   MIN(NOCCA_A,NOCCA_B)='',I4)') NOCA
         WRITE(6,'('' MAX(NOCCBM_A,NOCCBM_B)='',I4)') NOCBM
         WRITE(6,'(I4,'' MOS SHIFTED TO THE END OF OCCUPIED SPACE'')')
     *               NAREM
         WRITE(6,*)
        END IF
      ENDIF
C
      IF(ITER.LE.1.AND.(.NOT.OPTELG)) THEN
        CALL VCLR(VEC,1,NUM*NUM)
        DO 30 I=1,JXX
           IF(I.LE.NOCA) THEN
              II = I
           ELSE
              II = NOCBM + I
           ENDIF
           DO 30 J=1,NAAO
              VEC(J,II) = CX(J,I)
 30     CONTINUE
      ENDIF
C
      DO 40 I=1,NWM
         IF(I.LE.NOCBM) THEN
            II = NOCA + I
         ELSE
            II = JXX + I
         ENDIF
         DO 40 J=1,NWA
            VEC(J,II) = WORK(J,I)
 40   CONTINUE
C--------------------------------------------------------------------
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ADDONE
      SUBROUTINE ADDONE(QQ,NRUN)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,OUT,NORM,DOUBLE
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      DIMENSION QQ(*)
C
      DIMENSION DIJ(225),XIN(125),YIN(125),ZIN(125),
     *          IX(35),IY(35),IZ(35),JX(35),JY(35),JZ(35),
     *          IJX(225),IJY(225),IJZ(225)
      DIMENSION CHCINT(225)
      DIMENSION FIJ(225)
C
      PARAMETER (MXSH=5000, MXGTOT=20000,MXATM=2000)
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /STV   / XINT,YINT,ZINT,T,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
      COMMON /SYMIND/ TOL,II,JJ,LIT,LJT,MINI,MINJ,MAXI,MAXJ,IANDJ
C
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /NEWPAR/ NUMNEW,NATNEW,NSHNEW,ISNEW
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00,
     *           PI212=1.1283791670955D+00, SQRT3=1.73205080756888D+00,
     *           SQRT5=2.23606797749979D+00, SQRT7=2.64575131106459D+00,
     *           RLN10=2.30258D+00)
C
      DATA JX / 0, 1, 0, 0, 2, 0, 0, 1, 1, 0,
     *          3, 0, 0, 2, 2, 1, 0, 1, 0, 1,
     *          4, 0, 0, 3, 3, 1, 0, 1, 0, 2,
     *          2, 0, 2, 1, 1/
      DATA IX / 1, 6, 1, 1,11, 1, 1, 6, 6, 1,
     *         16, 1, 1,11,11, 6, 1, 6, 1, 6,
     *         21, 1, 1,16,16, 6, 1, 6, 1,11,
     *         11, 1,11, 6, 6/
      DATA JY / 0, 0, 1, 0, 0, 2, 0, 1, 0, 1,
     *          0, 3, 0, 1, 0, 2, 2, 0, 1, 1,
     *          0, 4, 0, 1, 0, 3, 3, 0, 1, 2,
     *          0, 2, 1, 2, 1/
      DATA IY / 1, 1, 6, 1, 1,11, 1, 6, 1, 6,
     *          1,16, 1, 6, 1,11,11, 1, 6, 6,
     *          1,21, 1, 6, 1,16,16, 1, 6,11,
     *          1,11, 6,11, 6/
      DATA JZ / 0, 0, 0, 1, 0, 0, 2, 0, 1, 1,
     *          0, 0, 3, 0, 1, 0, 1, 2, 2, 1,
     *          0, 0, 4, 0, 1, 0, 1, 3, 3, 0,
     *          2, 2, 1, 1, 2/
      DATA IZ / 1, 1, 1, 6, 1, 1,11, 1, 6, 6,
     *          1, 1,16, 1, 6, 1, 6,11,11, 6,
     *          1, 1,21, 1, 6, 1, 6,16,16, 1,
     *         11,11, 6, 6,11/
C
      DATA DBUGME/8HINT1    /
C
C    CALCULATE THE CHARGE-CHARGE CONTRIBUTION TO THE ONE ELECTRON
C    INTEGRALS FOR THE EFFECTIVE FRAGMENT POTENTIALS
C
C     ----- INTIALIZE PARALLEL -----
C
      IPCOUNT = ME - 1
C
C--------------------------------------------------------------------
C  PROCEDURE USED IN CUT-OFF ELONGATION CALCULATIONS FOR TWO PURPOSES
C  NRUN = 0   -- COMPUTE 1-ELECTRON CONTRIBUTION FROM CUT NUCLEI TO H
C  NRUN = 1   -- COMPUTE THE CUT-OFF PART OF TOTAL H (CUT + CURRENT)
C--------------------------------------------------------------------
C
      IF(NRUN.EQ.0) THEN
       NATSTR = NAT + 1
       NATEND = NATNEW
       ISHSTR = 1
       ISHEND = NSHELL
       JSHSTR = 1
       NTOT = NUM
      ELSE
       NATSTR = 1
       NATEND = NATNEW
       ISHSTR = NSHOLD + 1
       ISHEND = NSHNEW
       JSHSTR = 1
       NTOT = NUMNEW
      ENDIF
C
      IF(MASWRK) THEN
      WRITE(IW,'('' NATSTR='',I4,''  NATEND='',I4)')NATSTR,NATEND
      WRITE(IW,'('' ISHSTR='',I4,''  ISHEND='',I4)')ISHSTR,ISHEND
      WRITE(IW,'('' JSHSTR='',I4)')JSHSTR
      ENDIF
C
      TOL = RLN10*ITOL
      OUT = NPRINT.EQ.3  .OR.  EXETYP.EQ.DBUGME
      NORM = NORMF .NE. 1 .OR. NORMP .NE. 1
C
      L1 = NTOT
      L2 = (L1*L1+L1)/2
      CALL VCLR(QQ,1,L2)
C
C     ----- ISHELL
C
      DO 720 II = ISHSTR,ISHEND
         I = KATOM(II)
         XI = C(1,I)
         YI = C(2,I)
         ZI = C(3,I)
         I1 = KSTART(II)
         I2 = I1+KNG(II)-1
         LIT = KTYPE(II)
         MINI = KMIN(II)
         MAXI = KMAX(II)
         LOCI = KLOC(II)-MINI
C
C     ----- JSHELL
C
         DO 700 JJ = JSHSTR,II
C
C     ----- GO PARALLEL! -----
C
            IF (GOPARR) THEN
               IPCOUNT = IPCOUNT + 1
               IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 690
            END IF
            J = KATOM(JJ)
            XJ = C(1,J)
            YJ = C(2,J)
            ZJ = C(3,J)
            J1 = KSTART(JJ)
            J2 = J1+KNG(JJ)-1
            LJT = KTYPE(JJ)
            MINJ = KMIN(JJ)
            MAXJ = KMAX(JJ)
            LOCJ = KLOC(JJ)-MINJ
            NROOTS = (LIT+LJT-2)/2+1
            RR = (XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
            IANDJ = II .EQ. JJ
C
C     ----- PREPARE INDICES FOR PAIRS OF (I,J) FUNCTIONS
C
            IJ = 0
            MAX = MAXJ
            DO 160 I = MINI,MAXI
               NX = IX(I)
               NY = IY(I)
               NZ = IZ(I)
               IF (IANDJ) MAX = I
               DO 140 J = MINJ,MAX
                  IJ = IJ+1
                  IJX(IJ) = NX+JX(J)
                  IJY(IJ) = NY+JY(J)
                  IJZ(IJ) = NZ+JZ(J)
  140          CONTINUE
  160       CONTINUE
            DO 180 I = 1,IJ
               CHCINT(I) = ZERO
  180       CONTINUE
C
C     ----- I PRIMITIVE
C
            JGMAX = J2
            DO 520 IG = I1,I2
               AI = EX(IG)
               ARRI = AI*RR
               AXI = AI*XI
               AYI = AI*YI
               AZI = AI*ZI
               CSI = CS(IG)
               CPI = CP(IG)
               CDI = CD(IG)
               CFI = CF(IG)
               CGI = CG(IG)
C
C
C     ----- J PRIMITIVE
C
               IF (IANDJ) JGMAX = IG
               DO 500 JG = J1,JGMAX
                  AJ = EX(JG)
                  AA = AI+AJ
                  AA1 = ONE/AA
                  DUM = AJ*ARRI*AA1
                  IF (DUM .GT. TOL) GO TO 500
                  FAC = EXP(-DUM)
                  CSJ = CS(JG)
                  CPJ = CP(JG)
                  CDJ = CD(JG)
                  CFJ = CF(JG)
                  CGJ = CG(JG)
                  AX = (AXI+AJ*XJ)*AA1
                  AY = (AYI+AJ*YJ)*AA1
                  AZ = (AZI+AJ*ZJ)*AA1
C
C     ----- DENSITY FACTOR
C
                  DOUBLE=IANDJ.AND.IG.NE.JG
                  MAX = MAXJ
                  NN = 0
                  DUM1 = ZERO
                  DUM2 = ZERO
                  DO 220 I = MINI,MAXI
                     IF (I.EQ.1) DUM1=CSI*FAC
                     IF (I.EQ.2) DUM1=CPI*FAC
                     IF (I.EQ.5) DUM1=CDI*FAC
                     IF ((I.EQ.8).AND.NORM) DUM1=DUM1*SQRT3
                     IF (I.EQ.11) DUM1=CFI*FAC
                     IF ((I.EQ.14).AND.NORM) DUM1=DUM1*SQRT5
                     IF ((I.EQ.20).AND.NORM) DUM1=DUM1*SQRT3
                     IF (I.EQ.21) DUM1=CGI*FAC
                     IF ((I.EQ.24).AND.NORM) DUM1=DUM1*SQRT7
                     IF ((I.EQ.30).AND.NORM) DUM1=DUM1*SQRT5/SQRT3
                     IF ((I.EQ.33).AND.NORM) DUM1=DUM1*SQRT3
                     IF (IANDJ) MAX = I
                     DO 200 J = MINJ,MAX
                        IF (J.EQ.1) THEN
                           DUM2=DUM1*CSJ
                           IF (DOUBLE) THEN
                              IF (I.LE.1) THEN
                                 DUM2=DUM2+DUM2
                              ELSE
                                 DUM2=DUM2+CSI*CPJ*FAC
                              END IF
                           END IF
                        ELSE IF (J.EQ.2) THEN
                           DUM2=DUM1*CPJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF (J.EQ.5) THEN
                           DUM2=DUM1*CDJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.8).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        ELSE IF (J.EQ.11) THEN
                           DUM2=DUM1*CFJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.14).AND.NORM) THEN
                           DUM2=DUM2*SQRT5
                        ELSE IF ((J.EQ.20).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        ELSE IF (J.EQ.21) THEN
                           DUM2=DUM1*CGJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.24).AND.NORM) THEN
                           DUM2=DUM2*SQRT7
                        ELSE IF ((J.EQ.30).AND.NORM) THEN
                           DUM2=DUM2*SQRT5/SQRT3
                        ELSE IF ((J.EQ.33).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        END IF
                        NN = NN+1
                        DIJ(NN) = DUM2
  200                CONTINUE
  220             CONTINUE
C
C     EFFECTIVE POINT CHARGES INTEGRALS.
C
                  DUM = PI212*AA1
                  DO 400 I=1,IJ
                     FIJ(I) = DIJ(I)*DUM
  400             CONTINUE
                  AAX = AA*AX
                  AAY = AA*AY
                  AAZ = AA*AZ
                  DO 492 IC = NATSTR,NATEND
                     ZNUC = -ZAN(IC)
                     CX = C(1,IC)
                     CY = C(2,IC)
                     CZ = C(3,IC)
                     XX = AA*((AX-CX)**2+(AY-CY)**2+(AZ-CZ)**2)
                     IF (NROOTS.LE.3) CALL RT123
                     IF (NROOTS.EQ.4) CALL ROOT4
                     IF (NROOTS.EQ.5) CALL ROOT5
                     MM = 0
                     DO 477 K = 1,NROOTS
                        UU = AA*U(K)
                        WW = W(K)*ZNUC
                        TT = ONE/(AA+UU)
                        T = SQRT(TT)
                        X0 = (AAX+UU*CX)*TT
                        Y0 = (AAY+UU*CY)*TT
                        Z0 = (AAZ+UU*CZ)*TT
                        IN = -5+MM
                        DO 476 I = 1,LIT
                           IN = IN+5
                           NI = I
                           DO 475 J = 1,LJT
                              JN = IN+J
                              NJ = J
                              CALL STVINT
                              XIN(JN) = XINT
                              YIN(JN) = YINT
                              ZIN(JN) = ZINT*WW
  475                      CONTINUE
  476                   CONTINUE
                        MM = MM+25
  477                CONTINUE
                     DO 481 I = 1,IJ
                        NX = IJX(I)
                        NY = IJY(I)
                        NZ = IJZ(I)
                        DUM = ZERO
                        MM = 0
                        DO 479 K = 1,NROOTS
                           DUM = DUM+XIN(NX+MM)*YIN(NY+MM)*ZIN(NZ+MM)
                           MM = MM+25
  479                   CONTINUE
                        CHCINT(I) = CHCINT(I)+DUM*FIJ(I)
  481                CONTINUE
C
C     ----- END POINT CHARGES -----
C
  492             CONTINUE
C
C     ----- END PRIMITIVES -----
C
  500          CONTINUE
  520       CONTINUE
C
C           NXYZ = (301*301+301)/2
           NXYZ = (302*302+302)/2
C
            MAX = MAXJ
            NN = 0
            DO 620 I = MINI,MAXI
               LI = LOCI+I
               IN = (LI*(LI-1))/2
               IF (IANDJ) MAX = I
               DO 600 J = MINJ,MAX
                  LJ = LOCJ+J
                  JN = LJ+IN
                  NN = NN+1
                  QQ(JN) = QQ(JN) + CHCINT(NN)
       IF(JN.EQ.NXYZ) WRITE(6,*)'JN,NN,QQ,CHG=',JN,NN,QQ(JN),CHCINT(NN)
  600          CONTINUE
  620       CONTINUE
C
C     ----- END PARALLEL
C
  690    CONTINUE
C
C     ----- END SHELLS -----
C
  700    CONTINUE
  720 CONTINUE
C
C     ----- SUM UP PARTIAL CONTRIBUTIONS IF PARALLEL -----
C
      IF (GOPARR) CALL DDI_GSUMF(920,QQ,L2)
C
C     ----- DONE WITH INTEGRALS -----
C
      IF(MASWRK.AND.OUT) THEN
         WRITE(IW,*) 'MISSING ONE ELECTRON INTEGRALS ARE ADDED'
         CALL PRTRIL(QQ,L1)
      END IF
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ENCUT1
      SUBROUTINE ENCUT1(NTOT,NFRGBS,NUMX,NCTATM,DTOT,HTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000, MXAO=8192)
C
      LOGICAL PACK2E,SCHWZT,LFLD,SKPCUT
      LOGICAL GOPARR,MASWRK,DSKWRK,DIRSCF,FDIFF
      CHARACTER*8 INAOFL
      DIMENSION DTOT(NTOT*(NTOT+1)/2),HTOT(NTOT*(NTOT+1)/2)
      DOUBLE PRECISION NUCREP
      LOGICAL OUT
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /NEWPAR/ NUMNEW,NATNEW,NSHNEW,ISNEW
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /ELGFIL/ NFILE,INAOFL
      COMMON /ECTSKP/ SKPCUT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
C
      DATA RHF/8HRHF     /
      DATA FFIELD/8HFFIELD  /
C
      PARAMETER (HALF=0.5D+00)
C
      NTOTAL = NTOT*(NTOT + 1)/2
      NRECT1 = NFRGBS*(NFRGBS+1)/2 + NFRGBS*(NUMX-NFRGBS)
      NRECT2 = NFRGBS*(NFRGBS+1)/2 + NFRGBS*(NTOT-NFRGBS)
      NCURRT = NUM*(NUM+1)/2
C
      IF(SKPCUT) THEN
         LOADFM = 0
         CALL VALFM(LOADFM)
         LD   = LOADFM +   1
         LD1  = LD     +   NCURRT
         LAST = LD1    +   NRECT2
         NEED = LAST - LOADFM - 1
         CALL GETFM(NEED)
         CALL VCLR(X(LD),1,NEED)
         CALL SEQREW(NEG4)
         READ(NEG4)
         READ(NEG4)
         READ(NEG4)
         READ(NEG4)
         READ(NEG4)
         READ(NEG4)
         READ(NEG4) (X(LD1+J),J=0,NRECT1-1)
         CALL DAREAD(IDAF,IODA,X(LD),NCURRT,16,0)
         GOTO 100
      ENDIF
C
      NSHELL = NSHNEW
C
      NREC   = 1
      INTLOC = 1
      ICOUNT = 1
      ISOLD  = IS
      ISNEW  = NEG8
      IS     = ISNEW
C
      IST = NSHOLD + 1
      JST = 1
      KST = 1
      LST = 1
C
      CALL SEQREW(IS)
      NSH2 = (NSHNEW*NSHNEW+NSHNEW)/2
      MXGSH=30
      MXG2=MXGSH*MXGSH
      CALL BASCHK(LMAX)
      NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      MAXG = NANGM**4
C
      LOADFM = 0
      CALL VALFM(LOADFM)
      LD   = LOADFM +   1
      LH   = LD     +   NCURRT
      LF   = LH     +   NCURRT
      LD1  = LF     +   NCURRT
      LH1  = LD1    +   NRECT2
      LFT  = LH1    +   NRECT2
      LH2  = LFT    +   NTOTAL
      LAST = LH2    +   NTOTAL
C
      IF(.NOT.DIRSCF) THEN
         LBUFP  = LAST
         LBUFK  = LBUFP   +   NINTMX
         LIBUF  = LBUFK   +   NINTMX
         LXINTS = LIBUF   +   NINTMX
         LGHOND = LXINTS  +   NSH2
         LDDIJ  = LGHOND  +   MAXG
         LAST   = LDDIJ   +   16*MXG2
      ELSE
         LXINTS= LAST
         LGHOND= LXINTS + NSH2
         LDSH  = LGHOND + MAXG
         LDDIJ = LDSH   + NSH2
         LAST  = LDDIJ  + 16*MXG2
      ENDIF
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL VCLR(X(LD),1,NEED)
C
      CALL SEQREW(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4) (X(LD1+J),J=0,NRECT1-1)
C
      LFLD = .FALSE.
      IF(RUNTYP.EQ.FFIELD) THEN
         LFLD = .TRUE.
         CALL DAREAD(IDAF,IODA,X(LD),NCURRT,11,0)
         CALL DAREAD(IDAF,IODA,X(LH),NCURRT,94,0)
         CALL VSUB(X(LH),1,X(LD),1,X(LD),1,NCURRT)
         CALL DAREAD(IDAF,IODA,X(LF),NCURRT,14,0)
         CALL VSUB(X(LD),1,X(LF),1,X(LF),1,NCURRT)
         CALL DAREAD(IDAF,IODA,X(LD),NCURRT,16,0)
      ELSE
         CALL DAREAD(IDAF,IODA,X(LH),NCURRT,11,0)
         CALL DAREAD(IDAF,IODA,X(LF),NCURRT,14,0)
         CALL DAREAD(IDAF,IODA,X(LD),NCURRT,16,0)
      ENDIF
C
      CALL VCLR(HTOT,1,NTOTAL)
      CALL ADDONE(HTOT,1)
      CALL ADDKIN(X(LFT),NTOTAL,NSHOLD+1,NSHNEW)
C
      CALL VADD(HTOT,1,X(LFT),1,HTOT,1,NTOTAL)
      CALL VCLR(X(LFT),1,NTOTAL)
C
      CALL DENCUT(X(LD),X(LD1),DTOT,NUMOLD,NFRGBS,NCURRT,NRECT2,NTOTAL)
C
      IF(DIRSCF) THEN
         DUMMY = 0.0D+00
         IDUMMY = 1
         NINT = 0
         NSCHWZ = 0
         SCHWZT = ISCHWZ.GT.0
         IST = NSHOLD + 1
         JST = 1
         KST = 1
         LST = 1
         NREC   = 1
         INTLOC = 1
         ICOUNT = 1
         IF(SCHWZT) THEN
            CALL SHLDEN(RHF,DTOT,DUMMY,DUMMY,X(LDSH),
     *                     IA,NTOT,NTOTAL,NSH2,1)
            CALL EXCHNG(X(LXINTS),X(LGHOND),X(LDDIJ),
     *                          NSH2,MAXG,INTTYP)
         ENDIF
         IF(MASWRK) WRITE(6,*) 'DIRECT SCF CALCULATION, SCHWRZ=',SCHWZT
C
         CALL ADDINT(RHF,DIRSCF,.FALSE.,.FALSE.,.FALSE.,
     *        SCHWZT,NINT,NSCHWZ,NCURRT,
     *        DUMMY,DUMMY,IDUMMY,1,
     *        X(LXINTS),NSH2,X(LGHOND),MAXG,
     *        IA,DTOT,X(LFT),DUMMY,DUMMY,X(LDSH),
     *        .TRUE.,NTOT,NTOTAL,NTOTAL)
        IF(MASWRK)
     *   WRITE(IW,*) NINT,' NON-ZERO INTEGRALS',NSCHWZ,' SKIPPED BLOCKS'
         CALL DSCAL(NTOTAL,0.5D+00,X(LFT),1)
         II=LFT-1
         DO 10 I=1,NTOT
            II = II+I
            X(II) = X(II) + X(II)
 10      CONTINUE
      ELSE
C
         NFILE = 1
         INAOFL = 'EGINTB  '
         NEGX = NEG7
         NEG7 = NEG8
         NSHELL = NSHNEW
         NSCHWZ = 0
         SCHWZT = ISCHWZ.GT.0
         IST = NSHOLD + 1
         JST = 1
         KST = 1
         LST = 1
         NREC   = 1
         INTLOC = 1
         ICOUNT = 1
         IDUMMY=0
         DUMMY=0.0D+00
         IF(SCHWZT) CALL EXCHNG(X(LXINTS),X(LGHOND),X(LDDIJ),
     *        NSH2,MAXG,INTTYP)
C
         CALL ADDINT(RHF,.FALSE.,.FALSE.,.FALSE.,.FALSE.,
     *        SCHWZT,NINT,NSCHWZ,1,
     *        X(LBUFP),X(LBUFK),X(LIBUF),NINTMX,
     *        X(LXINTS),NSH2,X(LGHOND),MAXG,
     *        IDUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,
     *        .TRUE.,1,1,1)
         NEG7 = NEGX
C
         CALL ADDTWO(DTOT,X(LFT),X(LBUFP),X(LIBUF),NINTMX,IA,NTOT)
      ENDIF
C
      DO 20 I=1,NCURRT
         X(LFT+I-1) = X(LF+I-1)-X(LH+I-1)
         HTOT(I) = X(LH+I-1)
 20   CONTINUE
C
      CALL DIPCUT(DTOT,NTOTAL,LFLD,FLVAL)
C
      E1ESUM = TRACEP(DTOT,HTOT,NTOT)
      E2ESUM = HALF*TRACEP(DTOT,X(LFT),NTOT)
      CALL VADD(X(LFT),1,HTOT,1,X(LFT),1,NTOTAL)
      EHF = TRACEP(DTOT,X(LFT),NTOT)
      EHFSUM = HALF*(EHF + E1ESUM)
C
      EN = NUCREP(MXATM,NCTATM+NAT,ZAN,C)
C
      IF(MASWRK) THEN
      IF(LFLD) THEN
         WRITE(IW,'(54(1H-))')
         WRITE(IW,*) '    TOTAL ENERGY FOR CUT OFF FINITE FIELD RUN'
         WRITE(IW,'(54(1H-))')
         WRITE(IW,'(''     ELONGATION RHF TOTAL ENERGY: '',F20.12)')
     *        EHFSUM+EN+FLVAL
         WRITE(IW,'(54(1H-))')
         WRITE(IW,*)
      ELSE
         WRITE(IW,'(54(1H-))')
         WRITE(IW,*) '      TOTAL ENERGY INCLUDING CUT OFF FRAGMENT'
         WRITE(IW,'(54(1H-))')
         WRITE(IW,'(''    ELONGATION 1-ELECTRON ENERGY: '',F20.12)')
     *        E1ESUM
         WRITE(IW,'(''    ELONGATION 2-ELECTRON ENERGY: '',F20.12)')
     *        E2ESUM
         WRITE(IW,'(''  TOTAL NUCLEAR REPULSION ENERGY: '',F20.12)')
     *        EN
         WRITE(IW,'(34X,20(1H-))')
         WRITE(IW,'(''     ELONGATION RHF TOTAL ENERGY: '',F20.12)')
     *        EHFSUM+EN
         WRITE(IW,*)
         WRITE(IW,'(''ELONGATION RHF ELECTRONIC ENERGY: '',F20.12)')
     *        EHFSUM
         WRITE(IW,'(54(1H-))')
         WRITE(IW,*)
      ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  FOR CUT-OFF PURPOSES,  WRITING ON TAPE FOR THE NEXT ELONGATION STEP,
C  THE TOTAL DENSITY MATRIX SHOULD BE REARRANGED SO IT WILL BE DONE NOW
C
 100  CONTINUE
      CALL VCLR(DTOT,1,NTOTAL)
      II = 0
      JJ = 0
      KK = 1
      DO 110 J = 1,NFRGBS + NUM
         DO 110 K = 1,J
            IF(K.LE.NFRGBS) THEN
               DTOT(KK) = X(LD1+II)
               II = II + 1
               KK = KK + 1
            ELSE
               DTOT(KK) = X(LD + JJ)
               JJ = JJ + 1
               KK = KK + 1
            ENDIF
 110  CONTINUE
C-----------------------------------------------------------------------
      CALL RETFM(NEED)
      RETURN
      END
C
C*MODULE ELGSCF  *DECK NUCREP
      DOUBLE PRECISION FUNCTION NUCREP(MXATM,N,Z,C)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Z(MXATM),C(3,MXATM)
C
      NSTART = 2
      NEND   = N
C
      NUCREP = 0.0D+00
      DO 30 I = NSTART,NEND
         NI = I-1
         DO 30 J = NSTART-1,NI
            R2 = 0.0D+00
            DO 20 K = 1,3
               R2 = R2+(C(K,I)-C(K,J))**2
 20         CONTINUE
            NUCREP = NUCREP+Z(I)*Z(J)/SQRT(R2)
 30   CONTINUE
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK DENRLX
      SUBROUTINE DENRLX(NEG5,DA,DB,LL,NUMX,NFRGBS,NCTAO)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      DATA RHF,UHF/8HRHF     ,8HUHF     /
      DIMENSION DA(LL),DB(LL)
C
      CALL SEQREW(NEG5)
      READ(NEG5)
      READ(NEG5)
      IF(SCFTYP.EQ.UHF) THEN
        READ(NEG5)
        READ(NEG5)
      END IF
      READ(NEG5)
      IF(SCFTYP.NE.RHF) READ(NEG5)
      READ(NEG5) (DA(I),I=1,(NUMX-NFRGBS)*(NUMX-NFRGBS+1)/2)
      CALL CUTSHT(DA,LL,NUMX-NFRGBS,NCTAO,0)
      IF(SCFTYP.NE.RHF) THEN
         READ(NEG5) (DB(I),I=1,(NUMX-NFRGBS)*(NUMX-NFRGBS+1)/2)
         CALL CUTSHT(DB,LL,NUMX-NFRGBS,NCTAO,0)
      ENDIF
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ELGDIR
      SUBROUTINE ELGDIR(IA,DA,FA,DB,FB,GHONDO,NINT,ELGTOT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,UROHF
      LOGICAL ELGTOT
C
      DIMENSION IA(*),DA(*),FA(*),DB(*),FB(*),GHONDO(*)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /ERIOUT/ ISH,JSH,KSH,LSH,LSTRI,LSTRJ,LSTRK,LSTRL
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJX,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
C
      DATA HALF /0.5D+00/
      DATA UHF,ROHF/8HUHF     ,8HROHF     /
C
C-NEXT STATEMENT IS FOR VARIOUS IBM XLF 3.X AND 5.X COMPILERS-
C
      SAVE IJN,KLN
C
C     ----- FORM FOCK OPERATOR DIRECTLY FROM INTEGRALS -----
C     THIS ROUTINE WAS PIECED TOGETHER FROM QOUT AND HSTAR
C     BY FRANK JENSEN AT ODENSE UNIVERSITY IN MARCH 1990.
C     SCF FUNCTIONS BESIDES RHF ADDED BY MWS IN AUGUST 1991.
C
C     NOTE THAT OFF-DIAGONAL ELEMENTS WILL NEED TO BE HALVED LATER.
C
      UROHF = SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF
      CUTINT = CUTOFF
C
      SAME  = ISH .EQ. KSH .AND. JSH .EQ. LSH
      IANDJ = ISH .EQ. JSH
      KANDL = KSH .EQ. LSH
C
      MINI = KMIN(ISH)
      MINJ = KMIN(JSH)
      MINK = KMIN(KSH)
      MINL = KMIN(LSH)
      MAXI = KMAX(ISH)
      MAXJ = KMAX(JSH)
      MAXK = KMAX(KSH)
      MAXL = KMAX(LSH)
      LOCI = KLOC(ISH)-MINI
      LOCJ = KLOC(JSH)-MINJ
      LOCK = KLOC(KSH)-MINK
      LOCL = KLOC(LSH)-MINL
C
      IJN = 0
      JMAX = MAXJ
      DO 360 I = MINI,MAXI
         I_INDEX = (I-MINI)*LSTRI + 1
         IF (IANDJ) JMAX = I
         DO 340 J = MINJ,JMAX
            IJ_INDEX = (J-MINJ)*LSTRJ + I_INDEX
            IJN = IJN+1
            LMAX = MAXL
            KLN = 0
            DO 320 K =  MINK,MAXK
               IJK_INDEX = (K-MINK)*LSTRK + IJ_INDEX
               IF (KANDL) LMAX = K
               DO 300 L = MINL,LMAX
                  KLN = KLN+1
                  IF(SAME .AND. KLN.GT.IJN) GO TO 340
                  IJKL_INDEX = (L-MINL)*LSTRL + IJK_INDEX
C
                  VAL = GHONDO( IJKL_INDEX )
                  IF(ABS(VAL).LT.CUTINT) GO TO 300
                  NINT = NINT + 1
C
                  II = LOCI+I
                  JJ = LOCJ+J
                  KK = LOCK+K
                  LL = LOCL+L
C
                  IF (II .GE. JJ) GO TO 100
                  N = II
                  II = JJ
                  JJ = N
 100              IF (KK .GE. LL) GO TO 120
                  N = KK
                  KK = LL
                  LL = N
  120             IF (II-KK) 140,160,180
  140             N = II
                  II = KK
                  KK = N
                  N = JJ
                  JJ = LL
                  LL = N
                  GO TO 180
  160             IF (JJ .LT. LL) GO TO 140
  180             CONTINUE
C
                  IF(II.EQ.JJ) VAL = VAL*HALF
                  IF(KK.EQ.LL) VAL = VAL*HALF
                  IF(II.EQ.KK  .AND.  JJ.EQ.LL) VAL = VAL*HALF
C
C      WE NOW HAVE EVERYTHING READY, PUT INTEGRALS INTO FOCK MATRIX
C
C
                  VAL2 = VAL+VAL
                  VAL4 = VAL2+VAL2
C
                  IF(ELGTOT) GOTO 200
C
                  IF(II.LE.NUMOLD) THEN
                     NIJ = IA(II)+JJ
                     NKL = IA(KK)+LL
                     NIK = IA(II)+KK
                     NIL = IA(II)+LL
                     NJK = IA(JJ)+KK
                     NJL = IA(JJ)+LL
                     IF(JJ.LT.KK) NJK = IA(KK)+JJ
                     IF(JJ.LT.LL) NJL = IA(LL)+JJ
C
                     IF(UROHF) THEN
                     DUM = VAL4*(DA(NKL)+DB(NKL))
                     FA(NIJ) = FA(NIJ)+DUM
                     FB(NIJ) = FB(NIJ)+DUM
                     DUM = VAL4*(DA(NIJ)+DB(NIJ))
                     FA(NKL) = FA(NKL)+DUM
                     FB(NKL) = FB(NKL)+DUM
                     FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                     FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                     FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                     FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                     FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                     FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                     FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                     FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                     ELSE
                     FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                     FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                     FA(NIK) = FA(NIK)- VAL*DA(NJL)
                     FA(NIL) = FA(NIL)- VAL*DA(NJK)
                     FA(NJK) = FA(NJK)- VAL*DA(NIL)
                     FA(NJL) = FA(NJL)- VAL*DA(NIK)
                     ENDIF
                  ELSEIF(JJ.GT.NUMOLD) THEN
C
C          -------- II,JJ > NUMOLD;  KK,LL < NUMOLD --------
C
                     NKL = IA(KK)+LL
                     NIJ = IA(II)+JJ
                     IF(UROHF) THEN
                     DUM = VAL4*(DA(NIJ)+DB(NIJ))
                     FA(NKL) = FA(NKL)+DUM
                     FB(NKL) = FB(NKL)+DUM
                     ELSE
                     FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                     ENDIF
C
                  ELSEIF(KK.GT.NUMOLD) THEN
C
C          -------- II,KK > NUMOLD;  JJ,LL < NUMOLD --------
C
                     NIK = IA(II)+KK
                     IF(JJ.GT.LL) THEN
                        NJL = IA(JJ) + LL
                     ELSE
                        NJL = IA(LL) + JJ
                     ENDIF
                     IF(UROHF) THEN
                     FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                     FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                     ELSE
                     FA(NJL) = FA(NJL) - VAL*DA(NIK)
                     ENDIF
C
                  ELSE
C
C          -------- II > NUMOLD;  JJ,KK,LL < NUMOLD --------
C
                     NIJ = IA(II)+JJ
                     NIK = IA(II)+KK
                     NIL = IA(II)+LL
                     NKL = IA(KK)+LL
                    IF(JJ.GT.KK) THEN
                       NJK=IA(JJ)+KK
                       NJL=IA(JJ)+LL
                    ELSE
                       NJK=IA(KK)+JJ
                       IF(JJ.GT.LL) THEN
                          NJL=IA(JJ)+LL
                       ELSE
                          NJL=IA(LL)+JJ
                       ENDIF
                    ENDIF
                   IF(UROHF) THEN
                   DUM = VAL4*(DA(NIJ)+DB(NIJ))
                   FA(NKL) = FA(NKL)+DUM
                   FB(NKL) = FB(NKL)+DUM
                   FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                   FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                   FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                   FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                   ELSE
                   FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                   FA(NJK) = FA(NJK)-VAL*DA(NIL)
                   FA(NJL) = FA(NJL)-VAL*DA(NIK)
                   ENDIF
C
                ENDIF
C
C----------------------------------------------------------------------
                GOTO 300
C----------------------------------------------------------------------
 200            CONTINUE
                IF(LL.GT.NUMOLD) THEN
                   IF(JJ.GT.NUMOLD) THEN
C
C     -------- II,JJ,KK,LL > NUMOLD --------
C
                      NIJ = IA(II)+JJ
                      NKL = IA(KK)+LL
                      NIK = IA(II)+KK
                      NIL = IA(II)+LL
                      NJK = IA(JJ)+KK
                      NJL = IA(JJ)+LL
                      IF(JJ.LT.KK) NJK = IA(KK)+JJ
                      IF(JJ.LT.LL) NJL = IA(LL)+JJ
C
                      IF(UROHF) THEN
                      DUM = VAL4*(DA(NKL)+DB(NKL))
                      FA(NIJ) = FA(NIJ)+DUM
                      FB(NIJ) = FB(NIJ)+DUM
                      DUM = VAL4*(DA(NIJ)+DB(NIJ))
                      FA(NKL) = FA(NKL)+DUM
                      FB(NKL) = FB(NKL)+DUM
                      FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                      FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                      FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                      FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                      FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                      FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                      FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                      FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                      ELSE
                      FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                      FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                      FA(NIK) = FA(NIK)- VAL*DA(NJL)
                      FA(NIL) = FA(NIL)- VAL*DA(NJK)
                      FA(NJK) = FA(NJK)- VAL*DA(NIL)
                      FA(NJL) = FA(NJL)- VAL*DA(NIK)
                      ENDIF
C
                   ELSE
C
C          -------- II,KK,LL > NUMOLD;  JJ < NUMOLD --------
C
                      NIJ = IA(II)+JJ
                      NKL = IA(KK)+LL
                      NIK = IA(II)+KK
                      NIL = IA(II)+LL
                      NJK = IA(KK)+JJ
                      NJL = IA(LL)+JJ
C
                      IF(UROHF) THEN
                      DUM = VAL4*(DA(NKL)+DB(NKL))
                      FA(NIJ) = FA(NIJ)+DUM
                      FB(NIJ) = FB(NIJ)+DUM
                      DUM = VAL4*(DA(NIJ)+DB(NIJ))
                      FA(NKL) = FA(NKL)+DUM
                      FB(NKL) = FB(NKL)+DUM
                      FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                      FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                      FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                      FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                      FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                      FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                      FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                      FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                      ELSE
                      FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                      FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                      FA(NIK) = FA(NIK)- VAL*DA(NJL)
                      FA(NIL) = FA(NIL)- VAL*DA(NJK)
                      FA(NJK) = FA(NJK)- VAL*DA(NIL)
                      FA(NJL) = FA(NJL)- VAL*DA(NIK)
                      ENDIF
C
                   ENDIF
                ELSE
                   IF(JJ.GT.NUMOLD) THEN
                      IF(KK.GT.NUMOLD) THEN
C
C     -------- II,JJ,KK > NUMOLD;  LL < NUMOLD --------
C
                         NIJ = IA(II)+JJ
                         NKL = IA(KK)+LL
                         NIK = IA(II)+KK
                         NIL = IA(II)+LL
                         NJK = IA(JJ)+KK
                         NJL = IA(JJ)+LL
                         IF(JJ.LT.KK) NJK = IA(KK)+JJ
C
                         IF(UROHF) THEN
                         DUM = VAL4*(DA(NKL)+DB(NKL))
                         FA(NIJ) = FA(NIJ)+DUM
                         FB(NIJ) = FB(NIJ)+DUM
                         DUM = VAL4*(DA(NIJ)+DB(NIJ))
                         FA(NKL) = FA(NKL)+DUM
                         FB(NKL) = FB(NKL)+DUM
                         FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                         FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                         FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                         FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                         FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                         FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                         FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                         FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                         ELSE
                         FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                         FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                         FA(NIK) = FA(NIK)- VAL*DA(NJL)
                         FA(NIL) = FA(NIL)- VAL*DA(NJK)
                         FA(NJK) = FA(NJK)- VAL*DA(NIL)
                         FA(NJL) = FA(NJL)- VAL*DA(NIK)
                         ENDIF
C
                      ELSE
C
C          -------- II,JJ > NUMOLD;  KK,LL < NUMOLD --------
C
                         NIJ = IA(II)+JJ
                         NKL = IA(KK)+LL
                         NIK = IA(II)+KK
                         NIL = IA(II)+LL
                         NJK = IA(JJ)+KK
                         NJL = IA(JJ)+LL
C
                         IF(UROHF) THEN
                         DUM = VAL4*(DA(NKL)+DB(NKL))
                         FA(NIJ) = FA(NIJ)+DUM
                         FB(NIJ) = FB(NIJ)+DUM
                         FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                         FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                         FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                         FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                         FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                         FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                         FA(NJL) = FA(NJL)-VAL2*DA(NIK)
                         FB(NJL) = FB(NJL)-VAL2*DB(NIK)
                         ELSE
                         FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                         FA(NIK) = FA(NIK)- VAL*DA(NJL)
                         FA(NIL) = FA(NIL)- VAL*DA(NJK)
                         FA(NJK) = FA(NJK)- VAL*DA(NIL)
                         FA(NJL) = FA(NJL)- VAL*DA(NIK)
                         ENDIF
C
                      ENDIF
                   ELSE
                      IF(KK.GT.NUMOLD) THEN
C
C          -------- II,KK > NUMOLD;  JJ,LL < NUMOLD --------
C
                         NIJ = IA(II)+JJ
                         NKL = IA(KK)+LL
                         NIK = IA(II)+KK
                         NIL = IA(II)+LL
                         NJL = IA(JJ)+LL
                         NJK = IA(KK)+JJ
                         IF(JJ.LT.LL) NJL = IA(LL)+JJ
C
                         IF(UROHF) THEN
                         DUM = VAL4*(DA(NKL)+DB(NKL))
                         FA(NIJ) = FA(NIJ)+DUM
                         FB(NIJ) = FB(NIJ)+DUM
                         DUM = VAL4*(DA(NIJ)+DB(NIJ))
                         FA(NKL) = FA(NKL)+DUM
                         FB(NKL) = FB(NKL)+DUM
                         FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                         FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                         FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                         FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                         FA(NJK) = FA(NJK)-VAL2*DA(NIL)
                         FB(NJK) = FB(NJK)-VAL2*DB(NIL)
                         ELSE
                         FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                         FA(NKL) = FA(NKL)+VAL4*DA(NIJ)
                         FA(NIK) = FA(NIK)- VAL*DA(NJL)
                         FA(NIL) = FA(NIL)- VAL*DA(NJK)
                         FA(NJK) = FA(NJK)- VAL*DA(NIL)
                         ENDIF
C
                      ELSE
C
C     -------- II > NUMOLD;  JJ,KK,LL < NUMOLD --------
C
                         NIJ = IA(II)+JJ
                         NKL = IA(KK)+LL
                         NIK = IA(II)+KK
                         NIL = IA(II)+LL
                         NJK = IA(JJ)+KK
                         NJL = IA(JJ)+LL
                         IF(JJ.LT.KK) NJK = IA(KK)+JJ
                         IF(JJ.LT.LL) NJL = IA(LL)+JJ
C
                         IF(UROHF) THEN
                         DUM = VAL4*(DA(NKL)+DB(NKL))
                         FA(NIJ) = FA(NIJ)+DUM
                         FB(NIJ) = FB(NIJ)+DUM
                         FA(NIK) = FA(NIK)-VAL2*DA(NJL)
                         FB(NIK) = FB(NIK)-VAL2*DB(NJL)
                         FA(NIL) = FA(NIL)-VAL2*DA(NJK)
                         FB(NIL) = FB(NIL)-VAL2*DB(NJK)
                         ELSE
                         FA(NIJ) = FA(NIJ)+VAL4*DA(NKL)
                         FA(NIK) = FA(NIK)- VAL*DA(NJL)
                         FA(NIL) = FA(NIL)- VAL*DA(NJK)
                         ENDIF
C
                      ENDIF
                   ENDIF
                ENDIF
C
 300         CONTINUE
 320      CONTINUE
 340   CONTINUE
 360  CONTINUE
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ADDKIN
      SUBROUTINE ADDKIN(T,LL2,NCTSTR,NCTEND)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION NINE
C
      LOGICAL IANDJ,NORM,DOUBLE,GOPARR,DSKWRK,MASWRK
C
      DIMENSION T(LL2)
      DIMENSION TBLK(225),VBLK(225),
     *          FT(225),DIJ(225),IJX(225),IJY(225),IJZ(225),
     *          XIN(125),YIN(125),ZIN(125),
     *          IX(35),IY(35),IZ(35),JX(35),JY(35),JZ(35)
C
      PARAMETER (MXSH=5000, MXGTOT=20000,MXATM=2000)
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /STV   / XINT,YINT,ZINT,TAA,X0,Y0,Z0,
     *                XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
      COMMON /SYMIND/ TOL,II,JJ,LIT,LJT,MINI,MINJ,MAXI,MAXJ,IANDJ
C
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00, ONE=1.0D+00, TWO=2.0D+00,
     *           THREE=3.0D+00, FIVE=5.0D+00, SEVEN=7.0D+00,
     *           NINE=9.0D+00, ELEVEN=11.0D+00,
     *           SQRT3=1.73205080756888D+00,
     *           SQRT5=2.23606797749979D+00, SQRT7=2.64575131106459D+00,
     *           RLN10=2.30258D+00)
C
      DATA JX / 0, 1, 0, 0, 2, 0, 0, 1, 1, 0,
     *          3, 0, 0, 2, 2, 1, 0, 1, 0, 1,
     *          4, 0, 0, 3, 3, 1, 0, 1, 0, 2,
     *          2, 0, 2, 1, 1/
      DATA IX / 1, 6, 1, 1,11, 1, 1, 6, 6, 1,
     *         16, 1, 1,11,11, 6, 1, 6, 1, 6,
     *         21, 1, 1,16,16, 6, 1, 6, 1,11,
     *         11, 1,11, 6, 6/
      DATA JY / 0, 0, 1, 0, 0, 2, 0, 1, 0, 1,
     *          0, 3, 0, 1, 0, 2, 2, 0, 1, 1,
     *          0, 4, 0, 1, 0, 3, 3, 0, 1, 2,
     *          0, 2, 1, 2, 1/
      DATA IY / 1, 1, 6, 1, 1,11, 1, 6, 1, 6,
     *          1,16, 1, 6, 1,11,11, 1, 6, 6,
     *          1,21, 1, 6, 1,16,16, 1, 6,11,
     *          1,11, 6,11, 6/
      DATA JZ / 0, 0, 0, 1, 0, 0, 2, 0, 1, 1,
     *          0, 0, 3, 0, 1, 0, 1, 2, 2, 1,
     *          0, 0, 4, 0, 1, 0, 1, 3, 3, 0,
     *          2, 2, 1, 1, 2/
      DATA IZ / 1, 1, 1, 6, 1, 1,11, 1, 6, 6,
     *          1, 1,16, 1, 6, 1, 6,11,11, 6,
     *          1, 1,21, 1, 6, 1, 6,16,16, 1,
     *         11,11, 6, 6,11/
C
C     -----    COMPUTE CONVENTIONAL T (KINETIC ENERGY) INTEGRALS
C     ----- MODIFIED HSTAND BY J. KORCHOWIEC FOR ELONGATION CUT-OFF
C
      TOL = RLN10*ITOL
      NORM = NORMF .NE. 1 .OR. NORMP .NE. 1
C
      ISTART = NCTSTR
      IEND   = NCTEND
      JSTART = 1
      LOCIJ  = 0
C
      CALL VCLR(T,1,LL2)
C
C     ----- INTIALIZE PARALLEL -----
C
      IPCOUNT = ME - 1
C
C     ----- I SHELL -----
C
      DO 720 II = ISTART,IEND
         I = KATOM(II)
         XI = C(1,I)
         YI = C(2,I)
         ZI = C(3,I)
         I1 = KSTART(II)
         I2 = I1+KNG(II)-1
         LIT = KTYPE(II)
         MINI = KMIN(II)
         MAXI = KMAX(II)
         LOCI = KLOC(II)-MINI-LOCIJ
C
C     ----- J SHELL -----
C
         DO 700 JJ = JSTART,II
C
C     ----- GO PARALLEL! -----
C
            IF (GOPARR) THEN
               IPCOUNT = IPCOUNT + 1
               IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 700
            END IF
            J = KATOM(JJ)
            XJ = C(1,J)
            YJ = C(2,J)
            ZJ = C(3,J)
            J1 = KSTART(JJ)
            J2 = J1+KNG(JJ)-1
            LJT = KTYPE(JJ)
            MINJ = KMIN(JJ)
            MAXJ = KMAX(JJ)
            LOCJ = KLOC(JJ)-MINJ-LOCIJ
            NROOTS = (LIT+LJT-2)/2+1
            RR = (XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
            IANDJ = II .EQ. JJ
C
C     ----- PREPARE INDICES FOR PAIRS OF (I,J) FUNCTIONS
C
            IJ = 0
            MAX = MAXJ
            DO 160 I = MINI,MAXI
               NX = IX(I)
               NY = IY(I)
               NZ = IZ(I)
               IF (IANDJ) MAX = I
               DO 140 J = MINJ,MAX
                  IJ = IJ+1
                  IJX(IJ) = NX+JX(J)
                  IJY(IJ) = NY+JY(J)
                  IJZ(IJ) = NZ+JZ(J)
                  IF (J.LE.1) FT(IJ) = THREE
                  IF ((J.GT.1).AND.(J.LE.4)) FT(IJ) = FIVE
                  IF ((J.GT.4).AND.(J.LE.10)) FT(IJ) = SEVEN
                  IF ((J.GT.10).AND.(J.LE.20)) FT(IJ) = NINE
                  IF (J.GT.20) FT(IJ) = ELEVEN
 140           CONTINUE
 160        CONTINUE
C
            CALL VCLR(TBLK,1,IJ)
            CALL VCLR(VBLK,1,IJ)
C
C     ----- I PRIMITIVE
C
            JGMAX = J2
            DO 520 IG = I1,I2
               AI = EX(IG)
               ARRI = AI*RR
               AXI = AI*XI
               AYI = AI*YI
               AZI = AI*ZI
               CSI = CS(IG)
               CPI = CP(IG)
               CDI = CD(IG)
               CFI = CF(IG)
               CGI = CG(IG)
C
C     ----- J PRIMITIVE
C
               IF (IANDJ) JGMAX = IG
               DO 500 JG = J1,JGMAX
                  AJ = EX(JG)
                  AA = AI+AJ
                  AA1 = ONE/AA
                  DUM = AJ*ARRI*AA1
                  IF (DUM .GT. TOL) GO TO 500
                  FAC = EXP(-DUM)
                  CSJ = CS(JG)
                  CPJ = CP(JG)
                  CDJ = CD(JG)
                  CFJ = CF(JG)
                  CGJ = CG(JG)
                  AX = (AXI+AJ*XJ)*AA1
                  AY = (AYI+AJ*YJ)*AA1
                  AZ = (AZI+AJ*ZJ)*AA1
C
C     ----- DENSITY FACTOR
C
C     THE ONLY REASON WHY -ILZ WORKS WITH THIS DENSITY THAT ASSUMES
C     HERMITICITY IS BECAUSE <I|-ILZ|I>=0 (MOMENTUM QUENCHING).
C
                  DOUBLE=IANDJ.AND.IG.NE.JG
                  MAX = MAXJ
                  NN = 0
                  DUM1 = ZERO
                  DUM2 = ZERO
                  DO 220 I = MINI,MAXI
                     IF (I.EQ.1) DUM1=CSI*FAC
                     IF (I.EQ.2) DUM1=CPI*FAC
                     IF (I.EQ.5) DUM1=CDI*FAC
                     IF ((I.EQ. 8).AND.NORM) DUM1=DUM1*SQRT3
                     IF (I.EQ.11) DUM1=CFI*FAC
                     IF ((I.EQ.14).AND.NORM) DUM1=DUM1*SQRT5
                     IF ((I.EQ.20).AND.NORM) DUM1=DUM1*SQRT3
                     IF (I.EQ.21) DUM1=CGI*FAC
                     IF ((I.EQ.24).AND.NORM) DUM1=DUM1*SQRT7
                     IF ((I.EQ.30).AND.NORM) DUM1=DUM1*SQRT5/SQRT3
                     IF ((I.EQ.33).AND.NORM) DUM1=DUM1*SQRT3
                     IF (IANDJ) MAX = I
                     DO 200 J = MINJ,MAX
                        IF (J.EQ.1) THEN
                           DUM2=DUM1*CSJ
                           IF (DOUBLE) THEN
                              IF (I.LE.1) THEN
                                 DUM2=DUM2+DUM2
                              ELSE
                                 DUM2=DUM2+CSI*CPJ*FAC
                              END IF
                           END IF
                        ELSE IF (J.EQ.2) THEN
                           DUM2=DUM1*CPJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF (J.EQ.5) THEN
                           DUM2=DUM1*CDJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.8).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        ELSE IF (J.EQ.11) THEN
                           DUM2=DUM1*CFJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.14).AND.NORM) THEN
                           DUM2=DUM2*SQRT5
                        ELSE IF ((J.EQ.20).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        ELSE IF (J.EQ.21) THEN
                           DUM2=DUM1*CGJ
                           IF (DOUBLE) DUM2=DUM2+DUM2
                        ELSE IF ((J.EQ.24).AND.NORM) THEN
                           DUM2=DUM2*SQRT7
                        ELSE IF ((J.EQ.30).AND.NORM) THEN
                           DUM2=DUM2*SQRT5/SQRT3
                        ELSE IF ((J.EQ.33).AND.NORM) THEN
                           DUM2=DUM2*SQRT3
                        END IF
                        NN = NN+1
                        DIJ(NN) = DUM2
  200                CONTINUE
 220              CONTINUE
C
C     ----- OVERLAP AND KINETIC ENERGY
C
                  TAA = SQRT(AA1)
                  T1 = -TWO*AJ*AJ*TAA
                  T2 = -PT5*TAA
                  X0 = AX
                  Y0 = AY
                  Z0 = AZ
                  IN = -5
                  DO 320 I = 1,LIT
                     IN = IN+5
                     NI = I
                     DO 300 J = 1,LJT
                        JN = IN+J
                        NJ = J
                        CALL STVINT
                        XIN(JN) = XINT*TAA
                        YIN(JN) = YINT*TAA
                        ZIN(JN) = ZINT*TAA
                        NJ = J+2
                        CALL STVINT
                        XIN(JN+25) = XINT*T1
                        YIN(JN+25) = YINT*T1
                        ZIN(JN+25) = ZINT*T1
                        NJ = J-2
                        IF (NJ .GT. 0) THEN
                           CALL STVINT
                        ELSE
                           XINT = ZERO
                           YINT = ZERO
                           ZINT = ZERO
                        END IF
                        N = (J-1)*(J-2)
                        DUM = N * T2
                        XIN(JN+50) = XINT*DUM
                        YIN(JN+50) = YINT*DUM
                        ZIN(JN+50) = ZINT*DUM
  300                CONTINUE
  320             CONTINUE
                  DO 340 I = 1,IJ
                     NX = IJX(I)
                     NY = IJY(I)
                     NZ = IJZ(I)
                     YZ = YIN(NY)*ZIN(NZ)
                     DUM = YZ*XIN(NX)
                     DUM1 = (XIN(NX+25)+XIN(NX+50))*YZ+
     *                      (YIN(NY+25)+YIN(NY+50))*XIN(NX)*ZIN(NZ)+
     *                      (ZIN(NZ+25)+ZIN(NZ+50))*XIN(NX)*YIN(NY)
                     TBLK(I) = TBLK(I) + DIJ(I)*(DUM*AJ*FT(I)+DUM1)
  340             CONTINUE
C
C     ----- END OF PRIMITIVE LOOPS -----
C
  500          CONTINUE
 520        CONTINUE
C
C     ----- COPY BLOCK INTO H-CORE, OVERLAP, AND KINETIC ENERGY MATRICES
C
            MAX = MAXJ
            NN = 0
            DO 620 I = MINI,MAXI
               LI = LOCI+I
               IN = (LI*(LI-1))/2
               IF (IANDJ) MAX = I
               DO 600 J = MINJ,MAX
                  LJ = LOCJ+J
                  JN = LJ+IN
                  NN = NN+1
                  T(JN) = TBLK(NN)
  600          CONTINUE
  620       CONTINUE
C
C     ----- END OF SHELL LOOPS -----
C
  700    CONTINUE
  720 CONTINUE
C
C     ----- SUM UP PARTIAL CONTRIBUTIONS IF PARALLEL -----
C
      IF (GOPARR) THEN
         CALL DDI_GSUMF(912,T,LL2)
      END IF
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK CTDONE
      SUBROUTINE CTDONE(LCUT)
C
      LOGICAL LCUT
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /ELGRST/ IRSTRT,I2EA,IGOOD
C
      CALL SEQREW(NEG1)
      READ(NEG1)
      READ(NEG1) IDMY,IDMY,NCUTX
      CALL SEQREW(NEG1)
C
      IF(NEG1.LT.0) THEN
         WRITE(6,*) 'STRICTLY TO FOOL FTNCHEK: IDMY=',IDMY
      END IF
C
      IF(NCUTX.NE.0) THEN
         LCUT = .TRUE.
         I2EA = 0
      ENDIF
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK CUTINF
      SUBROUTINE CUTINF
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000)
      LOGICAL LCUT
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /MASSES/ ZMASS(MXATM)
C
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /ELGPMT/ NELONG,NATM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /NEWPAR/ NUMNEW,NATNEW,NSHNEW,ISNEW
      COMMON /ELGIDX/ LCUT
C-----------------------------------------------------------------JGK
      IF(NELONG.LT.3) RETURN
      IF(NCT.LT.1) RETURN
      IF(.NOT.LCUT) RETURN
C
      NGS    = KSTART(NSHELL) + KNG(NSHELL) - 1
C
      NSHOLD = NSHELL
      NATOLD = NAT
      NUMOLD = NUM
      ISOLD  = IS
C
C
C SHELL INFORMATIONS CONCERNING CUT OFF PARTS ARE READ TO SHLINF
C              COMMON BLOCK STARTING FROM SHELL+1,
C
      CALL SEQREW(NEG4)
      READ(NEG4)
      READ(NEG4) NCTATM,NCTAO,NCTSHL,NCTELC,NCTGAS,NUMX
      READ(NEG4) (ZMASS(J),J=NAT+1,NAT+NCTATM)
      READ(NEG4) (ZAN(J),(C(I,J),I=1,3),J=NAT+1,NAT+NCTATM)
      READ(NEG4) (EX(I),CS(I),CP(I),CD(I),CF(I),CG(I),
     *     I = NGS+1,NGS+NCTGAS)
      READ(NEG4) (KATOM(I),KTYPE(I),KNG(I),KMIN(I),KMAX(I),
     *     I=NSHELL+1,NSHELL+NCTSHL)
C
      IF(NEG4.LT.0) THEN
         ISUM = NCTELC + NUMX
         WRITE(6,*) 'STRICTLY TO FOOL FTNCHEK: ISUM=',ISUM
      END IF
C
C     CONTENTS OF SOME OF THE MATRICES SHOULD BE CHANGED
C     EVERY CUT FRAGMENT WAS AT THE BEGINNING OF THE INPUT
C
      DO 10 I = NSHELL+1,NSHELL+NCTSHL
         KATOM(I) = KATOM(I) + NAT
         KLOC(I) = KLOC(I-1) + KMAX(I-1) - KMIN(I-1) + 1
         KSTART(I) = KSTART(I-1) + KNG(I-1)
 10   CONTINUE
C
      NSHNEW = NSHELL + NCTSHL
      NATNEW = NAT + NCTATM
      NUMNEW = NUM + NCTAO
      ISNEW  = NEG7
C
      DO 20 I = NSHOLD+1,NSHNEW
         MAPSHL(I,1) = I
 20   CONTINUE
C
      DO 30 I = NATOLD+1,NATNEW
         MAPCTR(I,1) = I
 30   CONTINUE
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK DIPCUT
      SUBROUTINE DIPCUT(D,NTOTAL,LFLD,FLVAL)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
      PARAMETER (DFAC=2.541766D+00)
      LOGICAL LFLD
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION D(NTOTAL)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
     *                IEDINT,IEMINT,IEPINT,IEFINT
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /XYZPRP/ XP,YP,ZP,
     *                DIPMX,DIPMY,DIPMZ,
     *                QXX,QYY,QZZ,QXY,QXZ,QYZ,
     *                QMXX,QMYY,QMZZ,QMXY,QMXZ,QMYZ,
     *                OXXX,OXXY,OXXZ,OXYY,OYYY,OYYZ,
     *                OXZZ,OYZZ,OZZZ,OXYZ,
     *                OMXXX,OMXXY,OMXXZ,OMXYY,OMYYY,
     *                OMYYZ,OMXZZ,OMYZZ,OMZZZ,OMXYZ
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /NEWPAR/ NUMNEW,NATNEW,NSHNEW,ISNEW
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /FLDCUT/ EFCUT(3),IGFLD
C
      DATA ELMOM/8HELMOM   /
C
      NSHELL = NSHNEW
      NUM = NUMNEW
      NAT = NATNEW
      CALL CALCOM(XC,YC,ZC)
      XP = XC
      YP = YC
      ZP = ZC
C
      L1 = NUM
      L2 = (L1*L1+L1)/2
C
      CALL VALFM (LOADFM)
      LX   = LOADFM + 1
      LY   = LX     + L2
      LZ   = LY     + L2
      LMW  = LZ     + L2
      LAST = LMW    + 225*3
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL VCLR(X(LX),1,L2)
      CALL VCLR(X(LY),1,L2)
      CALL VCLR(X(LZ),1,L2)
C
      IEMSV = IEMOM
      IEMOM = 1
      CALL PRCALC(ELMOM,X(LX),X(LMW),3,L2,.FALSE.)
      IEMOM = IEMSV
C
      DIPX=-TRACEP(D,X(LX),NUMNEW)
      DIPY=-TRACEP(D,X(LY),NUMNEW)
      DIPZ=-TRACEP(D,X(LZ),NUMNEW)
      IF(MASWRK) THEN
      WRITE(6,'(44(1H-))')
      WRITE(6,*) '  ELECTRONIC CONTRIBUTION TO DIPOLE MOMENT'
      WRITE(6,'(44(1H-))')
      WRITE(6,'(1X,3F20.10,'' A.U.'')') DIPX,DIPY,DIPZ
      WRITE(6,'(1X,3F20.10,'' DB'')') DIPX*DFAC,DIPY*DFAC,DIPZ*DFAC
      WRITE(6,*)
      END IF
C
      DO 10 I=1,NAT
         ZNUC = ZAN(I)
         XN = C(1,I) - XP
         YN = C(2,I) - YP
         ZN = C(3,I) - ZP
         DIPX = DIPX + ZNUC*XN
         DIPY = DIPY + ZNUC*YN
         DIPZ = DIPZ + ZNUC*ZN
 10   CONTINUE
      IF(MASWRK) THEN
      WRITE(6,*)
      WRITE(6,'(44(1H-))')
      WRITE(6,*) '            TOTAL DIPOLE MOMENT'
      WRITE(6,'(44(1H-))')
      WRITE(6,'(1X,3F20.10,'' A.U.'')') DIPX,DIPY,DIPZ
      WRITE(6,'(1X,3F20.10,'' DB'')') DIPX*DFAC,DIPY*DFAC,
     *     DIPZ*DFAC
      WRITE(6,'(44(1H-))')
      WRITE(6,*)
      END IF
C
      FLVAL = 0.0D+00
      IF(LFLD) THEN
         WRITE(6,*)'APPLIED FIELD:'
         WRITE(6,'(1X,3F18.10)') (EFCUT(I),I=1,3)
         DO 20 I =1,L2
            X(LX+I-1) = X(LX+I-1)*EFCUT(1) + X(LY+I-1)*EFCUT(2)
     *                + X(LZ+I-1)*EFCUT(3)
 20      CONTINUE
         FLVAL = TRACEP(D,X(LX),NUM)
C
         ANUCF = 0.00D+00
         DO 30 J = 1,NAT
            COMX = C(1,J) - XP
            COMY = C(2,J) - YP
            COMZ = C(3,J) - ZP
            ANUCF = ANUCF - EFCUT(1)*COMX*ZAN(J) - EFCUT(2)*COMY*ZAN(J)
     *           - EFCUT(3)*COMZ*ZAN(J)
 30      CONTINUE
         FLVAL = FLVAL + ANUCF
      ENDIF
C
      NSHELL = NSHOLD
      NUM = NUMOLD
      NAT = NATOLD
C
      CALL RETFM(NEED)
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ELGLAG
      SUBROUTINE ELGLAG(XL,XC,WRK,F,XF,L1,L2,NE)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION F(L2),XL(L2)
      DIMENSION XC(L1,L1),XF(L1,L1),WRK(L1,L1)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
C
C LAGRANGE MULTIPLERS FOR ELONGATION GEOMETRY OPTIMIZATION RUN
C
      L3 = L1 * L1
      CALL DAREAD(IDAF,IODA,XC,L3,15,0)
      CALL DAREAD(IDAF,IODA,F,L2,14,0)
      CALL CPYTSQ(F,XF,L1,1)
C
      NPAIR = NE/2
      DO 20 I=1,L1
         DO 20 J=1,L1
            X=0.0D+00
            DO 10 K=1,L1
               X = X + XC(K,I)*XF(K,J)
 10         CONTINUE
            WRK(I,J) = X
 20   CONTINUE
C
      II = 1
      DO 40 I=1,L1
         DO 40 J=1,I
            X=0.0D+00
            DO 30 K=1,L1
               X = X + WRK(I,K)*XC(K,J)
 30         CONTINUE
            F(II) = X
            II = II + 1
 40   CONTINUE
C
      CALL CPYTSQ(F,XF,L1,1)
C
      DO 60 I =1,L1
         DO 60 J =1,L1
            X=0.0D+00
            DO 50 K=1,NPAIR
               X = X + XC(I,K)*XF(K,J)
 50         CONTINUE
            WRK(I,J) = X
 60   CONTINUE
C
      II = 1
      DO 80 I=1,L1
         DO 80 J=1,I
            X=0.0D+00
            DO 70 K=1,NPAIR
               X = X - WRK(I,K)*XC(J,K)
 70         CONTINUE
            XL(II) = 2.0D+00*X
            II = II + 1
 80   CONTINUE
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK DENCUT
      SUBROUTINE DENCUT(D,D1,DTOT,NUMOLD,NFRGBS,NCUR,NRECT,NTOTAL)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXAO=8192)
      DIMENSION D(NCUR),D1(NRECT),DTOT(NTOTAL)
      COMMON /IJPAIR/ IA(MXAO)
C
      DO 10 I=1,NCUR
         DTOT(I) = D(I)
 10   CONTINUE
C
      KL = 0
      DO 20 I = 1,NFRGBS
         DO 20 J = 1,I
            KL = KL + 1
            IJ = IA(NUMOLD + I) + J + NUMOLD
            DTOT(IJ) = D1(KL)
 20   CONTINUE
C
      IJ = 0
      II = 1
      DO 30 I = KL+1,NRECT
         IJ = IJ + 1
         IF(MOD(IJ,(NFRGBS+1)).EQ.0) THEN
            IJ = 1
            II = II + 1
         ENDIF
         JJ = IA(NUMOLD + IJ) + II
         DTOT(JJ)  = D1(I)
 30   CONTINUE
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ENCUT2
      SUBROUTINE ENCUT2(NTOT,NFRGBS,NUMX,NCTATM,DTOTA,DTOTB,HTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000, MXAO=8192)
C
      LOGICAL PACK2E,SCHWZT,LFLD
      LOGICAL GOPARR,MASWRK,DSKWRK,DIRSCF,FDIFF
      CHARACTER*8 INAOFL
      DIMENSION DTOTA(NTOT*(NTOT+1)/2),HTOT(NTOT*(NTOT+1)/2)
      DIMENSION DTOTB(NTOT*(NTOT+1)/2)
      DOUBLE PRECISION NUCREP
      LOGICAL OUT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /NEWPAR/ NUMNEW,NATNEW,NSHNEW,ISNEW
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /ELGFIL/ NFILE,INAOFL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
C
      DATA UHF/8HUHF     /
      DATA FFIELD/8HFFIELD  /
C
      PARAMETER (HALF=0.5D+00)
C
      NTOTAL = NTOT*(NTOT + 1)/2
      NRECT1 = NFRGBS*(NFRGBS+1)/2 + NFRGBS*(NUMX-NFRGBS)
      NRECT2 = NFRGBS*(NFRGBS+1)/2 + NFRGBS*(NTOT-NFRGBS)
      NCURRT = NUM*(NUM+1)/2
      NSHELL = NSHNEW
C
      NREC   = 1
      INTLOC = 1
      ICOUNT = 1
      ISOLD  = IS
      ISNEW  = NEG8
      IS     = ISNEW
C
      IST = NSHOLD + 1
      JST = 1
      KST = 1
      LST = 1
C
      CALL SEQREW(IS)
      NSH2 = (NSHNEW*NSHNEW+NSHNEW)/2
      MXGSH=30
      MXG2=MXGSH*MXGSH
      CALL BASCHK(LMAX)
      NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      MAXG = NANGM**4
C
      LOADFM = 0
      CALL VALFM(LOADFM)
        LDA  = LOADFM +   1
        LDB  = LDA    +   NCURRT
        LH   = LDB    +   NCURRT
        LFA  = LH     +   NCURRT
        LFB  = LFA    +   NCURRT
        LD1A = LFB    +   NCURRT
        LD1B = LD1A   +   NRECT2
        LH1  = LD1B   +   NRECT2
        LFTA = LH1    +   NRECT2
        LFTB = LFTA   +   NTOTAL
        LH2  = LFTB   +   NTOTAL
        LAST = LH2    +   NTOTAL
C
        IF(.NOT.DIRSCF) THEN
           LBUFP  = LAST
           LBUFK  = LBUFP   +   NINTMX
           LIBUF  = LBUFK   +   NINTMX
           LXINTS = LIBUF   +   NINTMX
           LGHOND = LXINTS  +   NSH2
           LDDIJ  = LGHOND  +   MAXG
           LAST   = LDDIJ   +   16*MXG2
        ELSE
            LXINTS= LAST
            LGHOND= LXINTS + NSH2
            LDSH  = LGHOND + MAXG
            LDDIJ = LDSH   + NSH2
            LAST  = LDDIJ  + 16*MXG2
        ENDIF
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL VCLR(X(LDA),1,NEED)
C
      CALL SEQREW(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4)
      READ(NEG4) (X(LD1A+J),J=0,NRECT1-1)
      READ(NEG4) (X(LD1B+J),J=0,NRECT1-1)
C
      LFLD = .FALSE.
      IF(RUNTYP.EQ.FFIELD) THEN
         LFLD = .TRUE.
         CALL DAREAD(IDAF,IODA,X(LDA),NCURRT,11,0)
         CALL DAREAD(IDAF,IODA,X(LH),NCURRT,94,0)
         CALL VSUB(X(LH),1,X(LDA),1,X(LDA),1,NCURRT)
         CALL DAREAD(IDAF,IODA,X(LFA),NCURRT,14,0)
         CALL DAREAD(IDAF,IODA,X(LFB),NCURRT,18,0)
         CALL VSUB(X(LDA),1,X(LFA),1,X(LFA),1,NCURRT)
         CALL VSUB(X(LDA),1,X(LFB),1,X(LFB),1,NCURRT)
         CALL DAREAD(IDAF,IODA,X(LDA),NCURRT,16,0)
         CALL DAREAD(IDAF,IODA,X(LDB),NCURRT,20,0)
      ELSE
         CALL DAREAD(IDAF,IODA,X(LH),NCURRT,11,0)
         CALL DAREAD(IDAF,IODA,X(LFA),NCURRT,14,0)
         CALL DAREAD(IDAF,IODA,X(LFB),NCURRT,18,0)
         CALL DAREAD(IDAF,IODA,X(LDA),NCURRT,16,0)
         CALL DAREAD(IDAF,IODA,X(LDB),NCURRT,20,0)
      ENDIF
C
      CALL VCLR(HTOT,1,NTOTAL)
      CALL ADDONE(HTOT,1)
      CALL ADDKIN(X(LFTA),NTOTAL,NSHOLD+1,NSHNEW)
C
      CALL VADD(HTOT,1,X(LFTA),1,HTOT,1,NTOTAL)
      CALL VCLR(X(LFTA),1,NTOTAL)
C
      CALL DENCUT(X(LDA),X(LD1A),DTOTA,NUMOLD,NFRGBS,
     *     NCURRT,NRECT2,NTOTAL)
      CALL DENCUT(X(LDB),X(LD1B),DTOTB,NUMOLD,NFRGBS,
     *     NCURRT,NRECT2,NTOTAL)
C
      IF(DIRSCF) THEN
         DUMMY = 0.0D+00
         IDUMMY = 1
         NINT = 0
         NSCHWZ = 0
         SCHWZT = ISCHWZ.GT.0
         IST = NSHOLD + 1
         JST = 1
         KST = 1
         LST = 1
         NREC   = 1
         INTLOC = 1
         ICOUNT = 1
         IF(SCHWZT) THEN
            CALL SHLDEN(UHF,DTOTA,DTOTB,DUMMY,X(LDSH),
     *           IA,NTOT,NTOTAL,NSH2,1)
            CALL EXCHNG(X(LXINTS),X(LGHOND),X(LDDIJ),
     *                          NSH2,MAXG,INTTYP)
         ENDIF
         IF(MASWRK) WRITE(6,*) 'DIRECT SCF CALCULATION, SCHWRZ=',SCHWZT
C
         CALL ADDINT(UHF,DIRSCF,.FALSE.,.FALSE.,.FALSE.,
     *        SCHWZT,NINT,NSCHWZ,NCURRT,
     *        DUMMY,DUMMY,IDUMMY,1,
     *        X(LXINTS),NSH2,X(LGHOND),MAXG,
     *        IA,DTOTA,X(LFTA),DTOTB,X(LFTB),X(LDSH),
     *        .TRUE.,NTOT,NTOTAL,NTOTAL)
        IF(MASWRK)
     *  WRITE(6,*) NINT,' NON-ZERO INTEGRALS',NSCHWZ,' SKIPPED BLOCKS'
         CALL DSCAL(NTOTAL,0.5D+00,X(LFTA),1)
         CALL DSCAL(NTOTAL,0.5D+00,X(LFTB),1)
         II=LFTA-1
         JJ=LFTB-1
         DO 10 I=1,NTOT
            II = II+I
            JJ = JJ+I
            X(II) = X(II) + X(II)
            X(JJ) = X(JJ) + X(JJ)
 10      CONTINUE
      ELSE
C
         NFILE = 1
         INAOFL = 'EGINTB  '
         NEGX = NEG7
         NEG7 = NEG8
         NSHELL = NSHNEW
         NSCHWZ = 0
         SCHWZT = ISCHWZ.GT.0
         IST = NSHOLD + 1
         JST = 1
         KST = 1
         LST = 1
         NREC   = 1
         INTLOC = 1
         ICOUNT = 1
         IDUMMY=0
         DUMMY=0.0D+00
         IF(SCHWZT) CALL EXCHNG(X(LXINTS),X(LGHOND),X(LDDIJ),
     *        NSH2,MAXG,INTTYP)
C
         CALL ADDINT(UHF,.FALSE.,.FALSE.,.FALSE.,.FALSE.,
     *        SCHWZT,NINT,NSCHWZ,1,
     *        X(LBUFP),X(LBUFK),X(LIBUF),NINTMX,
     *        X(LXINTS),NSH2,X(LGHOND),MAXG,
     *        IDUMMY,DUMMY,DUMMY,DUMMY,DUMMY,DUMMY,
     *        .TRUE.,1,1,1)
         NEG7 = NEGX
C
         CALL ADDUHF(DTOTA,X(LFTA),DTOTB,X(LFTB),X(LBUFP),X(LIBUF),
     *        NINTMX,IA,NTOT)
      ENDIF
C
      DO 20 I=1,NCURRT
         X(LFTA+I-1) = X(LFA+I-1)-X(LH+I-1)
         X(LFTB+I-1) = X(LFB+I-1)-X(LH+I-1)
         HTOT(I) = X(LH+I-1)
 20   CONTINUE
C
      E1ASUM =      TRACEP(DTOTA,HTOT,NTOT)
      E1BSUM =      TRACEP(DTOTB,HTOT,NTOT)
      E2ASUM = HALF*TRACEP(DTOTA,X(LFTA),NTOT)
      E2BSUM = HALF*TRACEP(DTOTB,X(LFTB),NTOT)
      CALL VADD(X(LFTA),1,HTOT,1,X(LFTA),1,NTOTAL)
      CALL VADD(X(LFTB),1,HTOT,1,X(LFTB),1,NTOTAL)
C
      EAHF = TRACEP(DTOTA,X(LFTA),NTOT)
      EBHF = TRACEP(DTOTB,X(LFTB),NTOT)
      EHF  = EAHF + EBHF
      E1ESUM = E1ASUM + E1BSUM
      E2ESUM = E2ASUM + E2BSUM
      EHFSUM = HALF*(EHF + E1ESUM)
C
      EN = NUCREP(MXATM,NCTATM+NAT,ZAN,C)
C
      CALL VADD(DTOTA,1,DTOTB,1,DTOTA,1,NTOTAL)
      CALL DIPCUT(DTOTA,NTOTAL,LFLD,FLVAL)
C
      IF(MASWRK) THEN
      IF(LFLD) THEN
         WRITE(6,'(54(1H-))')
         WRITE(6,*) '    TOTAL ENERGY FOR CUT OFF FINITE FIELD RUN'
         WRITE(6,'(54(1H-))')
         WRITE(6,'(''ELONGATION ROHF/UHF TOTAL ENERGY: '',F20.12)')
     *        EHFSUM+EN+FLVAL
         WRITE(6,'(54(1H-))')
         WRITE(6,*)
      ELSE
         WRITE(6,'(54(1H-))')
         WRITE(6,*) '      TOTAL ENERGY INCLUDING CUT OFF FRAGMENT'
         WRITE(6,'(54(1H-))')
         WRITE(6,'(''    ELONGATION 1-ELECTRON ENERGY: '',F20.12)')
     *        E1ESUM
         WRITE(6,'(''    ELONGATION 2-ELECTRON ENERGY: '',F20.12)')
     *        E2ESUM
         WRITE(6,'(''  TOTAL NUCLEAR REPULSION ENERGY: '',F20.12)')
     *        EN
         WRITE(6,'(34X,20(1H-))')
         WRITE(6,'(''ELONGATION ROHF/UHF TOTAL ENERGY: '',F20.12)')
     *        EHFSUM+EN
         WRITE(6,*)
         WRITE(6,'(''  ELG ROHF/UHF ELECTRONIC ENERGY: '',F20.12)')
     *        EHFSUM
         WRITE(6,'(54(1H-))')
         WRITE(6,*)
      ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  FOR CUT-OFF PURPOSES,  WRITING ON TAPE FOR THE NEXT ELONGATION STEP,
C  THE TOTAL DENSITY MATRIX SHOULD BE REARRANGED SO IT WILL BE DONE NOW
C
      CALL VCLR(DTOTA,1,NTOTAL)
      CALL VCLR(DTOTB,1,NTOTAL)
      II = 0
      JJ = 0
      KK = 1
      DO 30 J = 1,NFRGBS + NUM
         DO 30 K = 1,J
            IF(K.LE.NFRGBS) THEN
               DTOTA(KK) = X(LD1A+II)
               DTOTB(KK) = X(LD1B+II)
               II = II + 1
               KK = KK + 1
            ELSE
               DTOTA(KK) = X(LDA + JJ)
               DTOTB(KK) = X(LDB + JJ)
               JJ = JJ + 1
               KK = KK + 1
            ENDIF
 30   CONTINUE
C-----------------------------------------------------------------------
      CALL RETFM(NEED)
      RETURN
      END
C
C*MODULE ELGSCF  *DECK MOELIN
      SUBROUTINE MOELIN(CW,CX,VEC,NUM,NAAO,JXX,NOCCA,NOCBM)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /ELGINF/ NNAAO,NCUTP,NCUT,NCUTT,NLATOT,NLBTOT,NLA,NLB,
     *     IMOCUT,IMOCUTT,NWA,NWM,NWMT,NHB
      DIMENSION CW(NWA,NWM),CX(NAAO,JXX)
      DIMENSION VEC(NUM,NUM)
C
      DO 10 I=1,NUM
         DO 10 J=1,NUM
 10   VEC(J,I) = 0.0D+00
C
      DO 20 I=1,JXX
         IF(I.LE.NOCCA) THEN
            II = I
         ELSE
            II = NOCBM + I
         ENDIF
         DO 20 J=1,NAAO
            VEC(J,II) = CX(J,I)
 20   CONTINUE
C
      DO 30 I=1,NWM
         IF(I.LE.NOCBM) THEN
            II = NOCCA + I
         ELSE
            II = JXX + I
         ENDIF
         DO 30 J=1,NWA
 30   VEC(J,II) = CW(J,I)
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK FRFELG
      SUBROUTINE FRFELG(A,NA)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL MOI,MOJ
      DIMENSION A(*)
      PARAMETER (ZERO=0.0D+00)
      COMMON /ELGFRF/ NOCC,NOCCA,NVACA
C
      IJ=1
      DO 20 I=1,NA
         MOI = .TRUE.
         IF(I.LE.NOCCA) MOI=.FALSE.
         IF(I.GT.NOCC.AND.I.LT.(NOCC+NVACA)) MOI=.FALSE.
         DO 20 J=1,I
            MOJ = .TRUE.
            IF(J.LE.NOCCA) MOJ=.FALSE.
            IF(J.GT.NOCC.AND.J.LE.(NOCC+NVACA)) MOJ=.FALSE.
            IF(MOI.AND.MOJ) GO TO 10
            IF(I.NE.J) A(IJ) = ZERO
 10         IJ = IJ + 1
 20    CONTINUE
      RETURN
      END
C
C*MODULE ELGSCF  *DECK SOELG
      SUBROUTINE SOELG(GRAD,NPR,ORBGRD,L0,NA,NOCC1,NVAC1)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION GRAD(NPR)
      PARAMETER (ZERO=0.0D+00)
C
C          GRAD   - ORBITAL GRADIENT
C          NPR    - NUMBER OF ROTATION PARAMETERS
C          ORBGRD - MAXIMUM ORBITAL GRADIENT COMPONENTA
C          L0     - NUMBER OF LINEARLY INDEPENDENT BASIS FUNCS (MO'S)
C          NA     - NUMBER OF OCCUPIED ORBITALS
C
      II=NOCC1*(L0-NA)
      DO 10 I=1,II
         GRAD(I)=ZERO
 10   CONTINUE
      K = 0
      DO 20 I=II+1,NA*(L0-NA)
         K=K+1
         IF(K.EQ.(L0-NA+1)) K = 1
         IF(K.LE.NVAC1) GRAD(I)=ZERO
 20   CONTINUE
C
      IMAX = IDAMAX(NPR,GRAD,1)
      ORBGRD = ABS(GRAD(IMAX))
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK SORELG
      SUBROUTINE SORELG(GRAD,NPR,ORBGRD,L0,NA,NB,NOCC1,NVAC1,
     *     NOCC1B,NVAC1B,NWAY)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION GRAD(NPR)
      PARAMETER (ZERO=0.0D+00)
C     ! SHOULD BE CHANGED IN FUTURE FOR HIGH SPIN CALCULATIONS
C     GRAD   - ORBITAL GRADIENT
C     NPR    - NUMBER OF ROTATION PARAMETERS
C     ORBGRD - MAXIMUM ORBITAL GRADIENT COMPONENTS
C     L0     - NUMBER OF LINEARLY INDEPENDENT BASIS FUNCS (MO'S)
C     NA     - NUMBER OF ALPHA OCCUPIED ORBITALS
C     NB     - NUMBER OF  BETA OCCUPIED ORBITALS
C     NOCC1  - NUMBER OF ALPHA OCCUPIED ORBITALS IN FROZEN PART
C     NOCC1B - NUMBER OF  BETA OCCUPIED ORBITALS IN FROZEN PART
C     NVAC1  - NUMBER OF ALPHA VIRTUAL  ORBITALS IN FROZEN PART
C     NVAC1B - NUMBER OF  BETA VIRTUAL  ORBITALS IN FROZEN PART
C     NWAY = 1 - ALPHA CASE;  NWAY = 2 - BETA CASE
C
      IF(NWAY.EQ.1) THEN
         IF(NOCC1.EQ.NOCC1B) THEN
C-----------------------------------------------------------------------
C     LOW SPIN CASE
C-----------------------------------------------------------------------
            II=NOCC1*(L0-NA)
            DO 10 I=1,II
               GRAD(I)=ZERO
 10         CONTINUE
            K = 0
            DO 20 I=II+1,NA*(L0-NA)
               K=K+1
               IF(K.EQ.(L0-NA+1)) K = 1
               IF(K.LE.NVAC1) GRAD(I)=ZERO
 20         CONTINUE
         ELSE
C-----------------------------------------------------------------------
C     HIGH SPIN CASE
C     SINGLE OCCUPIED MO OF FROZEN PART ARE SHIFTED
C     TO THE END OF OCCUPIED SPACE
C-----------------------------------------------------------------------
            II=NOCC1B*(L0-NA)
            DO 30 I=1,II
               GRAD(I)=ZERO
 30         CONTINUE
            KK=(NA-(NOCC1-NOCC1B))*(L0-NA)
            DO 40 I=KK+1,NPR
               GRAD(I)=ZERO
 40         CONTINUE
            K = 0
            DO 50 I=II+1,KK
               K=K+1
               IF(K.EQ.(L0-NA+1)) K = 1
               IF(K.LE.NVAC1) GRAD(I)=ZERO
 50         CONTINUE
         ENDIF
      ELSE
         IF(NOCC1.EQ.NOCC1B) THEN
C-----------------------------------------------------------------------
C     LOW SPIN CASE
C-----------------------------------------------------------------------
            II=NOCC1*(L0-NB)
            KK=NA-NB
            DO 60 I=1,II
               GRAD(I)=ZERO
 60         CONTINUE
            K = 0
            DO 70 I=II+1,NB*(L0-NB)
               K=K+1
               IF(K.EQ.(L0-NB+1)) K = 1
               IF(K.GT.KK.AND.K.LE.(NVAC1B+KK)) GRAD(I)=ZERO
 70         CONTINUE
         ELSE
C-----------------------------------------------------------------------
C     HIGH SPIN CASE
C     SINGLE OCCUPIED MO OF FROZEN PART ARE SHIFTED
C     TO THE END OF OCCUPIED SPACE
C-----------------------------------------------------------------------
            II=NOCC1B*(L0-NB)
            DO 80 I=1,II
               GRAD(I)=ZERO
 80         CONTINUE
            KK=NA-NB-NOCC1+NOCC1B
            K = 0
            DO 90 I=II+1,NB*(L0-NB)
               K=K+1
               IF(K.EQ.(L0-NB+1)) K = 1
               IF(K.GT.KK.AND.K.LE.(NVAC1B+KK)) GRAD(I)=ZERO
 90         CONTINUE
         ENDIF
      ENDIF
C
      IMAX   = IDAMAX(NPR,GRAD,1)
      ORBGRD = ABS(GRAD(IMAX))
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ADDINT
      SUBROUTINE ADDINT(TYPSCF,DIRSCF,DIRNLO,DIRTRF,DIRCIS,
     *                  SCHWRZ,NINT,NSCHWZ,L2,
     *                  BUFP,BUFK,IX,NINTMX,
     *                  XINTS,NSH2,GHONDO,MAXG,
     *                  IA,DA,FA,DB,FB,DSH,
     *                  ELGTOT,LL1,LL2,LL3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,DIRNLO,DIRTRF,DIRCIS,CMBDIR
      LOGICAL OUT,SCHWRZ,SCHSKP,GOPARR,DSKWRK,MASWRK,DLB,SLB,C1GRP
      LOGICAL SKIPA,SKIPB,SKIPC,NPSYM
      LOGICAL PK,PANDK,NOTPK,BLOCK,GPSAVE
      LOGICAL IINA,JINA,KINA,ELGTOT
      CHARACTER*8 INAOFL
C
      DIMENSION BUFP(NINTMX),BUFK(NINTMX),IX(*),XINTS(NSH2),
     *          GHONDO(MAXG),IA(LL1),DA(LL3),FA(LL2),DB(L2),FB(LL2),
     *          DSH(NSH2)
      DIMENSION MI(48),MJ(48),MK(48),M0(48)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000)
C
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PKFIL / PK,PANDK,BLOCK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /SHLEXC/ NORGSH(3),NORGSP(3),IEXCH,NANGM,NGTH(4)
      COMMON /SHLG70/ ISH,JSH,KSH,LSH,IJKLXX(4)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C-----------------------------------------------------------------JGK
C
C    ORIGINAL TWOEI SUBROUTINE CHANGED BY JACEK KORCHOWIEC
C       IT ALLOWS TO COMPUTE 2 ELECTRON INTERACTIONS
C      BETWEEN CUT OFF FRAGMENT AND THE CURRENT SYSTEM
C
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /ELGFIL/ NFILE,INAOFL
C-----------------------------------------------------------------JGK
C
      PARAMETER (ZERO=0.0D+00)
C
      DATA UHF,ROHF/8HUHF     ,8HROHF     /
C
C          ----- TWO-ELECTRON INTEGRALS -----
C     THIS VERSION CAN HANDLE S,P,D,F,G AND L SHELLS
C
      TIM = ZERO
      CALL TSECND(TIM)
C
      CMBDIR= DIRSCF .OR. DIRNLO .OR. DIRTRF .OR. DIRCIS
C
C        THE OLD FASHIONED PARALLEL INTEGRAL TRANSFORMATIONS DO NOT
C        ALLOW THE AO INTEGRAL WORK TO BE RUN IN PARALLEL.  THE MODERN
C        DISTRIBUTED MEMORY TRANSFORMATIONS DO NOT PASS THROUGH HERE.
C
      ICONT=  0
      GPSAVE = GOPARR
      IF(DIRTRF) GOPARR=.FALSE.
C
C     ----- INITIALIZATION FOR PARALLEL WORK -----
C     BOTH STATIC AND DYNAMIC LOAD BALANCING ARE IMPLEMENTED BELOW
C
      SLB = GOPARR  .AND.  IBTYP.EQ.0
      DLB = GOPARR  .AND.  IBTYP.EQ.1
      NEXT = -1
      MINE = -1
      IPCOUNT = ME - 1
C
      C1GRP = NT.EQ.1
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      NGTH(4) = 1
      NGTH(3) = NGTH(4) * NANGM
      NGTH(2) = NGTH(3) * NANGM
      NGTH(1) = NGTH(2) * NANGM
      IF(NOPK.EQ.0) THEN
         NORGSH(1) = 0
         NORGSH(2) = NORGSH(1) + NANGM**4
         NORGSH(3) = NORGSH(2) + NANGM**4
         NORGSP(1) = 0
         NORGSP(2) = 256
         NORGSP(3) = 512
      ELSE
         DO 10 I=1,3
            NORGSH(I) = 0
            NORGSP(I) = 0
 10      CONTINUE
      END IF
C
      NOTPK = .NOT.PK
      NINT  = 0
      NSCHWZ= 0
      SCHSKP=.FALSE.
      DENMAX = ZERO
C
C        NOW WE ARE READY TO LOOP OVER ALL NSHELL**4 SHELL QUARTETS
C
C     ----- I SHELL -----
C
      DO 920 II = IST,NSHELL
         IINA=.FALSE.
         IF(II.GT.NSHOLD) IINA=.TRUE.
C
C     ----- CHECK CPU TIME -----
C
      CALL TSECND(TIM)
      IF(TIM.GE.TIMLIM) THEN
C        SOMETHING MUST BE DONE FOR IN-CORE INTEGRALS
         IF(.NOT.CMBDIR)
     *      CALL FINAL(0,II,1,1,1,PANDK,BUFP,BUFK,IX,NINTMX)
         IF(MASWRK) WRITE(IW,9030)
         CALL ABRT
      END IF
C
C     ----- PRINT INTERMEDIATE RESTART DATA -----
C
      IF(NPRINT.NE.-5  .AND.  .NOT.CMBDIR .AND. MASWRK) THEN
         IF(ICOUNT.LE.NINTIC) THEN
            WRITE(IW,9015) II,JST,KST,LST,ICOUNT
         ELSE
            WRITE(IW,9010) II,JST,KST,LST,NREC,ICOUNT-NINTIC
         ENDIF
      ENDIF
C
C     ----- SKIP I SHELL IF NOT SYMMETRY UNIQUE -----
C     THIS, AND THE SIMILAR BRANCHINGS FOR THE J, K, AND L LOOPS IS
C     WHAT GENERATES THE "PETITE" RATHER THAN "GRANDE" INTEGRAL LIST.
C
      IF(C1GRP) THEN
         MI(1)=II
      ELSE
         DO 120 IT = 1,NT
            ID = MAPSHL(II,IT)
            IF (ID .GT. II) GO TO 920
            MI(IT) = ID
  120    CONTINUE
      END IF
C
C     ----- J SHELL -----
C
      J0 = JST
      DO 900 JJ = J0,II
      JST = 1
      JINA=.FALSE.
      IF(JJ.GT.NSHOLD) JINA=.TRUE.
C
      IF(C1GRP) THEN
         MJ(1)=JJ
      ELSE
         DO 200 IT = 1,NT
            ID = MI(IT)
            JD = MAPSHL(JJ,IT)
            MJ(IT) = JD
            IF (ID .GE. JD) GO TO 160
            ND = ID
            ID = JD
            JD = ND
  160       IF (ID-II) 200,180,900
  180       IF (JD-JJ) 200,200,900
  200    CONTINUE
      END IF
C
C     ----- GO PARALLEL! -----
C
      IF (DLB) THEN
         MINE = MINE + 1
         IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
         IF (NEXT.NE.MINE) GO TO 900
      END IF
C
C     ----- K SHELL -----
C
      K0 = KST
      DO 880 KK = K0,JJ
      KST = 1
      KINA=.FALSE.
      IF(KK.GT.NSHOLD) KINA=.TRUE.
C
      IF(C1GRP) THEN
         MK(1)=KK
      ELSE
         DO 340 IT = 1,NT
            ID = MI(IT)
            JD = MJ(IT)
            KD = MAPSHL(KK,IT)
            MK(IT) = KD
  240       IF (ID .GE. JD) GO TO 260
            ND = ID
            ID = JD
            JD = ND
  260       IF (JD .GE. KD) GO TO 280
            ND = JD
            JD = KD
            KD = ND
            GO TO 240
  280       IF (ID-II) 340,300,880
  300       IF (JD-JJ) 340,320,880
  320       IF (KD-KK) 340,340,880
  340    CONTINUE
      END IF
C
C     ----- GO PARALLEL! -----
C
      IF(SLB) THEN
         IPCOUNT = IPCOUNT + 1
         IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 880
      END IF
C
C     ----- L SHELL ----
C
      L0 = LST
      DO 860 LL = L0,KK
      LST = 1
C
C ----CHECKING TO AVOID COMPUTATION OF UNNEEDED INTEGRALS ----
C
      IF(DIRSCF) THEN
        IF(ELGTOT) THEN
         IF(.NOT.IINA) GOTO 860
        ELSE
         IF(IINA.AND.JINA.AND.KINA) GOTO 860
        ENDIF
      ELSE
        IF(ELGTOT) THEN
         IF(.NOT.(IINA.AND.JINA.AND.KINA) ) GOTO 860
        ELSE
         IF(IINA.AND.JINA.AND.KINA) GOTO 860
        ENDIF
      ENDIF
C
      IF(C1GRP) THEN
         M0(1)=1
         N4=1
      ELSE
         N4 = 0
         DO 540 IT = 1,NT
            ID = MI(IT)
            JD = MJ(IT)
            KD = MK(IT)
            LD = MAPSHL(LL,IT)
  380       IF (ID .GE. JD) GO TO 400
            ND = ID
            ID = JD
            JD = ND
  400       IF (JD .GE. KD) GO TO 420
            ND = JD
            JD = KD
            KD = ND
            GO TO 380
  420       IF (KD .GE. LD) GO TO 440
            ND = KD
            KD = LD
            LD = ND
            GO TO 400
  440       IF (ID-II) 540,460,860
  460       IF (JD-JJ) 540,480,860
  480       IF (KD-KK) 540,500,860
  500       IF (LD-LL) 540,520,860
  520       N4 = N4+1
            M0(N4) = IT
  540    CONTINUE
      END IF
C
C         THE LOOP STRUCTURE IN THIS ROUTINE IS DESIGNED TO FACILITATE
C         SUPERMATRIX CONSTRUCTION BY HAVING UP TO THREE "EXCHANGED"
C         QUARTETS AVAILABLE AT ONCE.  THE LOOP STRUCTURE TO GENERATE
C         A MORE NORMAL CANONICAL ORDERING OF THE QUARTETS HITS THE
C         SAME QUARTETS IN A SLIGHTLY DIFFERENT ORDER, BUT BOTH LOOPS
C         WILL DO EXACTLY THE SAME QUARTETS.
C
C             CANONICAL                      SUPERMATRIX
C         DO ISH=1,NSHELL                 DO II=1,NSHELL
C           DO JSH=1,ISH                    DO JJ=1,II
C             IJSH = IA(ISH)+JSH
C             DO KSH=1,ISH                    DO KK=1,JJ
C               DO LSH=1,KSH                    DO LL=1,JJ
C                 KLSH=IA(KSH)+LSH
C                 IF(IJSH.LT.KLSH),               [II JJ|KK LL],
C                    CYCLE KSH LOOP               [II KK|JJ LL],
C                 [ISH JSH|KSH LSH]               [II LL|JJ KK]
C               ENDDO                           ENDDO
C             ENDDO                           ENDDO
C           ENDDO                           ENDDO
C         ENDDO                           ENDDO
C
C     ----- CHECK FOR REDUNDANIES BETWEEN THE 3 COMBINATIONS -----
C            (II,JJ//KK,LL), (II,KK//JJ,LL), (II,LL//JJ,KK)
C
      SKIPA =  JJ.EQ.KK
      SKIPB = (II.EQ.KK) .OR. (JJ.EQ.LL)
      SKIPC = (II.EQ.JJ) .OR. (KK.EQ.LL)
      NPSYM = .FALSE.
      IF (SKIPA .OR. SKIPB .OR. SKIPC) GO TO 720
      NPSYM = .TRUE.
      DO 640 M = 1,N4
         IT = M0(M)
         IH = MI(IT)
         JH = MJ(IT)
         IF(JH.LE.IH) THEN
            ID = IH
            JD = JH
         ELSE
            ID = JH
            JD = IH
         END IF
         IF(.NOT.SKIPA) SKIPA = (ID.EQ.II .AND. JD.EQ.KK) .OR.
     *                          (ID.EQ.JJ .AND. JD.EQ.LL)
         IF(.NOT.SKIPB) SKIPB = (ID.EQ.II .AND. JD.EQ.LL) .OR.
     *                          (ID.EQ.JJ .AND. JD.EQ.KK)
         IF (SKIPA .AND. SKIPB) GO TO 660
         KH = MK(IT)
         IF(KH.LE.IH) THEN
            ID = IH
            KD = KH
         ELSE
            ID = KH
            KD = IH
         END IF
         IF(.NOT.SKIPC) SKIPC = (ID.EQ.II .AND. KD.EQ.LL) .OR.
     *                          (ID.EQ.JJ .AND. KD.EQ.KK)
         IF(SKIPA .AND. SKIPC) GO TO 680
         IF(SKIPB .AND. SKIPC) GO TO 700
  640 CONTINUE
      GO TO 720
C
  660 SKIPC = .TRUE.
      GO TO 720
  680 SKIPB = .TRUE.
      GO TO 720
  700 SKIPA = .TRUE.
C
C        GENERATE SYMMETRY FACTOR -Q4- FOR THIS QUARTET IN PETITE LIST
C
  720 CONTINUE
      Q4 = NT
      Q4 = Q4 / N4
C
C     ----- (II,JJ//KK,LL) -----
C
      IEXCH = 1
      ISH = II
      JSH = JJ
      KSH = KK
      LSH = LL
      QQ4 = Q4
      IF(SKIPA .AND. NPSYM) QQ4 = QQ4+Q4
      IF(SKIPB .AND. NPSYM) QQ4 = QQ4+Q4
      GO TO 780
C
C     ----- (II,KK//JJ,LL) -----
C
  740 IF (SKIPA) GO TO 760
      IEXCH = 2
      ISH = II
      JSH = KK
      KSH = JJ
      LSH = LL
      QQ4 = Q4
      IF (SKIPC .AND. NPSYM) QQ4 = QQ4+Q4
      GO TO 780
C
C     ----- (II,LL//JJ,KK) -----
C
  760 IF (SKIPB .OR. SKIPC) GO TO 840
      IEXCH = 3
      ISH = II
      JSH = LL
      KSH = JJ
      LSH = KK
      QQ4 = Q4
C
C        ----- COMPUTE TWO-ELECTRON INTEGRALS ----
C
  780 CONTINUE
      IF(PK .AND. IEXCH.EQ.1) CALL ZPKOUT(ISH,JSH,KSH,LSH,GHONDO,
     *                                    SKIPA,SKIPB,SKIPC,NPSYM)
C
C     APPLY THE SCHWARZ INEQUALITY TO SCREEN OUT SMALL INTEGRALS,
C      (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C     SEE, FOR EXAMPLE, J.L.WHITTEN, J.CHEM.PHYS. 58,4496-4501(1973)
C
      IF(SCHWRZ) THEN
         IJIJ = (ISH*ISH-ISH)/2 + JSH
         KLKL = (KSH*KSH-KSH)/2 + LSH
         TEST = QQ4*XINTS(IJIJ)*XINTS(KLKL)
         IF(DIRSCF) THEN
            DENMAX = SCHWDN(DSH,ISH,JSH,KSH,LSH,IA)
            TEST = TEST*DENMAX
         END IF
         SCHSKP = TEST.LT.CUTOFF
         IF(SCHSKP) NSCHWZ = NSCHWZ + 1
      END IF
      IF(SCHSKP) GO TO 820
C
C        ----- ELECTRON REPULSION INTEGRAL CALCULATION -----
C     THIS MAY USE ROTATED AXIS, ERIC, OR RYS QUADRATURE METHODS
C
      CALL SHELLQUART(ISH,JSH,KSH,LSH,GHONDO)
C
      IF(DIRSCF) THEN
         CALL ELGDIR(IA,DA,FA,DB,FB,GHONDO,NINT,ELGTOT)
      ELSE
         IF(NOTPK) CALL QOUT(BUFP,IX,NINTMX,GHONDO)
      END IF
C
  820 CONTINUE
      GO TO (740,760,840),IEXCH
C
C     ----- WRITE THE P (OR PK) SUPERMATRIX TO DISK FILE -----
C
  840 CONTINUE
      IF(PK) CALL PKFILE(II,JJ,KK,LL,SKIPA,SKIPB,SKIPC,NPSYM,
     *                   BUFP,BUFK,IX,NINTMX,GHONDO)
C
C     ----- END OF SHELL LOOPS -----
C
  860 CONTINUE
  880 CONTINUE
  900 CONTINUE
  920 CONTINUE
C
      IF(DLB) CALL DDI_DLBRESET
C
C     ----- OUTPUT THE LAST BITS OF INTEGRALS -----
C
      IF(DIRTRF) CALL ONEIDX(BUFP,IX,ICONT)
      IF(.NOT.CMBDIR) THEN
         IF(SCHWRZ) THEN
            IF(GOPARR) CALL DDI_GSUMI(1055,NSCHWZ,1)
            IF(NPRINT.NE.-5 .AND. MASWRK) WRITE(IW,9020) NSCHWZ
         END IF
         CALL FINAL(1,II,II,II,II,PANDK,BUFP,BUFK,IX,NINTMX)
      END IF
C
      GOPARR = GPSAVE
C
C----TO MAKE DIRECT SCF WITH CUTOFF FOR TOTAL ENERGY POSSIBLE-----MMK
        IF(GOPARR.AND.ELGTOT.AND.DIRSCF) THEN
          CALL DDI_GSUMF(2809,FA(1),LL2)
          IF(TYPSCF.EQ.UHF.OR.TYPSCF.EQ.ROHF) THEN
             CALL DDI_GSUMF(2810,FB(1),LL2)
          ENDIF
        END IF
C-----------------------------------------------------------------MMK
      IF(.NOT.DIRSCF) THEN
         NSHELL = NSHOLD
         NAT    = NATOLD
         NUM    = NUMOLD
         IF(NFILE.GT.1) THEN
            CALL SEQCLO(IS,'KEEP')
            CALL SEQOPN(IS,INAOFL(1:6),'UNKNOWN',.FALSE.,'UNFORMATTED')
            CALL SEQREW(IS)
         ENDIF
         IS     = ISOLD
      ENDIF
C
      RETURN
C
 9010 FORMAT(1X,'II,JST,KST,LST =',4I3,' NREC =',I10,' INTLOC =',I5)
 9015 FORMAT(1X,'II,JST,KST,LST =',4I3,' IN CORE, INTLOC =',I12)
 9020 FORMAT(1X,'SCHWARZ INEQUALITY TEST SKIPPED',I10,
     *        ' INTEGRAL BLOCKS.')
 9030 FORMAT(//1X,'*** THIS JOB HAS EXHAUSTED ITS CPU TIME ***'/
     *         1X,'     (WHILE COMPUTING 2E- INTEGRALS)'///)
      END
C*MODULE ELGSCF  *DECK DEBTCT
      SUBROUTINE DEBTCT(DIRSCF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DIRSCF,OUT,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000, MXAO=8192)
C
      COMMON /B     / CO(MXSH,3)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /NEWPAR/ NUMNEW,NATNEW,NSHNEW,ISNEW
C------------------------------------------------------------------
C     ----- INITIALIZE TWO ELECTRON INTEGRAL CALCULATION -----
C     ---  ORIGINAL DEBUT CHANGED FOR CUT-OFF CALCULATIONS ---
C------------------------------------------------------------------
C
      NSHELL = NSHNEW
      NAT    = NATNEW
      NUM    = NUMNEW
      IS     = ISNEW
C
      NREC   = 1
      INTLOC = 1
      ICOUNT = 1
C
      IF(DIRSCF) THEN
         IST = 1
         JST = 1
         KST = 1
         LST = 1
      ELSE
         IST = NSHOLD + 1
         JST = 1
         KST = 1
         LST = 1
      ENDIF
C
      CALL SEQREW(IS)
C
      IF(MASWRK) THEN
         WRITE(IW,*)' PARAMETERS BEFORE AND AFTER DEBTCT'
         WRITE(IW,*)'   |  NUM   | NSHELL |  NAT  |'
         WRITE(IW,'(3X,3(I7,2X))') NUMOLD,NSHOLD,NATOLD
         WRITE(IW,'(3X,3(I7,2X))') NUM,NSHELL,NAT
         WRITE(IW,*)
         WRITE(IW,*)'       STARTING SHELL INFORMATION'
         WRITE(IW,*)' IST=',IST,' JST=',JST,' KST=',KST,' LST=',LST
      END IF
C
      DO 10 I=NUMOLD+1,NUMNEW
         IA(I)=(I*I-I)/2
 10   CONTINUE
C
      DO 20 I=NSHOLD+1,NSHELL
         ICC = KATOM(I)
         CO(I,1)= C(1,ICC)
         CO(I,2)= C(2,ICC)
         CO(I,3)= C(3,ICC)
 20   CONTINUE
      CALL ERIPRE
      IF(DIRSCF) THEN
         IST = 1
         JST = 1
         KST = 1
         LST = 1
         IS = ISOLD
         NUM = NUMOLD
         NAT = NATOLD
      ENDIF
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK ELGINT
      SUBROUTINE ELGINT(IS,BUFP,IX,NINTMX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL OUT,LCUT,LTRMST
      CHARACTER*8 INAOFL
      DIMENSION BUFP(NINTMX),IX(*)
C
C            ROUTINE WRITTEN BY JACEK KORCHOWIEC
C     READS DATA FROM PREVIOUS ELONGATION STEP,
C     IT IS THE FILE WITH AO INTEGRALS,
C     AND PREPARE IT FOR THE CURRENT ELONGATION CALCULATIONS
C
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /ELGPMT/ NELONG,NATMM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      COMMON /ELGIDX/ LCUT
      COMMON /ELGRST/ IRSTRT,I2EA,IGOOD
      COMMON /ELGFIL/ NFILE,INAOFL
      COMMON /ELGTRM/ LTRMST,NFLTRM,NRCTRM,NPSTRM,NHTSHL
C
C TWO PARAMETERS FROM PREVIOUS RUN ARE REQUIRED FOR CUT OFF
C NSHLX - NSHELL FROM THE PREVIOUS ELONGATION STEP
C NDSHLX- START POINT OF THE SHELL FOR TERMINAL ATOMS
C
      LTRMST=.FALSE.
      IF(NELONG.LT.2) RETURN
      IF(NTMLB.GT.0) LTRMST=.TRUE.
      IF(NELONG.LT.3) RETURN
      IF(I2EA.NE.1) RETURN
      IF(LCUT) RETURN
C
      NSHLX = 0
      NSHCTX = 0
      CALL SEQREW(NEG1)
      READ(NEG1)
      READ(NEG1) NATOCX,NCTMOX,NCUTX,NCTAOX,KELGX,NSHLX,NDSHLX,
     *           NFLTRM,NRCTRM,NPSTRM
      CALL SEQREW(NEG1)
C
      IF(NEG1.LT.0) THEN
         ISUM = NATOCX + NCTMOX + NCUTX + NCTAOX + KELGX
         WRITE(6,*) 'STRICTLY TO FOOL FTNCHEK: ISUM=',ISUM
      END IF
C
      NFILE=NFLTRM
      IF(NFLTRM.GT.1) THEN
         CALL SEQCLO(IS,'KEEP')
         IF(NFILE.GT.9) THEN
            WRITE(INAOFL(7:8),'(I2)') NFILE
         ELSE
            WRITE(INAOFL(7:8),'(I1,'' '')') NFILE
         ENDIF
         CALL SEQOPN(IS,INAOFL,'UNKNOWN',.FALSE.,'UNFORMATTED')
      ENDIF
C
      CALL SEQREW(IS)
C
      INTLOC = NPSTRM
      ICOUNT = NPSTRM
      NREC = NRCTRM
      N = NRCTRM - 1
C
      CALL SEQREW(IS)
      DO 10 I=1,N
         READ(IS)
 10   CONTINUE
      CALL PREAD(IS,BUFP,IX,NXX,NINTMX)
      CALL SEQREW(IS)
      DO 20 I=1,N
         READ(IS)
 20   CONTINUE
C
      IF(NTMLB.EQ.0) THEN
         IST = NSHLX + 1 - NSHCTX
      ELSE
         IST = NDSHLX - NSHCTX
      ENDIF
      JST = 1
      KST = 1
      LST = 1
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK GESTST
      SUBROUTINE GESTST(CA,CB,C,CBM,CABM,ST,WRK,N,LL,NAAO,
     *                  JXX,JWW,NOCC1,NVAC1,NOCC2,NVAC2,NOCCM,NVACM,
     *                  NOCC,NWA,NWM,NHB)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION ST(LL),CA(NAAO,JXX),CB(NAAO,JWW),CBM(NWA,NWM),
     *          CABM(N,N),C(N,N),WRK(N)
C
C       WRITE(6,*)'N,LL,NAAO,JXX,JWW=',N,LL,NAAO,JXX,JWW
C       WRITE(6,*)'NOCC1,NVAC1,NOCC2,NVAC2,NOCCM,NVACM,NOCC,NHB='
C       WRITE(6,*) NOCC1,NVAC1,NOCC2,NVAC2,NOCCM,NVACM,NOCC,NHB
C
C      WRITE(6,*)'CA-MATRIX'
C      CALL WRITN4(JXX,NAAO,CA,JXX,NAAO)
C      WRITE(6,*)'CB-MATRIX'
C      CALL WRITN4(JWW,NAAO,CB,JWW,NAAO)
C
      CALL VCLR(CABM,1,N*N)
C
C   CABM STORES COEFFICIENTS FOR A, B, AND THEN M.
C
      DO I=1,NAAO-NHB
        DO J=1,NOCC1
         CABM(I,J) = CA(I,J)
        ENDDO
C
        DO J=1,NOCC2
         CABM(I,NOCC1+J) = CB(I,J)
        ENDDO
C
        DO J=1,NVAC1
         CABM(I,NOCC1+NOCC2+J) = CA(I,NOCC1+J)
        ENDDO
C
        DO J=1,NVAC2
         CABM(I,NOCC1+NVAC1+NOCC2+J) = CB(I,NOCC2+J)
        ENDDO
      ENDDO
C
      DO I=NAAO-NHB+1,N
       DO J=1,NOCCM
        IF(I.EQ.(JXX+JWW+J)) THEN
           CABM(I,JWW+JXX+J) = 1.0D+00
        ENDIF
       ENDDO
       DO J=1,NVACM
        IF(I.EQ.(JXX+JWW+NOCCM+J)) THEN
          CABM(I,JXX+JWW+NOCCM+J) = 1.0D+00
        ENDIF
       ENDDO
      ENDDO
C
C      WRITE(6,*)'CABM BEFORE ORTHOGONORMALIZATION'
C      CALL WRITN4(N,N,CABM,N,N)
C
C
C   CHECK ORTH-NORM
C
C       CALL CPYTSQ(ST,C,N,1)
C       WRITE(6,*)'BEFORE RE-ORTH,CHECK THE ORTH-NORM CA+B+M IN GESTST'
C       DO I=1,N
C       DO J=1,N
C        XXX = 0.0D+00
C         DO K=1,N
C         DO L=1,N
C          XXX = XXX + CABM(K,I)*C(K,L)*CABM(L,J)
C         ENDDO
C         ENDDO
C        IF(ABS(XXX).GT.1.0D-04)
C     *      WRITE(6,'(''I,J,XXX='',2I4,F12.8)')I,J,XXX
C       ENDDO
C       ENDDO
C
C
C
C ORTHOGONORMALIZE M TO A&B
C
       CALL NEWSCHMELG(CABM,ST,WRK,N,N,N,JXX+JWW)
C
C      WRITE(6,*)'CABM AFTER ORTHOGONORMALIZATION'
C      CALL WRITN4(N,N,CABM,N,N)
C
C  RE-ORDER CABM AND STORED IN C
C
      DO I=1,N
       DO J=1,NOCC1+NOCC2
        C(I,J) = CABM(I,J)
       ENDDO
       DO J=1,NOCCM
        C(I,NOCC1+NOCC2+J) = CABM(I,NOCC1+NOCC2+NVAC1+NVAC2+J)
       ENDDO
       DO J=1,NVAC1+NVAC2
        C(I,NOCC+J) = CABM(I,NOCC1+NOCC2+J)
       ENDDO
       DO J=1,NVACM
        C(I,NOCC+NVAC1+NVAC2+J) = CABM(I,NOCC+NVAC1+NVAC2+J)
       ENDDO
      ENDDO
C
      DO I=1,N
       DO J=1,NOCC2+NOCCM
        CBM(I,J) = C(I,NOCC1+J)
       ENDDO
       DO J=1,NVAC2+NVACM
        CBM(I,NOCC2+NOCCM+J) = C(I,NOCC+NVAC1+J)
       ENDDO
      ENDDO
C
C
C      WRITE(6,*)'CBM IN GESTST'
C      CALL WRITN4(NWM,NWA,CBM,NWM,NWA)
C
C   CHECK ORTH-NORM
C
      NCHK = 0
      IF(NCHK.EQ.1) THEN
       CALL CPYTSQ(ST,CABM,N,1)
       WRITE(6,*)'CHECK THE ORTH-NORM IN GESTST'
       DO I=1,N
       DO J=1,N
        XXX = 0.0D+00
         DO K=1,N
         DO L=1,N
          XXX = XXX + C(K,I)*CABM(K,L)*C(L,J)
         ENDDO
         ENDDO
       IF(ABS(XXX).GT.1.0D-04)WRITE(6,'(''I,J,XXX='',2I4,F12.8)')I,J,XXX
       ENDDO
       ENDDO
      ENDIF
C
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK GESOPT
      SUBROUTINE GESOPT(CA,C,CBM,CABM,ST,WRK,N,LL,NAAO,
     *                  JXX,NOCC1,NVAC1,NOCC2,NVAC2,NOCCM,NVACM,
     *                  NOCC,NWA,NWM,NHB)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION ST(LL),CA(NAAO,JXX),CBM(NWA,NWM),
     *          CABM(N,N),C(N,N),WRK(N)
C
C ORTHOGONORMALIZE FOR A
C
       CALL NEWSCHMELG(CA,ST,WRK,NAAO,JXX,NAAO,0)
C
C   CHECK ORTH-NORM
C
      NCHK = 0
      IF(NCHK.EQ.1) THEN
       CALL CPYTSQ(ST,CABM,N,1)
       WRITE(6,*)'CHECK THE ORTH-NORM IN GESOPT FOR OCC CA'
       DO I=1,JXX
       DO J=1,JXX
        XXX = 0.0D+00
         DO K=1,NAAO
         DO L=1,NAAO
          XXX = XXX + CA(K,I)*CABM(K,L)*CA(L,J)
         ENDDO
         ENDDO
       IF(ABS(XXX).GT.1.0D-07)WRITE(6,'(''I,J,XXX='',2I4,F12.8)')I,J,XXX
       ENDDO
       ENDDO
      ENDIF
C
      CALL VCLR(CABM,1,N*N)
C
C   CABM STORES COEFFICIENTS FOR A, B, AND THEN M.
C
      DO I=1,NAAO-NHB
        DO J=1,JXX
         CABM(I,J) = CA(I,J)
        ENDDO
      ENDDO
C
      DO I=1,N
        DO J=1,NOCC2+NOCCM
         CABM(I,JXX+J) = C(I,NOCC1+J)
        ENDDO
C
        DO J=NOCC+NVAC1+1,N
         CABM(I,J) = C(I,J)
        ENDDO
      ENDDO
C
C ORTHOGONORMALIZE (B+M) TO A
C
       CALL NEWSCHMELG(CABM,ST,WRK,N,N,N,JXX)
C
C  RE-ORDER CABM AND STORED IN C
C
      DO I=1,N
       DO J=1,NOCC1
        C(I,J) = CABM(I,J)
       ENDDO
       DO J=1,NOCC2+NOCCM
        C(I,NOCC1+J) = CABM(I,JXX+J)
       ENDDO
       DO J=1,NVAC1
        C(I,NOCC+J) = CABM(I,NOCC1+J)
       ENDDO
       DO J=NOCC+NVAC1+1,N
        C(I,J) = CABM(I,J)
       ENDDO
      ENDDO
C
      DO I=1,N
       DO J=1,NOCC2+NOCCM
        CBM(I,J) = C(I,NOCC1+J)
       ENDDO
       DO J=1,NVAC2+NVACM
        CBM(I,NOCC2+NOCCM+J) = C(I,NOCC+NVAC1+J)
       ENDDO
      ENDDO
C
C   CHECK ORTH-NORM
C
      NCHK = 0
      IF(NCHK.EQ.1) THEN
       CALL CPYTSQ(ST,CABM,N,1)
       WRITE(6,*)'CHECK THE ORTH-NORM IN GESOPT'
       DO I=1,N
       DO J=1,N
        XXX = 0.0D+00
         DO K=1,N
         DO L=1,N
          XXX = XXX + C(K,I)*CABM(K,L)*C(L,J)
         ENDDO
         ENDDO
       IF(ABS(XXX).GT.1.0D-04)WRITE(6,'(''I,J,XXX='',2I4,F12.8)')I,J,XXX
       ENDDO
       ENDDO
      ENDIF
C
C
      RETURN
      END
C
C*MODULE ELGSCF  *DECK RHFELG
      SUBROUTINE RHFELG
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PACK2E,OUT,SOME,PRDENS,DIRSCF,FDIFF,SCHWRZ,
     *        CVGED,CVGING,CVDENS,CVENGY,CVDIIS,
     *        CVGSVP,CVGSVPDN,CVGSVPDN1,CVGSVPNR,
     *        DODIIS,DAMPH,EXTRAH,VSHIFT,RSTRCT,RSTRSV,DEM,DEMOFF,
     *        NOTOPN,GOPARR,DSKWRK,MASWRK,TDSKWRK,MASPRT,
     *        ABINIT,MINMEM,VTSCAL,VIROK,LVCLN,IZRFLS,
     *        DOMBAS,SOSCF0,SOSCF,EIGAVL,FT15OP,MFRZ,IPCFP,
     *        QOPS,QFMM,SHLOUT,DIISON,ISGDDI,PAROUT,INITGDDI,
     *        NEEDTAU,PRTTAU,SG1
C
      DOUBLE PRECISION MOROKM
      CHARACTER*10 METHOD
C
      DIMENSION TIMSTR(3),NSBOX(20)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXGSH=30, MXG2=MXGSH*MXGSH,
     *           MXATM=2000, MXFRG=1050, MXAO=8192, MAXNFRAGS=10,
     *           MXCAV=5810, MXDFG=5, MXDPPT=MXFRG*MXDFG*12,
     *           MXGRID=10, MXRT=100)
      PARAMETER (NUMRA=23, NITDIR=10)
C
      COMMON /ACONV / RRSHFT,EXTTOL,DMPTOL,VSHTOL,IEXTIN
      COMMON /ATHEAT/ ATHEAT
      COMMON /CONV  / DENTOL,EN,ETOT,EHF,EHF0,DIFF,ITER,ICALP,ICBET
      COMMON /DEMOPT/ DEMCUT,IDEM
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,BSLRD(137),NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0,
     *                NANGPT(MXGRID),NANGPT0(MXGRID),SG1
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /DIISSO/ SOGTOL,ETHRSH,MAXDII,IRAF
      COMMON /DMPING/ SHIFTO,SHIFTV,DMPCUT,SWDIIS,DIRTHR
      COMMON /EFPBUF/ POLCHG(10),NBUFMO,LBUFF(MXAO),LBF,NAPOL,IAPOL(10)
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT1,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / X(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMOOPT/ ESPSCA(9),RESPAP(2),RESPPC(2),RESDIM,RESTRI(4),
     *                RCORSD,RESPCT,CONVFG,CNVDMP,COROFF,IXESP,MXITFG,
     *                NGUESS,NBSSE,MODORB,MODPAR,IRSTSTP,IRSTLAY,NPRFMO,
     *                NFMOPAL,MODPRP,MAXL1C,IPIEDA,MODGRD,MODESP,IVMUL
      COMMON /FMORUN/ ESPSCF,E0SCF(2),IDAFMO,ICURLAY,ICURFG,JCURFG,
     *                KCURFG,NCURSH,NGAU,ICURPOP,IFMOSTP,MONCOR,NAT1E,
     *                NEEDR,MODRST,NORBPROJ,NUNESP,ISKIPESP,ICURUNT
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /FUNCT / ENERGY,EGRAD(3,MXATM)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INDDIP/ TMUX,TMUY,TMUZ,TMUXD,TMUYD,TMUZD,MINMEM
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /METGGA/ NEEDTAU,PRTTAU
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
      COMMON /MIOPT / DTOLMI,CNVLOCMI,DIISTL,ALPHAMI,
     *                NF(MAXNFRAGS),MF(MAXNFRAGS),NFRAGS,MSHIFTMI,
     *                ITERMI,ITLOCMI,IGUESSMI,MXDIISMI,
     *                IOPTMI,MIFLAG,DIISON
      COMMON /MOLMEC/ HTYPE(4),NHCO(4,200),NNHCO,ITYPE
      COMMON /MPCGEO/ GEO(3,MXATM)
      COMMON /N2ELCT/ N2EL
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCMCHG/ PB,PX,PC,UNZ,QNUC,FN,FE,UNZOR,PORT
      COMMON /PCMDIM/ MXSP,MXTS,MEMPCM1,MEMPCM2,NTS
      COMMON /PCMITR/ RCUT(2),THRES,IPCMIT,IMUL,MXDIIS,NREG,MXITR1,
     *                MXITR2,MODPAP
      COMMON /PCMOPT/ RABI,RASC,REFPOL,THRSLS,DENSLS,WB,WA,ETA2,GD,EVAC,
     *                RHOW,PM,AREATL,AREAKP,BONDRY,OMEGA,RET,FRO,EPSINF,
     *                EPS,DR,RSOLV,VMOL,TCE,STEN,DSTEN,CMF,TABS,IDIRCT,
     *                IPCDER,IDP,ICOMP,IFIELD,ICAV,IDISP,IPRINT,IRETCAV,
     *                ICENT,IFAST,NEVAL,IEFPOL,KEEPSM,IMGABI,IMGASC,NADD
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IKREP,IEF,IP_F,NFMOPCM
      COMMON /PCMPNT/ LXYZRE,LSSFE,LLIST,LALPCM,LRINPCM,LINAPCM,LINFPCM,
     *                LINIPCM,LMEPCM,LAXYZCT,LXYZCT2,LNVERT,LQSN,LQSE,
     *                LQFS,LQIND,LISPHE,LVAD,LQOR,LVECMUL,LAIPRJ,LFIPRJ
     *                ,LPEL
      COMMON /PCMPRT/ GCAVP,GCAVS,GDISP,GREP,EHFGAS
      COMMON /QMFM  / SIZE,EPSLN,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /FMMDER/ MAXWS, NTBOX,NCXYZ, NTMPL,MAXNYP
      COMMON /QFMMRA/IORA(NUMRA),IQRAF,MIJKL
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,NPREO(4)
      COMMON /SCFWFN/ AROHF(3),BROHF(3),PACAVO(6),IACAVO,IUHFNO,MVOQ
      COMMON /SHLT  / SHLTOL,CUTOFF,ICOUNT,SHLOUT
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /SVPSCM/ IADDR_SVP,ILAST_SVP
      COMMON /SVPNRG/ ATMSVP,ELCSVP,SVPSVP,SURSVP,VOLPLM,VOLSVP,RXNSVP
      COMMON /SVPOPT/ ISVP,NSVP
      COMMON /SVPTGR/ NVLPL,MTHSVP,IQORP,NSTAGE,IOPPRD,IRENRM,ISHAPE,
     *                ITRCAV,NDRCAV,ICVICK,IFRQUP,IRDRF,IONSTR,
     *                INTCAV,NPTLEB,NPTTHE,NPTPHI,IROTGR,ITRNGR,
     *                ICRD,LINEQ,IPNRF,IPRRF,IPNDN,IPRDN,IEX
      COMMON /SVPPAR/ CAVC(3,MXCAV),CAVW(MXCAV),CAVQ(MXCAV),
     1                CAVN(3,MXCAV),SPHW(MXCAV),CAVP(MXCAV),
     2                CENCAV(3),RNTCAV(3),NCAV,IQP
      COMMON /VIRIAL/ SCALTE,SCALTT,GVIR,VTCONV,MAXVT,VTSCAL,VIROK,LVCLN
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /ZRFPAR/ GZRF,FIND(3),GNUCF,EBORN,DIELEC,IZRF,ICALC
C
C     COSMO INFORMATION
C
      PARAMETER (MAXDEN=25*MXATM, LENABC=2000, NPPA=1082)
      LOGICAL ISEPS, USEPS
      DIMENSION QVPOT(NPPA)
      COMMON /ISEPS / ISEPS, USEPS
      COMMON /SOLV  / FEPSI,RDS,DISEX2,COSURF(3,LENABC),SRAD(MXATM),
     *                QDEN(MAXDEN),AR(LENABC),
     *                NSPA,NPS,NPS2,NDEN,NPSPHER
      COMMON /SOLVI / IATSP(LENABC+1),N0(2),NP1,NP2,ISKIP
      COMMON /COSMO1/ SE2,SECORR,ETOTS,CDUM,QVCOSMO,
     *                CSPOT(NPPA),ICORR,ITRIPO,ITRIP2,ITRIP3,ITRIP4,
     *                NATCOS,NQS,ITERC
      COMMON /COSMO2/ QENUC,ELAST,EMP2COS,EMP2COS2,ETOTSMP,SAVESE,
     *                EMP2LAST,MP2TRIP,MP2ITER,MP2FACT
      COMMON /COSMO3/ COSZAN(NPPA),CORZAN(3,NPPA)
      COMMON /COSFRQ/ FCOORD(3,MXATM),POS0(NPPA),
     *                COSZAN0(NPPA),EDIEL0,FINDEX,ICFREQ,ICFREQ1
C
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00, ONE=1.0D+00, TWO=2.0D+00,
     *           FIVE=5.0D+00, TEN=1.0D+01, SMALL=1.0D-08,
     *           PT2=0.2D+00, TWOPT2=2.2D+00, DMPTLC=1.0D-02)
      PARAMETER (TOANGS=0.52917724924D+00,TOBOHR=ONE/TOANGS)
C
      SAVE FT15OP
C
      DATA FT15OP/.FALSE./
C
      DATA CHECK/8HCHECK   /, DEBUG/8HDEBUG   /, DBUGME/8HRHFCL   /
      DATA RHF/8HRHF     /
      DATA MOROKM/8HMOROKUMA/, HESS/8HHESSIAN /, OPTMZE/8HOPTIMIZE/
      DATA NONE,ANONE/4HNONE,8HNONE    /
      DATA COARSE,FINE/8HCOARSE  ,8HFINE    /
C-------------------------------------------------------------------FLGU
C  FENG LONG GU:  MODIFY GAMESS FOR ELONGATION : START - 0001       FLGU
C-------------------------------------------------------------------FLGU
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /ELGINF/ NAAO,NCUTP,NCUT,NCUTT,NLATOT,NLBTOT,NLA,NLB,
     *                IMOCUT,IMOCUTT,NWA,NWM,NWMT,NHB
      LOGICAL LCUT,ELGSO,OPTELG
      COMMON /ELGIDX/ LCUT
      COMMON /ELGOPT/ OPTELG
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /NEWPAR/ NUMNEW,NATNEW,NSHNEW,ISNEW
      COMMON /JTST/JXX,JWW,NOCC2,NVAC2,NOCCM,NVACM
      PARAMETER (MXSTP=500)
      DIMENSION NFZOC(MXSTP),NFZVT(MXSTP)
      DIMENSION NFZATM(MXSTP)
      ELGSO = .FALSE.
C-------------------------------------------------------------------FLGU
C  FENG LONG GU:  MODIFY GAMESS FOR ELONGATION :  END  - 0001       FLGU
C-------------------------------------------------------------------FLGU
C
C     ----- CLOSED SHELL HF-SCF CALCULATION -----
C     C.C.J.ROOTHAAN, REV.MOD.PHYS.  23,69-89(1951)
C
      ABINIT = MPCTYP.EQ.NONE
C
      METHOD='RHF       '
      IF(DFTYPE.NE.ANONE) WRITE(UNIT=METHOD,FMT='(''R-'',A8)') DFTYPE
      IF(MPCTYP.NE.NONE)
     *      WRITE(UNIT=METHOD,FMT='(''R-'',A4,''    '')') MPCTYP
      LENMTH = LSTRNG(METHOD,10)
C
C           POSSIBLE SCF-MI CALCULATION, WHICH IS DONE ELSEWHERE
C
      IF(MIFLAG.EQ.1) THEN
         CALL SCFMI
         RETURN
      END IF
C
      IZRFLS = IZRF.NE.0
C
C        SET UP THE CASE OF BOTH EFP AND PCM MODELS BEING USED TOGETHER
C
      IF(IPCM.EQ.1 .AND. IEFP.EQ.1) THEN
         IPCM=0
         IEFP=0
         IPCFP=.TRUE.
      ELSE
         IPCFP=.FALSE.
      END IF
C
      OUT    = .FALSE.
      SOME   = .FALSE.
      PRDENS = .FALSE.
      IF(MASWRK) THEN
        OUT    = NPRINT.EQ. 5 .OR. EXETYP.EQ.DEBUG .OR. EXETYP.EQ.DBUGME
        SOME   = NPRINT.NE.-5 .OR. EXETYP.EQ.DEBUG .OR. EXETYP.EQ.DBUGME
        PRDENS = NPRINT.GT. 8 .OR. EXETYP.EQ.DEBUG .OR. EXETYP.EQ.DBUGME
        OUT    = OUT .AND. NPRTGO.NE.2
        SOME   = SOME .AND. NPRTGO.NE.2
        PRDENS = PRDENS .AND. NPRTGO.NE.2
      END IF
      MASPRT = MASWRK  .AND.  NPRTGO.NE.2 .AND.
     *   (NFG.EQ.0.OR.IAND(NPRFMO,3).LE.1)
C
      IF(MASPRT.AND.(NFG.EQ.0.OR.NPRINT.NE.-5))
     *   WRITE(IW,9000) METHOD(1:LENMTH)
C
C     ----- START THE CLOCKS -----
C
      TIM0 = ZERO
      TIM1 = ZERO
      CALL TSECND(TIM0)
      TLEFTS = TIMLIM - TIM0
C
C     ----- SELECT CONVERGENCE PROCEDURES(S) -----
C
      EXTRAH = MOD(MCONV,2)  .EQ. 1
      DAMPH  = MOD(MCONV,4)  .GE. 2
      VSHIFT = MOD(MCONV,8)  .GE. 4
      RSTRCT = MOD(MCONV,16) .GE. 8
      DODIIS = MOD(MCONV,32) .GE.16
      DEM    = MOD(MCONV,64) .GE.32
      SOSCF0 = MOD(MCONV,128).GE.64
      RSTRSV = RSTRCT
C        IF WE ARE SWITCHING LATER, WE NEED TO ALLOCATE STORAGE FOR
C        THE SOSCF, BUT BE SURE SOSCF IS TURNED OFF BEFORE ITERS START.
      SOSCF  = SOSCF0 .OR.  SWDIIS.GT.0.0D+00
C
C     ----- SET POINTERS FOR PARTITIONING OF MEMORY -----
C
      IF(RUNTYP.EQ.MOROKM) THEN
         CALL STRHF(NUM,NA,NB,NE,NST,LL1,LL2,LL3,DOMBAS)
      ELSE
         NST = 1
         LL1 = NUM
         LL2 = (LL1*LL1+LL1)/2
         LL3 = LL1*LL1
         DOMBAS=.FALSE.
      END IF
C
      L0 = NQMT
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
C        FOR MOROKUMA RUNS, L1 MAY BE A SMALL PART OF MO SPACE
C
      IF(RUNTYP.EQ.MOROKM) L0 = MIN(NQMT,L1)
C
      MAXIT2=(MAXIT*MAXIT+MAXIT)/2
C
      NSH2 = (NSHELL*NSHELL+NSHELL)/2
C
      CALL VALFM(LOADFM)
      CALL GOTFM(NGOTMX)
      LSCR  = LOADFM + 1
      LIWRK = LSCR   + L1*8
      LWRK  = LIWRK  + L1
      LWRK1 = LWRK   + L1
      LWRK2 = LWRK1  + LL3
      LWRK3 = LWRK2  + LL3
      LEIG  = LWRK3  + LL3
      LOCC  = LEIG   + LL1
      LFAO  = LOCC   + L1
      LD    = LFAO   + LL2
      LVEC  = LD     + LL2
      LAST  = LVEC   + LL3
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      IF(LMAX.EQ.5) NANGM = 21
      IF(LMAX.EQ.6) NANGM = 28
      MAXG = NANGM**4
C
      MINTMX=NINTMX
      IF(NINTIC.NE.0) MINTMX=0
C     MEMORY IS ALLOCATED ELSEWHERE
CNB   FANCY OPTIONS (LOOK FOR NINTMX BELOW) WILL NOT WORK WITH
C     IN CORE INTEGRALS
C
      IF(ABINIT) THEN
         IF(DIRSCF) THEN
            LBUF  = LAST
            LIBUF = LAST
            LXINTS= LAST
            LGHOND= LXINTS + NSH2
            LDSH  = LGHOND + MAXG
            LDDIJ = LDSH   + NSH2
            LAST  = LDDIJ  + 49*MXG2
         ELSE
            LXINTS= LAST
            LGHOND= LAST
            LDSH  = LAST
            LDDIJ = LAST
            LBUF  = LAST
            LIBUF = LBUF   + MINTMX
            LAST  = LIBUF  + MINTMX
         END IF
         IF(NINTIC.NE.0) THEN
            LBUF  = LBUFPIC
            LIBUF = LIXIC
         END IF
         LTWOEI= LAST
         LPTOT2= LAST
      ELSE
         LXINTS= LAST
         LGHOND= LAST
         LDSH  = LAST
         LDDIJ = LAST
         LBUF  = LAST
         LIBUF = LAST
         LTWOEI= LAST
         LPTOT2= LTWOEI + N2EL
         LAST  = LPTOT2 + NAT*16
      END IF
C
      IF(DODIIS) THEN
         LADIIS = LAST
         LBDIIS = LADIIS + MAXDII*MAXDII
         LPDIIS = LBDIIS + MAXIT2
         LXDIIS = LPDIIS + MAXIT
         LIODII = LXDIIS + MAXIT
         LAST   = LIODII + 4*MAXDII
      ELSE
         LADIIS = LAST
         LBDIIS = LAST
         LPDIIS = LAST
         LXDIIS = LAST
         LIODII = LAST
      END IF
C
      IF(DEM) THEN
         LWRK4 = LAST
         LWRK5 = LWRK4 + L3
         LAST  = LWRK5 + L3
      ELSE
         LWRK4 = LAST
         LWRK5 = LAST
      END IF
C
C      EXTRA MEMORY FOR APPROXIMATE CORRELATION ADAPTED VIRTUAL ORBITALS
C
      IF(IACAVO.EQ.1) THEN
         LKCORE = LAST
         LKVAL  = LKCORE + L2
         LAST   = LKVAL  + L2
      ELSE
         LKCORE = LAST
         LKVAL  = LAST
      END IF
C
C     -- MEMORY FOR SOLVATION METHODS
C        THE ORDER MUST BE PCM, EFP, PCM/EFP.
C
      CALL PCMMEM3(IPCFP,L2,LAST,NTSPAR,LSOL,LCHG,LDMATM,LQPOT,LQFLD,
     *             LVPOT,LSE,LDE,LQ0,LQ1,LQ2,LQ3,LD0,LQA,LDIMAT,LQREP,
     *             LTMP0,LTMP1,LTMP2,LIPVT,LPOTTMP,LRMUL,LCHG2,
     *             LASCCRD,LASCCHG,LASCDIP,LASCQAD,LDISV,LDIS1,LDIS2,
     *             LCQEF,LQEFF,LELD,LXDINT,LYDINT,LZDINT,LEFLD,MADD,
     *             LABFLD,LVECMP,LVEC_2,LVEC_S,LAPROJ,LFPROJ)
C
      IF((IZRFLS .OR. IEFP.EQ.1 .OR. IPCFP)
     *    .AND. (DIRSCF.AND.FDIFF)) THEN
         NDIPER = LAST
         LDIPER = NDIPER  + L2
         LAST   = LDIPER  + L2
      ELSE
         NDIPER = LAST
         LDIPER = LAST
      END IF
C
C         MEMORY FOR SVP SOLVENT MODEL
C
      IF(ISVP.EQ.1) THEN
         NOPER=2
         IF(IQP.EQ.0.AND.MTHSVP.EQ.1) NOPER=1
         LENSVP=10*NCAV+NOPER*NCAV**2
         LSVP=LAST
         LAST=LSVP+LENSVP
      ELSE
         LSVP=LAST
         LENSVP=0
      END IF
C          AND A COUPLE OF INITIALIZATIONS FOR -SVP- MODEL
      IUPRXN = -1
      IF(ISVP.EQ.1) FDIFF=.FALSE.
C
C         FOR SOSCF CONVERGER
C
      NFT15=15
      NPR=(L0-NA)*NA
      ITSO=0
      ORBGRD=ZERO
      IF(SOSCF) THEN
         LGRAD  = LAST
         LHESS  = LGRAD  + NPR
         LPGRAD = LHESS  + NPR
         LDISPL = LPGRAD + NPR
         LAST   = LDISPL + NPR
      ELSE
         LGRAD  = LAST
         LHESS  = LAST
         LPGRAD = LAST
         LDISPL = LAST
      END IF
C
C     ----- FOR QFMM -----
C
      IF (QFMM) THEN
         CALL INITPRMT(NCXYZ,1)
         NSHL2=NSHELL*NSHELL
C
         IF (NCXYZ.LT.NUMRD) NUMRD=NCXYZ-1
C
         LCXYZ= LAST
         LIYP = LCXYZ    + NCXYZ*3
         LIBS = LIYP     + NCXYZ/NWDVAR+1
         LISP = LIBS     + NCXYZ*4/NWDVAR
         LIPP = LISP     + NCXYZ*2/NWDVAR
         LIDXWS = LIPP   + NCXYZ*2/NWDVAR
         LIDXIJK= LIDXWS + NCXYZ/NWDVAR+1
         LPTBL  = LIDXIJK+ NCXYZ*3/NWDVAR+2
         LYZTBL = LPTBL  + ((2**(NS+1)-1)**3+1)/NWDVAR+1
         LCLM   = LYZTBL + ((2**(NS+1)-1)**3+1)/NWDVAR+1
         LFLM   = LCLM   + 2*NP+1
         LPNTR  = LFLM   + 2*NP+1
         LG     = LPNTR  + 3*2**NS/NWDVAR+1
         LF     = LG     + 8*((NP*(NP+1)*(NP+2)*4/3)+(NP+1))
         LZLL   = LF     + 8*((NP*(NP+1)*(NP+2)*4/3)+(NP+1))
         LINDX  = LZLL   + (2*NP+2)*2
         LINDX2 = LINDX  + NCXYZ/NWDVAR+1
         LINDX3 = LINDX2 + NCXYZ/NWDVAR+1
         LDLIST = LINDX3 + NCXYZ/NWDVAR+1
         LSLIST = LDLIST + NSHL2/NWDVAR+1
         LDLN   = LSLIST + NSHL2/NWDVAR+1
         LSLN   = LDLN   + NSHELL/NWDVAR+2
         LMLIST   = LSLN   + NSHELL/NWDVAR+2
         LMLPNT = LMLIST + 4*NSHL2/NWDVAR+1
         LTS    = LMLPNT + 2*NSHELL/NWDVAR+1
         LMAXIJ = LTS    + NSHELL
         LIDXSHL= LMAXIJ + NSHELL
         LAST  = LIDXSHL+ NSH2/NWDVAR+2
      ELSE
         LCXYZ= LAST
         LIYP = LAST
         LIBS = LAST
         LISP = LAST
         LIPP = LAST
         LIDXWS = LAST
         LIDXIJK= LAST
         LPTBL  = LAST
         LYZTBL = LAST
         LCLM   = LAST
         LFLM   = LAST
         LPNTR  = LAST
         LG     = LAST
         LF     = LAST
         LZLL   = LAST
         LINDX  = LAST
         LINDX2 = LAST
         LINDX3 = LAST
         LDLIST = LAST
         LSLIST = LAST
         LDLN   = LAST
         LSLN   = LAST
         LMLIST = LAST
         LMLPNT = LAST
         LTS    = LAST
         LMAXIJ = LAST
         LIDXSHL= LAST
      END IF
C
C     ----- ADD IN GRID-BASED DFT MEMORY -----
C
C        ISWOFF=1 MEANS USE RHF UNTIL THE DENSITY GETS BELOW SWOFF,
C        THIS APPLIES ONLY TO THE VERY FIRST GEOMETRY IN THE RUN.
C
      ISWOFF=0
      IF(NDFTFG.EQ.1) THEN
         LFXC    = LAST
         IGRDDFT = LFXC + LL2
         CALL GRDDFT(LL2,NGRDMEM)
         LAST    = IGRDDFT + NGRDMEM
         IF((NEVALS.EQ.0 .OR. NFG.NE.0)  .AND.  SWOFF.NE.0) ISWOFF=1
      END IF
      HFSSAV=DFTTYP(3)
      NDFTSV=NDFTFG
      IDFTSWITCH=0
      ISWDIR=1
C     ISWDIR TELLS HOW MANY TIMES WE PERMIT TO RECOMPUTE THE FOCK MATRIX
C     USING DIRTHR.
C
C     ----- ADD IN GRID-FREE DFT MEMORY-----
C
      MEMDFT=LAST
      IF(DFTTYP(1) .NE. 0.0D+00) THEN
         CALL DFTMEM(IDFTMEM)
         LAST=LAST+IDFTMEM
         NEED  = LAST -LOADFM -1
      END IF
C
C        WE CAN REDUCE MEMORY NEED BY 2N**2 BY DOING MORE DAREADS,
C        TO OVERLAP -H1- AND -WRK1-, -Q- AND -WRK2-, -S- AND -WRK3-.
C        THERE ARE A NUMBER OF EXOTIC OPTIONS THAT DON'T ENSURE
C        THE OVERLAPPING WILL WORK PROPERLY, SO FORCE THEM INTO THE
C        SEPARATE ALLOCATION.
C
      NEED = LAST - LOADFM - 1
      NSAVE = 2*LL2 + LL3
      NEEDI = NEED + NSAVE
      IF((NEEDI.LT.NGOTMX)  .OR.
     * (DEM .OR. VSHIFT .OR. IZRFLS .OR.
     *  IPCFP. OR. IPCM.EQ.1 .OR. IEFP.EQ.1)) THEN
         MINMEM = .FALSE.
         LH1   = LAST
         LQ    = LH1    + LL2
         LS    = LQ     + LL3
         LAST  = LS     + LL2
         NEED  = LAST -LOADFM -1
      ELSE
         MINMEM = .TRUE.
         IF(SOME) WRITE(IW,9005) NSAVE
         LH1 = LWRK1
         LQ  = LWRK2
         LS  = LWRK3
      END IF
C-------------------------------------------------------------------FLGU
C  FENG LONG GU:  MODIFY GAMESS FOR ELONGATION : START - 0002       FLGU
C-------------------------------------------------------------------FLGU
         ELGSO=.TRUE.
C
         CALL SEQREW(NEG1)
         CALL SEQREW(NEG5)
         READ (NEG1) JXX,JWW,NAAO,NOCC1,NOCC2,NOCC1B,NOCC2B,MUL,NHB,NATX
         READ (NEG1) NATOC,NCTMO,NCUT,NCTAO,KELG,NSHELX,NDNSHL
         READ (NEG1) (NFZOC(I),I=1,KELG),(NFZVT(I),I=1,KELG)
         READ (NEG1) (NFZATM(I),I=1,KELG)
C
         IF(NCUT.NE.0) NOCUT = NFZOC(NCUT)
C
      IF(NEG1.LT.0) THEN
         ISUM = NOCUT + NFZVT(1) + NATX + NDNSHL + NFZATM(1)
     *        + NSHELX + NATOC
         WRITE(6,*) 'STRICTLY TO FOOL FTNCHEK: ISUM=',ISUM
      END IF
C
C     NUMBER OF MOS IN B+M REGION: NWM, LARGER THAN JWW
C     SO NEED SOME INITIAL GUESS MOS FOR M-REGION
C
         NWA = NUM
         NWM = NUM - JXX
         NWMT = NWM + JXX
         NOCC  = NE/2
         NOCCM = NOCC - NOCC1 - NOCC2
         NVACM = NWM - JWW - NOCCM
         NWM2 = NWM*NWM
         NOCBM = NOCC - NOCC1
         NVAC1  = JXX-NOCC1
         NVAC1B = JXX-NOCC1B
         NVAC2  = JWW-NOCC2
         NVAC2B = JWW-NOCC2B
         NTOT = NUM
         IF(NCTAO.NE.0) NTOT  = NUM + NCTMO
C
         IF(MASWRK) THEN
         WRITE(IW,'(40(1H-))')
         WRITE(IW,*)'   DOUBLY OCCUPIED MOLECULAR ORBITALS'
         WRITE(IW,'(40(1H-))')
         WRITE(IW,*)'                 ALPHA           BETA   '
         WRITE(IW,'(40(1H-))')
         WRITE(IW,'('' REGION A:'',8X,I4,11X,I4)') NOCC1,NOCC1B
         WRITE(IW,'('' REGION B:'',8X,I4,11X,I4)') NOCC2,NOCC2B
         WRITE(IW,'('' REGION M:'',8X,I4,11X,I4)') NOCCM,NOCCM
         WRITE(IW,'(40(1H-))')
         WRITE(IW,*)'        VACANT MOLECULAR ORBITALS'
         WRITE(IW,'(40(1H-))')
         WRITE(IW,'('' REGION A:'',8X,I4,11X,I4)') NVAC1,NVAC1B
         WRITE(IW,'('' REGION B:'',8X,I4,11X,I4)') NVAC2,NVAC2B
         WRITE(IW,'('' REGION M:'',8X,I4,11X,I4)') NVACM,NVACM
         WRITE(IW,'(40(1H-))')
         WRITE(IW,*)'          SUBSYSTEMS DIMENSIONS'
         WRITE(IW,'(40(1H-))')
         WRITE(IW,'('' FROZEN REGION   A: '',I6)') JXX
         WRITE(IW,'('' ACTIVE REGION B+M: '',I6)') NWM
         WRITE(IW,'(40(1H-))')
         ENDIF
C
C         FOR INITIAL GUESS ON M-PART
C
          MBF = NOCCM + NVACM
          MLL = MBF*(MBF+1)/2
          LHM = LAST
          LSM = LHM + MLL
          LS1 = LSM + MLL
          LS2 = LS1 + MBF*MBF
          LAST= LS2 + MBF*MBF
C
         LCXAL = LAST
         LCWAL = LCXAL   + JXX*NAAO ! A REGION CL
         LCBMA = LCWAL   + JWW*NAAO ! B REGION CL
         MFLMO = LCBMA   + NWM*NWA
         MVEC  = MFLMO   + NWM2
         MEIG  = MVEC    + NWM*NWM
         MJBIG = MEIG    + NWM
         MBIG  = MJBIG   + 8*NWM
         MWRK1 = MBIG    + NWM
         MTMP  = MWRK1   + NWA
         LAST  = MTMP    + NTOT*NTOT ! FOR ALL-REGION D-MAT
C----------------------------------------------------------JGK
C                     FOR AO-CUT
C----------------------------------------------------------JGK
         IF(LCUT) THEN
            CALL SEQREW(NEG4)
            READ(NEG4)
            READ(NEG4) NCTATM,NCTAOX,I,I,I,NUMX
C
            IF(NEG4.LT.0) THEN
               WRITE(6,*) 'STRICTLY TO FOOL FTNCHEK: NCTATM=',NCTATM
            END IF
C
            NFRGSH = NUMX - NCTAOX
            NFRGBS = NUMNEW-NUMOLD
            NDIM1 =  NFRGBS*(NFRGBS+1)/2 + NFRGBS*NFRGSH
            NDIM2 =  NFRGBS*(NFRGBS+1)/2 + NFRGBS*NUM
            NTOT  =  NUMNEW
            NTOTAL = NTOT*(NTOT+1)/2
C
            NDOFF = NAAO*(NAAO+1)/2
C
            LD1    = LAST
            LDOFF  = LD1   + NDIM2
            LDTOT  = LDOFF + NAAO*(NAAO+1)/2
            LAST   = LDTOT + NTOTAL
C
            IF(DIRSCF) THEN
               LDTWRK = LAST
               LAST   = LDTWRK + NTOTAL
            ENDIF
C
            CALL VCLR(X(LD1),1,NDIM2)
            CALL VCLR(X(LDOFF),1,NAAO*(NAAO+1)/2)
            CALL VCLR(X(LDTOT),1,NTOTAL)
C
            READ(NEG4)
            READ(NEG4)
            READ(NEG4)
            READ(NEG4)
            READ(NEG4) (X(LD1+J),J=0,NDIM1-1)
      ENDIF
C----------------------------------------------------------JGK
         NEED  = LAST -LOADFM -1
C
            CALL SEQREW(NEG5)
            READ(NEG5) (X(LCXAL+ID-1),ID=1,JXX*NAAO)
            READ(NEG5) (X(LCWAL+ID-1),ID=1,JWW*NAAO)
            IF(LCUT) THEN
               READ(NEG5)
               READ(NEG5) (X(LDOFF+I-1),I=1,NFRGSH*(NFRGSH+1)/2)
            ENDIF
            CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
C-------------------------------------------------------------------FLGU
C  FENG LONG GU:  MODIFY GAMESS FOR ELONGATION :  END  - 0002       FLGU
C-------------------------------------------------------------------FLGU
C
C     ----- GET MEMORY -----
C
      CALL GETFM(NEED)
C
C     ----- INITIALIZE OCCUPATION NUMBERS -----
C
      CALL VCLR(X(LOCC),1,L1)
      DO 120 I = NST,NA+NST-1
         X(LOCC-1+I) = TWO
  120 CONTINUE
C
C     ----- INITIALIZE VARIABLES -----
C
      NOTOPN = .TRUE.
      IF(MAXIT.LE.0) MAXIT = 30
C
C        LOOSEN CONVERGENCE FOR DIRECT SCF BY JUST A BIT
C        AT THE BEGINNING OF GEOMETRY OPTS, WE CAN BE A BIT COARSER
C
      IF(DIRSCF) THEN
         DENTOL = TWO * CONVHF
         ENGTOL = 1.0D-08
         DIITOL = 1.0D-06
      ELSE
         DENTOL = CONVHF
         ENGTOL = 1.0D-09
         DIITOL = 1.0D-07
      END IF
      IF(NDFTFG.NE.1) THEN
C        SW0=ZERO
C        CREATES PROBLEMS IN FMO WHEN MIXING RHF AND DFT.
      ELSE
C        IF(SW0.LT.CONVHF.AND.SW0.NE.0) THEN
         IF(SW0.LT.CONVHF) THEN
            IF(MASWRK) WRITE(IW,9006) SW0,CONVHF
            CALL ABRT
         END IF
      END IF
      SWDFT = SW0
      IF(NDFTFG.NE.1) SWDFT=ZERO
      IF(RUNTYP.EQ.OPTMZE  .AND.  NEVALS.GT.0.AND.NFG.EQ.0) THEN
         GRMS = DDOT(3*NAT,EGRAD,1,EGRAD,1)
         GRMS = SQRT(GRMS/(3*NAT))
                               CFACT =  1.0D+00
         IF(GRMS.GT.0.005D+00) CFACT =  5.0D+00
         IF(GRMS.GT.0.020D+00) CFACT = 20.0D+00
         IF(GRMS.GT.0.100D+00) CFACT = 50.0D+00
         DENTOL = CFACT*DENTOL
         ENGTOL = CFACT*ENGTOL
         DIITOL = CFACT*ENGTOL
         SWDFT  = CFACT*SWDFT
      END IF
      DTOL2 = TWO * DENTOL
      ETOL2 = TEN * ENGTOL
      CVDIIS = .FALSE.
      CVGING = .FALSE.
      CVGED  = .FALSE.
C
C     CVGSVP KEEPS TRACK OF WHETHER SVP CHARGES/DIPOLES APPEAR CONVERGED
C
      CVGSVP    = .FALSE.
      CVGSVPDN  = .FALSE.
      CVGSVPDN1 = .FALSE.
      CVGSVPNR  = .FALSE.
C
      ICCFLG=0
      ITDIIS = 1
      MPUNCH = NPUNCH
      EHF = ZERO
      ETOT= ZERO
      EEXC= ZERO
      EDHF1=ZERO
      ITERV= 0
      ICALP = 0
      DAMP = ZERO
      DAMP0 = ZERO
      IF(DMPCUT .LE. ZERO) DMPCUT = ZERO
      RRSHFT = ZERO
      ERDIIS=ZERO
      DIFF = ZERO
      DIFFP= ZERO
      DELE = ZERO
      DEAVG = ZERO
      NDAF = 15
      NDAFD = 23
      IF(DAMPH .OR. VSHIFT) DAMP = ONE
      NUMDEM = 0
C
      II = 0
      DO 140 I = 1,L1
         IA(I) = II
         II = II + I
  140 CONTINUE
C
C     ----- INITIALIZE -SVP- MODEL -----
C
      IF(ISVP.EQ.1) THEN
         IADDR_SVP=LSVP
         ILAST_SVP=LSVP+LENSVP-1
         CALL SVPSET
      END IF
C
C        MOPAC HAS A MOLECULAR MECHANICS PEPTIDE BOND CORRECTION
C
      EHNCO = ZERO
      IF(MPCTYP.NE.NONE) THEN
         DO I=1,NNHCO
            CALL DIHED(GEO,NHCO(1,I),NHCO(2,I),
     *                     NHCO(3,I),NHCO(4,I),ANGLE,SIGNA)
            SINANG = SIN(ANGLE)
            EHNCO = EHNCO + HTYPE(ITYPE)*SINANG*SINANG
         ENDDO
         EHNCO = EHNCO/627.52791D+00
      END IF
C
C --  C. AMOVILLI AND B. MENNUCCI
C     PCM CALCULATION OF DISPERSION INTERACTION
C     THREE STEPS PROCEDURE:
C      1) IN VACUO CALCULATION
C      2) SOLUTE AVERAGE TRANSITION FREQUENCY
C      3) ADDITION OF SOLVENT INTERACTION MATRICES:
C         ELECTROSTATIC + DISPERSION (+ REPULSION IF IRPCM=1)
C
C      PCM STEP 1) IN VACUO CALCULATION
C
      ISD=1
      IF(IPCM.EQ.1  .AND.  IDP.EQ.1) THEN
        EN=EN-UNZ
        ISD=0
      END IF
      WA = ZERO
C
C        READ INVERSE D MATRIX FOR PCM (SKIP FOR ITERATIVE SOLVER)
C
      IF(IPCMIT.EQ.0  .AND.  (IPCM.EQ.1 .OR. IPCFP)) THEN
         NTS3 = NTS*NTS
         CALL SEQREW(NFT26)
         CALL DERCHK(NDER)
         IF(NDER.EQ.1.AND.IPCDER.EQ.1) THEN
            CALL SEQADV(NFT26)
            CALL SEQADV(NFT26)
            CALL SEQADV(NFT26)
            CALL SEQADV(NFT26)
         END IF
         IF(IEF.GT.0.AND.IEF.LT.3) THEN
            CALL SEQADV(NFT26)
            CALL SEQADV(NFT26)
            CALL SQREAD(NFT26,X(LSE),NTS3)
            CALL SQREAD(NFT26,X(LDE),NTS3)
         END IF
         CALL SQREAD(NFT26,X(LDMATM),NTS3)
         CALL SEQREW(NFT26)
      END IF
C
C     PCM STEP 3) ADDITION OF SOLVENT INTERACTION MATRICES:
C
  333 CONTINUE
      IF(IPCM.EQ.1 .AND. IDP.EQ.1 .AND. ISD.EQ.1) THEN
         EN=EN+UNZ
         IF(SOME) WRITE(IW,9007) UNZ,EN
         IF(SOME) WRITE(IW,*)
         IF(DIRSCF  .AND.  FDIFF) THEN
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
            CALL DAWRIT(IDAF,IODA,X(LH1),LL2,14,0)
            CALL VCLR(X(LWRK1),1,L2)
         END IF
         GO TO 101
      END IF
C
C     ----- PRINT SCF OPTIONS -----
C
      IF(MASPRT.AND.(NFG.EQ.0.OR.NPRINT.NE.-5)) THEN
         IF(SOME) WRITE(IW,9010) EN,MAXIT,MPUNCH,EXTRAH,DAMPH,
     *                  VSHIFT,RSTRCT,DODIIS,DEM,SOSCF
         IF(NDFTFG.NE.1) THEN
            WRITE(IW,9012) DENTOL
         ELSE
            WRITE(IW,9013) DENTOL,SWDFT,SWOFF
         END IF
         IF(SOME  .AND.  VTSCAL) WRITE(IW,9015) VTSCAL,MAXVT,VTCONV
         IF(SOME  .AND.  SOSCF) WRITE(IW,9017) NPR,SOGTOL
         IF(SOME) WRITE(IW,9020) NEED
      END IF
C
C     ----- EXCHANGE INTEGRALS FOR DIRECT SCF THRESHOLD TESTS -----
C
      NINT=0
      NSCHWZ=0
      IF(DIRSCF.AND.ABINIT) THEN
         SCHWRZ = ISCHWZ.GT.0
         IF(MASPRT) WRITE(IW,9030) SCHWRZ,FDIFF,DIRTHR,NITDIR
         IF(SCHWRZ) CALL EXCHNG(X(LXINTS),X(LGHOND),X(LDDIJ),
     *                          NSH2,MAXG,INTTYP)
      ELSE
         SCHWRZ=.FALSE.
      END IF
C
C     ----- READ IN MOPAC 2-ELECTRON INTEGRALS -----
C
      IF(MPCTYP.NE.NONE  .AND.  N2EL.GT.0)
     *    CALL DAREAD(IDAF,IODA,X(LTWOEI),N2EL,53,0)
C
C     ----- READ BARE NUCLEUS HAMILTONIAN -----
C     ----- READ OVERLAP INTEGRALS -----
C     ----- READ INITIAL DENSITY MATRIX -----
C     ----- READ SYMMETRY ADAPTED Q MATRIX -----
C     L0 = NUMBER OF CANONICAL ORTHONORMAL VECTORS KEPT.
C
      IF(.NOT.MINMEM) THEN
         CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
         CALL DAREAD(IDAF,IODA,X(LS) ,LL2,12,0)
         CALL DAREAD(IDAF,IODA,X(LQ) ,LL3,45,0)
      END IF
      CALL DAREAD(IDAF,IODA,X(LD),LL2,16,0)
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0003                      FLGU
C-------------------------------------------------------------------FLGU
C         CALL GUESEG
C INITIAL GUESS, I.E.,  DENSITY FROM PREVIOUS RUN FOR A AND B PARTS
C IN THE CASE OF CUT OFF INCLUDES CORRECTION FROM CUT MO IN THE SCF
C SHOULD BE ADDED SEPARATELY [STORED IN X(DOFF) MATRIX]
C    SINCE THIS IS COMMENTED OUT, LVM AND LEM STORAGE IS NOT ALLOCATED:
C         CALL HTOM(X(LH1),X(LHM),L1,MBF)
C         CALL HTOM(X(LS),X(LSM),L1,MBF)
C         CALL GFLGES(X(LHM),X(LSM),X(LEM),X(LVM),X(LS1),X(LS2),
C     *       X(MJBIG),X(MBIG),MBF)
C
           IF(.NOT.OPTELG) THEN
             CALL GESTST(X(LCXAL),X(LCWAL),X(LVEC),X(LCBMA),X(MTMP),
     *            X(LS),X(MWRK1),NUM,LL2,NAAO,JXX,JWW,
     *            NOCC1,NVAC1,NOCC2,NVAC2,NOCCM,NVACM,NOCC,NWA,NWM,NHB)
             IF(MASPRT) WRITE(IW,*)' CPU TIME FOR ELG-GUESS'
            CALL TIMIT(1)
             CALL SEQREW(NEG5)
             READ(NEG5)
             READ(NEG5)
             READ(NEG5) (X(LD+I),I=0,(NAAO-NHB-NCTAO)
     *                           *(NAAO-NHB-NCTAO+1)/2-1)
           ELSE
             CALL GESOPT(X(LCXAL),X(LVEC),X(LCBMA),X(MTMP),
     *            X(LS),X(MWRK1),NUM,LL2,NAAO,JXX,
     *            NOCC1,NVAC1,NOCC2,NVAC2,NOCCM,NVACM,NOCC,NWA,NWM,NHB)
             CALL DMTX(X(LD),X(LVEC),X(LOCC),NOCC,NUM,NUM)
           ENDIF
C
      IF(LCUT) THEN
         CALL DENCUT(X(LD),X(LD1),X(LDTOT),NUMOLD,NFRGBS,
     *               LL2,NDIM2,NTOTAL)
      ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0003                        FLGU
C-------------------------------------------------------------------FLGU
C
C     THE FOLLOWING IS FOR THE DENSITY UPDATE IN THE INNER SCF WITHIN
C     MP2 ITERATIONS - HERE THE SCF-DENSITY IS IN RECORD 308, RECORD 16
C     CONTAINS THE MP2 DENSITY, SO WE READ FROM RECORD 308
C
      IF(ISEPS  .AND.  MP2ITER.EQ.1) THEN
         CALL DAREAD(IDAF,IODA,X(LD),LL2,308,0)
         WRITE(IW,*)
         WRITE(IW,*)"    READING IN SCF-DENSITY AGAIN FOR MP2ITER=1"
      END IF
C
      IF(SOSCF) THEN
CGU         CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
         CALL DAREAD(IDAF,IODA,X(LEIG),LL1,17,0)
         TDSKWRK = DSKWRK
         DSKWRK = .FALSE.
         IF(.NOT.FT15OP) THEN
            FT15OP = .TRUE.
            CALL SEQOPN(NFT15,'WORK15','UNKNOWN',.FALSE.,'UNFORMATTED')
            CALL SEQREW(NFT15)
         ELSE
            CALL SEQREW(NFT15)
         END IF
         DSKWRK = TDSKWRK
      END IF
C
C     ----- PREVIOUS DENSITY IS ZERO, PREVIOUS FOCK MAT. IS HCORE -----
C
      IF(DIRSCF  .AND.  FDIFF) THEN
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
         CALL DAWRIT(IDAF,IODA,X(LH1),LL2,14,0)
         CALL VCLR(X(LWRK1),1,L2)
      END IF
C
C     ----- IF SCRF SAVE PRISTINE ONE ELEC. HAM. -----
C     -----    AND READ IN DIPOLE INTEGRALS      -----
C
      IF(IZRFLS) THEN
         CALL DAREAD(IDAF,IODA,X(LXDINT),LL2,95,0)
         CALL DAREAD(IDAF,IODA,X(LYDINT),LL2,96,0)
         CALL DAREAD(IDAF,IODA,X(LZDINT),LL2,97,0)
      END IF
      IF(IZRFLS  .OR.  IEFP.EQ.1  .OR.  IPCFP  .OR.  ISVP.EQ.1) THEN
         CALL DAWRIT(IDAF,IODA,X(LH1),LL2,87,0)
      END IF
C
C     MINNESOTA SOLVENT MODEL: SETUP S-HALF MATRIX AND BORN RADII
C
C-SM5-CALL SETSOL(X(LS),L1,ABINIT)
C
C     ----- SETTING FOR GRID DFT -----
C
      IF (NDFTFG.EQ.1) THEN
C          PCM HAS A BUG RESETTING THE GRID, SO DON'T LET IT
        IF(IPCM.EQ.1) THEN
           NRAD0 = NRAD
           NPHI0 = NPHI
           NTHE0 = NTHE
        END IF
        IF(NRAD*NPHI*NTHE.GT.NRAD0*NPHI0*NTHE0) THEN
          IF(MASPRT) WRITE(IW,9340) NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0
          CALL SWGRID
          GRIDTYP=COARSE
        ELSE
          GRIDTYP=FINE
        END IF
        CALL DFTSET(X(IGRDDFT),1,.FALSE.)
C
C         SWITCH OFF DFT AT THIS POINT IF THE USER SO REQUESTED.
C
        IF(ISWOFF.GT.0) THEN
          IF(MASWRK  .AND.  NDFTFG.NE.0) WRITE(IW,9350)
          DFTTYP(3)=1.0D+00
          NDFTFG=0
        END IF
      END IF
C
C     ----- SETUP FOR QFMM -----
C
      IF (QFMM) THEN
         CALL QFMMUP(LL2,LS,NSHL2,LSLIST,NSHELL,LSLN,LTS,
     *     NCXYZ,LCXYZ,LIYP,LIBS,LISP,LIPP,LIDXWS,LINDX,MAXWS,
     *     MAXNYP,NSH2,LIDXSHL,LPNTR,NBOX,NTBOX,LCLM,LFLM,
     *     LAST,LIDXBOX,LMBOX,LEBOX,LNBR,LNUMWS,LYZPNT,LTMPGPS,
     *     LTMPGPL,NEED1,NEED,LAST1,LINDX2,LINDX3,
     *     LIDXIJK,LPTBL,LYZTBL,NSBOX,NTMPL,
     *     MTIJ,MIJKL,LYP,LZP,LITSP,LITPP,LITSP2,
     *     LITPP2,IJTPP,KLTPP,IJSPP,KLSPP,IJTBLP,IJTBL,LAST2,NEED2)
C
C           THERE ARE ADDITIONAL MEMORY ALLOCATIONS INSIDE ROUTINES
C           -QFMMBOX- AND -NEARJ-, WHICH THE CHECK RUN WILL BRANCH
C           AROUND W/O CALLING WHEN BRANCHING PAST THE ITERS BELOW.
C           THESE MEMORY NEEDS ARE NOT SIMULTANEOUSLY NECESSARY.
C
         MQBOX = 3*NCXYZ + 2*NCXYZ/NWDVAR + 3*2**NS/NWDVAR + 3
         MNEARJ= 6*MIJKL + 2
C
         IF(EXETYP.EQ.CHECK) THEN
            NEED2 = NEED2 + MAX(MQBOX,MNEARJ)
         ELSE
            IF(MASPRT) WRITE(IW,9035) NEED2 + MAX(MQBOX,MNEARJ)
         END IF
         CALL GETFM(NEED2)
         NEED=NEED+NEED2
      END IF
C
      IF(EXETYP.EQ.CHECK) GO TO 500
C
C     ----- PRINT ITERATION HEADER -----
C
      IF(MASPRT) THEN
      IF(NBUFMO.GT.0) THEN
        WRITE(IW,9039)
      END IF
      IF(DAMPH  .OR.  VSHIFT) THEN
         IF(SOSCF) THEN
            IF(.NOT.DIRSCF) WRITE(IW,9040)
            IF(     DIRSCF) WRITE(IW,9050)
         ELSE
            IF(.NOT.DIRSCF) WRITE(IW,9045)
            IF(     DIRSCF) WRITE(IW,9055)
         END IF
      ELSE
         IF(SOSCF) THEN
            IF(.NOT.DIRSCF) WRITE(IW,9060)
            IF(     DIRSCF) WRITE(IW,9070)
         ELSE
            IF(.NOT.DIRSCF) WRITE(IW,9065)
            IF(     DIRSCF) WRITE(IW,9075)
         END IF
      END IF
      END IF
C
C           ********************
C     ***** START RHF ITERATIONS *****
C           ********************
C
  101 CONTINUE
      TFOCK = ZERO
      TSOLVE = ZERO
      ITDIR=0
      SOSCF = SOSCF0
      DO 300 ITER=1,MAXIT
C
  310 CONTINUE
      CALL TSECND(TITER0)
C
C     ----- CONSTRUCT SKELETON 2 ELECTRON FOCK MATRIX -----
C     FOR DIRECT SCF,
C     EITHER -LWRK1- IS THE CHANGE IN THE DENSITY, WITH THE CHANGE
C     TO THE FOCK MATRIX TO BE COMPUTED IN -LFAO-, OR ELSE
C     -LWRK1- IS THE CURRENT DENSITY, WITH ALL 2 E- TERMS IN -LFAO-.
C
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0004                      FLGU
C-------------------------------------------------------------------FLGU
      IF(ABINIT) THEN
         IF(DIRSCF) THEN
            IF(FDIFF) THEN
               CALL VSUB(X(LWRK1),1,X(LD),1,X(LWRK1),1,L2)
               IF(LCUT) CALL VSUB(X(LDTWRK),1,X(LDTOT),1,X(LDTWRK),1,
     *              NTOTAL)
            ELSE
               CALL DCOPY(L2,X(LD),1,X(LWRK1),1)
               IF(LCUT) CALL DCOPY(NTOTAL,X(LDTOT),1,X(LDTWRK),1)
            END IF
            IF(SCHWRZ) THEN
               DUMMY = 0.0D+00
               IF(LCUT) THEN
                  CALL SHLDEN(RHF,X(LDTWRK),DUMMY,DUMMY,X(LDSH),
     *                 IA,NTOT,NTOTAL,NSH2,1)
               ELSE
                  CALL SHLDEN(RHF,X(LWRK1),DUMMY,DUMMY,X(LDSH),
     *                 IA,L1,L2,NSH2,1)
               ENDIF
            END IF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0004                        FLGU
C-------------------------------------------------------------------FLGU
            CALL VCLR(X(LFAO),1,L2)
C
C         ----- LINEAR SCALING TWO-ELECTRON INTEGRAL COMPUTATION -----
C
            IF (QFMM) THEN
               IDUMMY=0
               CALL LSTWOEI(LDLIST,NSHL2,LDLN,LTS,NSHELL,LMAXIJ,LDSH,
     *            NSH2,NINT,L1,L2,LXINTS,LGHOND,MAXG,LDDIJ,LWRK1,LFAO,
     *            LSLIST,LMLIST,LIDXSHL,LIPP,LINDX2,LIDXIJK,
     *            LIDXWS,NCXYZ,LSLN,LMLPNT,LIYP,LCXYZ,LIBS,LYZTBL,
     *            NTMPL,LYP,LZP,NTBOX,MAXWS,LYZPNT,LF,LG,LZLL,LCLM,
     *            LFLM,LIDXBOX,NSBOX,NZ,LISP,
     *            SCHWRZ,NSCHWZ,LINDX,LITSP,LITPP,LITSP2,LITPP2,LMBOX,
     *            LEBOX,LNBR,LNUMWS,MIJKL,IDUMMY,IDUMMY,
     *            IJTPP,KLTPP,IJSPP,KLSPP,IJTBLP,IJTBL)
C
C          ----- DIRECT TWO-ELECTRON INTEGRAL COMPUTATION -----
C                LARGE MOLECULES AND/OR DIFFUSE FUNCTIONS NEED
C                INCREASED ACCURACY TO AVOID ROUNDOFF ERRORS NEAR
C                CONVERGENCE.  FOCK DIFFERENCING NEEDS A LITTLE
C                BIT MORE CARE WITH THE CONVERGENCE THAN THAT.
C
            ELSE
               CUTSV  = CUTOFF
               CUTOFF = MIN(CUTOFF,1.0D-10)
               IF(FDIFF) CUTOFF=CUTOFF/TWO
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0005                      FLGU
C-------------------------------------------------------------------FLGU
               IF(LCUT) THEN
                  CALL ADDINT(RHF,DIRSCF,.FALSE.,.FALSE.,.FALSE.,
     *                 SCHWRZ,NINT,NSCHWZ,L2,
     *                 DUMMY,DUMMY,IDUMMY,1,
     *                 X(LXINTS),NSH2,X(LGHOND),MAXG,
     *                 IA,X(LDTWRK),X(LFAO),DUMMY,DUMMY,X(LDSH),
     *                 .FALSE.,NTOT,L2,NTOTAL)
               ELSE
                  CALL TWOEI(RHF,DIRSCF,.FALSE.,.FALSE.,.FALSE.,
     *                 INTTYP,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                    DUMMY,DUMMY,IDUMMY,1,
     *                    X(LXINTS),NSH2,X(LGHOND),MAXG,X(LDDIJ),
     *                    IA,X(LWRK1),X(LFAO),DUMMY,DUMMY,X(LDSH),
     *                    DUMMY,DUMMY,1)
               END IF
               CUTOFF = CUTSV
            ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0005                        FLGU
C-------------------------------------------------------------------FLGU
            CALL DSCAL(L2,HALF,X(LFAO),1)
            II=LFAO-1
            DO I=1,L1
               II = II+I
               X(II) = X(II) + X(II)
            ENDDO
C
C          ----- TWO-ELECTRON INTEGRALS TAKEN FROM DISK -----
C
         ELSE
            TDSKWRK = DSKWRK
            DSKWRK  = .TRUE.
            CALL SEQREW(IS)
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0006                      FLGU
C-------------------------------------------------------------------FLGU
            IF(LCUT) THEN
               CALL HSTELG(X(LDTOT),X(LFAO),X(LBUF),X(LIBUF),
     *                 NINTMX,IA,NOPK)
            ELSE
               CALL HSTAR(X(LD),X(LFAO),X(LBUF),X(LIBUF),
     *                 NINTMX,IA,NOPK,.FALSE.)
            END IF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0006                        FLGU
C-------------------------------------------------------------------FLGU
            DSKWRK  = TDSKWRK
         END IF
C
C     ----- ADD GRID DFT CONTRIBUTION TO 2E- FOCK OPERATOR -----
C     TRANSPOSING ALLOWS UNIT STRIDE ACCESS INSIDE THE DFT CODES
C
         IF (NDFTFG.EQ.1) THEN
           IF(ITER .EQ. 1) CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
           CALL TRPOSE(X(LVEC),X(LWRK1),L1,L1,1)
           CALL DFTEXCOR(X(IGRDDFT),X(LFXC),X(LFXC),X(LVEC),X(LVEC),
     *                   L1,L2,EEXC,TOTELE,TOTKIN)
           CALL TRPOSE(X(LVEC),X(LWRK1),L1,L1,1)
           CALL SYMH(X(LFXC),X(LWRK2),IA)
C
C          FOCK MATRIX WILL BE CONTRACTED WITH DENSITY.
C          THIS IS MEANINGLESS FOR THE DFT EXCHANGE CORRELATION,
C          SO WE SUBSTRACT THAT LATER.
C          P.S. MEANINGLESS BECAUSE FXC DEPENDS ON DENSITY.
C
           CALL DDI_GSUMF(2310,EEXC,1)
           CALL DDI_GSUMF(2311,TOTELE,1)
           IF (PRTTAU) THEN
             CALL DDI_GSUMF(2317,TOTKIN,1)
             WRITE(IW,9326) TOTKIN
           END IF
           EDFT(1)=EEXC
           EDFT(2)=TOTELE
C
C          BY ADDING FXC NOW WE SAVE ONE CALL TO DDI_GSUM.
C
           IF(.NOT.(ABINIT.AND.DIRSCF.AND.FDIFF)) THEN
             EDHF1 = TRACEP(X(LD),X(LFXC),L1)/TWO
             CALL DDI_GSUMF(2314,EDHF1,1)
             CALL VADD(X(LFAO),1,X(LFXC),1,X(LFAO),1,L2)
           END IF
C
C          FDIFF DOES NOT WORK WITH DFT, UNLESS ONE DOES NOT
C          INCLUDE FXC (FOCK EX-CORR) INTO DIFFERENCING,
C          PROBABLY BECAUSE OF THE ABOVE P.S.
C
         END IF
         IF(GOPARR) THEN
            CALL DDI_GSUMF(1000,X(LFAO),L2)
            CALL DDI_GSUMI(1001,NINT   ,1)
            CALL DDI_GSUMI(1002,NSCHWZ ,1)
         END IF
C
C           ----- MOPAC SEMI-EMPIRICAL 2E- FOCK OPERATOR -----
C
      ELSE
         HFCO = -HALF
         CALL MPCG(X(LFAO),X(LFAO),X(LD),DUMMY,DUMMY,X(LPTOT2),
     *             X(LTWOEI),L2,HFCO)
      END IF
C
C     ----- ADD POSSIBLE GRID-FREE DFT TERMS TO FOCK MATRIX
C
      IF(DFTTYP(1) .NE. 0.0D+00) THEN
C         IN RHF THE ORBITALS ARE NOT READ IN FOR THE FIRST ITERATION
          IF(ITER .EQ. 1) CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
          CALL DFTDRVR(X(MEMDFT),X(LFAO),X(LFAO),X(LD),X(LD),X(LVEC))
          IF(PRDENS .OR. OUT) THEN
              WRITE(IW,9320) EXENA+EXENB
          END IF
      ELSE
          EXENA=0.0D+00
          EXENB=0.0D+00
          EXENC=0.0D+00
      END IF
C
C           AT THIS POINT, THE SKELETON 2E- FOCK OPERATOR IS FINISHED
C
      IF(OUT) THEN
         WRITE(IW,*) '*** START OF DEBUG OUTPUT FOR ITERATION',ITER
         WRITE(IW,*) 'SKELETON FOCK MATRIX'
         CALL PRTRIL(X(LFAO),L1)
      END IF
C
C     ----- SYMMETRIZE SKELETON FOCK MATRIX -----
C     SCRATCH AREA AT LWRK1 IS USED AS A SYMMETRIC MATRIX
C
      CALL SYMH(X(LFAO),X(LWRK1),IA)
      IF(OUT) THEN
         WRITE(IW,*) 'SYMMETRIZED FOCK OPERATOR'
         CALL PRTRIL(X(LFAO),L1)
      END IF
C
C     * * * * * SOLVATION MODEL CORRECTIONS TO 1E- TERM * * * * *
C
C                ----- ONSAGER REACTION FIELD -----
C     GET PRISTINE ONE ELEC. HAM., CALC. INDUCED DIPOLES, ADD PERTURB.
C
      IF(IZRFLS) THEN
         CALL DAREAD(IDAF,IODA,X(LH1),LL2,87,0)
         IF(DIRSCF .AND. FDIFF) THEN
            CALL RCNFLD(X(LH1),X(LFAO),DUMMY,X(LD),X(NDIPER),
     *                  X(LDIPER),X(LXDINT),X(LYDINT),X(LZDINT),L2,L1,0)
         ELSE
            CALL RCNFLD(X(LH1),DUMMY,DUMMY,X(LD),DUMMY,
     *                  DUMMY,X(LXDINT),X(LYDINT),X(LZDINT),L2,L1,0)
         END IF
      END IF
C
C     ----- SURFACE AND VOLUME POLARIZATION FOR ELECTROSTATICS -----
C
      IF(ISVP.EQ.1) THEN
         CALL SVPCHG(X(LD),X(LD),X(LH1),X(LWRK1),IADDR_SVP,ILAST_SVP,
     1               LL2,LL1,ESVP,ITER,
     2               CVGSVPDN,CVGSVPDN1,CVGSVPNR,IUPRXN,CHGDIF,CVGSVP)
      END IF
C
C     ----- POLARIZABLE CONTINUUM MODEL CALCULATION -----
C
      IF(IPCM.EQ.1) THEN
C
C      IF BUFFER MOS ARE THERE, USE THE 'BUFFERLESS' DENSITY IN PCMFLD
C
         IF(NBUFMO.GT.0) THEN
            CALL DCOPY(L2,X(LD),1,X(LWRK1),1)
            CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
            CALL DMTX(X(LWRK2),X(LVEC),X(LOCC),NBUFMO,L1,L1)
            CALL VSUB(X(LWRK2),1,X(LD),1,X(LWRK2),1,L2)
         ELSE
            CALL DCOPY(L2,X(LD),1,X(LWRK2),1)
         END IF
         CALL PCMFLD(X(LFAO),DUMMY,X(LD),X(LSOL),X(LCHG),X(LWRK1),
     *               X(LDISV),X(LDIS1),X(LDIS2),X(LWRK3),X(LSCR),
     *               X(LDMATM),X(LCQEF),X(LQEFF),X(LELD),X(LQPOT),
     *               X(LQFLD),X(LVPOT),X(LSE),X(LDE),
     *               X(LQ0),X(LQ1),X(LQ2),X(LQ3),
     *               X(LD0),X(LQA),X(LDIMAT),X(LQREP),
     *               X(LTMP0),X(LTMP1),X(LTMP2),X(LIPVT),
     *               X(LPOTTMP),X(LRMUL),TCH,QET,QETN,QESC,ISD,NFT27,
     *               IPCFP,L1,L2,NTSPAR,X(LAXYZCT),X(LAXYZCT+MXTS),
     *               X(LAXYZCT+MXTS*2),X(LXYZCT2),X(LXYZCT2+MXTS),
     *               X(LXYZCT2+MXTS*2),X(LAXYZCT+MXTS*3),X(LQSN),
     *               X(LQSE),X(LQFS),X(LVECMUL),
     *               X(LCHG2),X(LQIND+MXTS),X(LPEL),
     *               X(LASCCRD),X(LASCCHG),X(LASCDIP),X(LASCQAD),
     *               X(LXYZRE),X(LXYZRE+MXSP),X(LXYZRE+MXSP*2),
     *               X(LXYZRE+MXSP*3),X(LISPHE),X(LLIST))
      END IF
      IF(NFMOPCM.NE.0) THEN
        CALL DAREAD(IDAF,IODA,X(LWRK2),L2,311,0)
        PX=-TRACEP(X(LD),X(LWRK2),L1)
      ENDIF
C
C               ------ COMBINED PCM/EFP METHOD ------
C
      IF(IPCFP) THEN
         IF(NBUFMO.GT.0) THEN
            CALL DCOPY(L2,X(LD),1,X(LWRK1),1)
            CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
            CALL DMTX(X(LWRK2),X(LVEC),X(LOCC),NBUFMO,L1,L1)
            CALL VSUB(X(LWRK2),1,X(LD),1,X(LWRK2),1,L2)
         ELSE
            CALL DCOPY(L2,X(LD),1,X(LWRK2),1)
         END IF
         CALL PCMFLD(X(LFAO),DUMMY,X(LD),X(LSOL),X(LCHG),X(LWRK1),
     *               X(LDISV),X(LDIS1),X(LDIS2),X(LWRK3),X(LSCR),
     *               X(LDMATM),X(LCQEF),X(LQEFF),X(LELD),X(LQPOT),
     *               X(LQFLD),X(LVPOT),X(LSE),X(LDE),
     *               X(LQ0),X(LQ1),X(LQ2),X(LQ3),
     *               X(LD0),X(LQA),X(LDIMAT),X(LQREP),
     *               X(LTMP0),X(LTMP1),X(LTMP2),X(LIPVT),
     *               X(LPOTTMP),X(LRMUL),TCH,QET,QETN,QESC,ISD,NFT27,
     *               IPCFP,L1,L2,NTSPAR,X(LAXYZCT),X(LAXYZCT+MXTS),
     *               X(LAXYZCT+MXTS*2),X(LXYZCT2),X(LXYZCT2+MXTS),
     *               X(LXYZCT2+MXTS*2),X(LAXYZCT+MXTS*3),X(LQSN),
     *               X(LQSE),X(LQFS),X(LVECMUL),
     *               X(LCHG2),X(LQIND+MXTS),X(LPEL),
     *               X(LASCCRD),X(LASCCHG),X(LASCDIP),X(LASCQAD),
     *               X(LXYZRE),X(LXYZRE+MXSP),X(LXYZRE+MXSP*2),
     *               X(LXYZRE+MXSP*3),X(LISPHE),X(LLIST))
         CALL DAREAD(IDAF,IODA,X(LH1),LL2,87,0)
C
C           IF BUFFER MOS ARE THERE, USE 'BUFFERLESS' DENSITY IN CHGIND
C
         IF(NBUFMO.GT.0) THEN
            CALL DCOPY(L2,X(LD),1,X(LWRK1),1)
            CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
            CALL DMTX(X(LWRK2),X(LVEC),X(LOCC),NBUFMO,L1,L1)
            CALL VSUB(X(LWRK2),1,X(LD),1,X(LD),1,L2)
         END IF
C
         IF(DIRSCF .AND. FDIFF) THEN
            CALL CHGIND(X(LH1),X(LFAO),DUMMY,X(LD),X(NDIPER),X(LDIPER),
     *                  X(LDMATM),X(LXDINT),X(LYDINT),X(LZDINT),
     *                  X(LEFLD),X(MADD),X(LABFLD),X(LVECMP),X(LVEC_2),
     *                  X(LVEC_S),L2,L1,0,
     *                  X(LAXYZCT),X(LAXYZCT+MXTS),X(LAXYZCT+MXTS*2),
     *                  X(LAXYZCT+MXTS*3),X(LQSN),X(LQSE),X(LQFS),
     *                  X(LQIND),X(LAIPRJ),X(LFIPRJ))
         ELSE
            CALL CHGIND(X(LH1),DUMMY,DUMMY,X(LD),DUMMY,DUMMY,
     *                  X(LDMATM),X(LXDINT),X(LYDINT),X(LZDINT),
     *                  X(LEFLD),X(MADD),X(LABFLD),X(LVECMP),X(LVEC_2),
     *                  X(LVEC_S),L2,L1,0,
     *                  X(LAXYZCT),X(LAXYZCT+MXTS),X(LAXYZCT+MXTS*2),
     *                  X(LAXYZCT+MXTS*3),X(LQSN),X(LQSE),X(LQFS),
     *                  X(LQIND),X(LAIPRJ),X(LFIPRJ))
         END IF
C
C           WE WANT THE FULL DENSITY BACK AFTER EFPCMP IS DONE
C
         IF(NBUFMO.GT.0) CALL DCOPY(L2,X(LWRK1),1,X(LD),1)
      END IF
C
C           ---- EFFECTIVE FRAGMENT POTENTIAL MODEL -----
C
      IF(IEFP.EQ.1) THEN
         CALL DAREAD(IDAF,IODA,X(LH1),LL2,87,0)
C
C      IF BUFFER MOS ARE THERE, USE THE 'BUFFERLESS' DENSITY IN EFPCMP
C
         IF(NBUFMO.GT.0) THEN
            CALL DCOPY(L2,X(LD),1,X(LWRK1),1)
            CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
            CALL DMTX(X(LWRK2),X(LVEC),X(LOCC),NBUFMO,L1,L1)
            CALL VSUB(X(LWRK2),1,X(LD),1,X(LD),1,L2)
         END IF
         IF(DIRSCF .AND. FDIFF) THEN
            CALL EFPCMP(X(LH1),X(LFAO),DUMMY,X(LD),X(NDIPER),
     *                  X(LDIPER),X(LXDINT),X(LYDINT),X(LZDINT),
     *                  X(LEFLD),X(MADD),X(LABFLD),L2,L1,0)
         ELSE
            CALL EFPCMP(X(LH1),DUMMY,DUMMY,X(LD),DUMMY,DUMMY,
     *                  X(LXDINT),X(LYDINT),X(LZDINT),X(LEFLD),
     *                  X(MADD),X(LABFLD),L2,L1,0)
         END IF
C   WE WANT THE FULL DENSITY BACK AFTER EFPCMP IS DONE
         IF(NBUFMO.GT.0) THEN
            CALL DCOPY(L2,X(LWRK1),1,X(LD),1)
         END IF
      END IF
C
C                      ----- COSMO -----
C     ADD IN CORRECTION DUE TO SOLVENT SCREENING SELF-CONSISTENTLY
C     FIXED SCREENING CHARGES FOR HF PART WITHIN MP2 (MP2ITER=1)
C
      IF(ISEPS) THEN
         DO 402 IF=1,NAT
            DO 403 JF=1,3
               FCOORD(JF,IF)=C(JF,IF)
  403       CONTINUE
  402    CONTINUE
C
         IF(MP2ITER.EQ.0) THEN
            WRITE(IW,9400)
            WRITE(IW,*)'              ADD IN COSMO SOLVENT EFFECTS    '
            WRITE(IW,9400)
            WRITE(IW,*)" GRAB MULTIPOLES AND SET UP SOLVENT SURFACE."
            ITRIP2=1
            WRITE(IW,*)
            WRITE(IW,*)" AMOS'S DISTRIBUTED MULTIPOLE ANALYSIS:"
            WRITE(IW,*)"      -- CALLING FROM RHFCL --"
            WRITE(IW,*)
            CALL TIMIT(1)
            CALL NUMPROP
            WRITE(IW,*)" BACK FROM NUMPROP:"
            CALL TIMIT(1)
C
C     FIRST SCF ITERATION NEEDS SURFACE CONSTRUCTION
C         ABCMAT HOLDS THREE DIFFERENT MATRICES NAMED A, B, C.
C         WHEN A IS FIRST GENERATED, IT IS SQUARE STORAGE.
C         WE DON'T KNOW HOW BIG -NPS- WILL BE UNTIL PART WAY
C         THROUGH CONSTS ROUTINE, SO WE MAKE A GUESS OF -IPS-
C
            IPS = 50*NAT
            IPS2 = (IPS*IPS+IPS)/2
            NDEN2 = (NDEN*NDEN+NDEN)/2
            LENAB2 = MAX(IPS*IPS, IPS2 + NDEN*IPS + NDEN2)
            CALL VALFM(LOADFM)
            LABCMT = LOADFM + 1
            LXSP   = LABCMT + LENAB2
            LNSET  = LXSP   + 3*LENABC
            LNSETF = LNSET  + (NPPA*NAT)/(2*NWDVAR) + 3
            LIPIV  = LNSETF + LENABC/NWDVAR         + 1
            LDIN   = LIPIV  + LENABC/NWDVAR         + 1
            LTM    = LDIN   + NPPA/NWDVAR           + 1
            LDIRTM = LTM    + 3*3*NAT
            LBH    = LDIRTM + 3*NPPA
            LCONRM = LBH    + LENABC
            LNAR   = LCONRM + 3*LENABC
            LNIPA  = LNAR   + LENABC
            LLIPA  = LNIPA  + 400
            LSUDE  = LLIPA  + 4000
            LISUDE = LSUDE  + 4*500
            LNN    = LISUDE + 4*500
            LAST   = LNN    + 3*NAT
            NEEDC = LAST - LOADFM - 1
            CALL GETFM(NEEDC)
C
C               GENERATE COSMO SURFACE AND SAVE -A- MATRIX INVERSE
C
            IF(ICORR.EQ.0) THEN
               NFT26 = 26
               CALL SEQOPN(NFT26,'PCMDATA','UNKNOWN',
     *                     .FALSE.,'UNFORMATTED')
               CALL CONSTS(C,X(LABCMT),X(LXSP),X(LNSET),X(LNSETF),
     *                     X(LIPIV),X(LDIN),X(LTM),X(LDIRTM),
     *                     X(LCONRM),X(LNAR),X(LNIPA),X(LLIPA),
     *                     X(LSUDE),X(LISUDE),X(LNN),
     *                     LENABC,LENAB2,NPPA,NAT)
               CALL SQWRIT(NFT26,X(LABCMT),NPS2)
            ELSE
               CALL SQREAD(NFT26,X(LABCMT),NPS2)
            END IF
C
C               GENERATE AND SAVE -B- AND -C- MATRICES
C
            CALL BTOC(C,X(LABCMT),X(LBH),LENABC,LENAB2)
            CALL SQWRIT(NFT26,X(LABCMT+NPS2)         ,NDEN*NPS)
            CALL SQWRIT(NFT26,X(LABCMT+NPS2+NDEN*NPS),NDEN2)
            CALL SEQREW(NFT26)
C
            CALL DECORR(X(LABCMT),LENAB2)
            CALL RETFM(NEEDC)
C
            USEPS=.TRUE.
            WRITE(IW,*)"NOW WE NEED ENERGY OF THE SOLUTE+SOLVENT:"
            ITRIP4=1
            ICORR=1
            WRITE(IW,*)"UPDATING 1 ELECTRON CONTRIBUTION:"
            CALL ONEEI
            WRITE(IW,*)"ADDING NUCLEAR/SCREENING CHARGE CONTRIBUTION:"
            EN=ENUC(NAT,ZAN,C)
            WRITE(IW,*)"ETOT, SECORR, EN= ",ETOT,SECORR,EN
         END IF
      END IF
C
C     * * * * * END OF SOLVATION MODEL CORRECTIONS TO 1E- TERM * * * * *
C
C     ----- COMPLETE THE FOCK MATRIX -----
C     WE EITHER ADD THE FOCK OPERATOR OF THE PREVIOUS ITERATION TO
C     THE CHANGE IN THE FOCK MATRIX, OR WE ADD THE ONE ELECTRON
C     HAMILTONIAN TO THE FULLY COMPUTED TWO ELECTRON OPERATOR.
C
C       IF MO FREEZING IS IN EFFECT,
C       THE UNZEROED FOCK MATRIX IN AO BASIS WILL BE NEEDED TO
C       COMPUTE LAGRANGIAN AT THE END OF THE LAST ITERATION
C       (DICTIONARY FILE 317).
C
C     FOR COSMO, WE NEED TO UPDATE THE ONE-ELECTRON HAMILTONIAN FOR
C     CONVENTIONAL SCF-COSMO AND FOR THE INNER SCF WITHIN THE
C     MP2-COSMO ITERATIONS FOR BOTH SCF TYPES
C
      IF(ISEPS) CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
C
      IF(ABINIT  .AND.  DIRSCF  .AND.  FDIFF) THEN
         IF(MFRZ .AND. ITER .GT. 1) THEN
             CALL DAREAD(IDAF,IODA,X(LWRK1),LL2,317,0)
             CALL VADD(X(LWRK1),1,X(LFAO),1,X(LWRK1),1,L2)
             CALL DAWRIT(IDAF,IODA,X(LWRK1),LL2,317,0)
         END IF
         CALL DAREAD(IDAF,IODA,X(LWRK1),LL2,14,0)
         CALL VADD(X(LFAO),1,X(LWRK1),1,X(LFAO),1,L2)
C
C     FOR DIRECT SCF-COSMO WHERE THE SURFACE CHARGES ARE UPDATED EACH
C     SCF ITERATION, WE NEED THE CHANGE IN H BETWEEN THE CURRENT AND
C     THE PREVIOUS SCF ITERATION, SO THE CURRENT H IS ADDED FROM
C     SECTION 11 AND THE PREVIOUS H SUBTRACTED FROM SECTION 87
C
         IF(ISEPS.AND.(MP2ITER.EQ.0)) THEN
            WRITE(IW,*)"ADDING DIFFERENCE HNEW-HOLD TO F"
            CALL VADD(X(LFAO),1,X(LH1),1,X(LFAO),1,L2)
            CALL DAREAD(IDAF,IODA,X(LH1),LL2,87,0)
            CALL VSUB(X(LH1),1,X(LFAO),1,X(LFAO),1,L2)
         END IF
C
         IF(MFRZ .AND. ITER .EQ. 1)
     *       CALL DAWRIT(IDAF,IODA,X(LFAO),LL2,317,0)
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
      ELSE
         IF(DOMBAS) CALL CTMOTR(X(LWRK1),X(LFAO),X(LWRK2),X(LSCR),LL1)
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
         CALL VADD(X(LFAO),1,X(LH1),1,X(LFAO),1,L2)
         IF(MFRZ) CALL DAWRIT(IDAF,IODA,X(LFAO),LL2,317,0)
      END IF
C
C        SAVE THE FOCK MATRIX TO DISK.  NOTE THAT THIS DOES NOT
C        CONTAIN THE DFT EXCHANGE, BUT MUST BE SAVED HERE SO THAT
C        THE FDIFF OPTION WORKS PROPERLY.
C        SEE THE NOTE ABOUT DFT EXCHANGE ABOVE, IT CANNOT BE FDIFF'ED.
C
      CALL DAWRIT(IDAF,IODA,X(LFAO),LL2,14,0)
      IF(CVGED  .AND.  ICCFLG.GT.0) GO TO 290
C
C     IF DOMBAS, FILE 16 INITIALLY CONTAINS AO BASED DENSITY,
C     AFTER HERE, IT CONTAINS MO BASED DENSITY.
C
      IF(DOMBAS.AND.ITER.EQ.1) CALL INDDEN(LL1,NA,NST)
      IF(DOMBAS) CALL DAREAD(IDAF,IODA,X(LD),LL2,16,0)
C
C     ----- CALCULATE THE ENERGY -----
C
      EHF1 = TRACEP(X(LD),X(LFAO),L1)
      EHF2 = TRACEP(X(LD),X(LH1),L1)
C
C       GRID DFT: FXC HAS NOT YET BEEN SUMMED, DO IT NOW (COMPLETES F)
C       SAVE THIS COMPLETED FOCK MATRIX FOR THE END OF THE RUN,
C       RECYCLING -308- RECORD SINCE MP2/COSMO AND DFT DON'T CLASH
C
      IF(NDFTFG.EQ.1.AND.ABINIT.AND.DIRSCF.AND.FDIFF) THEN
        CALL DDI_GSUMF(2312,X(LFXC),L2)
        CALL VADD(X(LFAO),1,X(LFXC),1,X(LFAO),1,L2)
        CALL DAWRIT(IDAF,IODA,X(LFAO),LL2,308,0)
      END IF
C
C     IF PCM: ADD SOLUTE-SOLVENT DISPERSION ENERGY
C
      IF(IPCM.EQ.1  .AND.  IDP.EQ.1  .AND.  ISD.EQ.1)
     *  EHF2=EHF2+TRACEP(X(LD),X(LDIS1),L1)
C
C   SUBTRACT INTERACTION OF THE EFP WITH THE BUFFER ZONE DENSITY.
C   IF EFP + PCM, REMOVE CONTRIBUTIONS FROM NUCLEI AND ELECTRONS
C   INTERACTING WITH THE NUCLEAR INDUCED CHARGE
C   CALCULATE THE DENSITY OF THE BUFFER ZONE (FIRST NBUFMO MO-S)
C
C   HERE WE DEFINE EEFP AS THE INTERACTION OF THE EFP(MULTIPOLE
C   POINTS AND POLARIZABLE POINTS) WITH THE BUFFER ZONE DENSITY
C   I.E. (1)BUFFER ELECTRON -- MULTIPOLE POINTS
C        (2)BUFFER ELECTRON -- POLARIZABLE POINTS(INDUCED DIPOLE)
C   ANY PCM ASC ASSOCIATED INTERACTION IS NOT CONSIDERED AS A
C   PART OF EEFP.
C
      IF(NBUFMO.GT.0) THEN
         CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
         CALL DAREAD(IDAF,IODA,X(LWRK2),L2,319,0)
         CALL VSUB(X(LWRK2),1,X(LH1),1,X(LWRK2),1,L2)
C
        IF(IPCMIT.EQ.0) THEN
           IF(IPCM.EQ.1) THEN
              CALL DAREAD(IDAF,IODA,X(LWRK3),L2,263,0)
              CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
              CALL DAREAD(IDAF,IODA,X(LWRK3),L2,264,0)
              CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
           END IF
           IF(IPCFP) THEN
              CALL DAREAD(IDAF,IODA,X(LWRK3),L2,263,0)
              CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
              CALL DAREAD(IDAF,IODA,X(LWRK3),L2,264,0)
              CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
              CALL VSUB(X(LVEC_2),1,X(LWRK2),1,X(LWRK2),1,L2)
           END IF
        END IF
C
         CALL DMTX(X(LWRK3),X(LVEC),X(LOCC),NBUFMO,L1,L1)
         EEFP= TRACEP(X(LWRK3),X(LWRK2),L1)
      ELSE
         EEFP = ZERO
      END IF
C
C         THE CONTRIBUTIONS HERE ARE THE AB INITO ENERGY
C         PLUS EXCHANGE CORRELATION FROM GRIDLESS DFT
C         PLUS EXCHANGE CORRELATION FROM GRID DFT
C         MINUS A CORRECTION FROM THE BUFFER REGION EFP CODE
C         PLUS A POSSIBLE MOPAC EMPIRICAL MM ENERGY FOR PEPTIDE BONDS
C
      EHF0 = EHF
      EHF = (EHF1+EHF2)/TWO
     *    + (EXENA+EXENB+EXENC)
     *    + (EEXC-EDHF1)
     *    - EEFP
     *    + EHNCO
C
C     MO FREEZING REQUIRES TRANSFORMATION TO THE MO BASIS,
C     ZEROING OUT THE OFF-DIAGONAL FOCK MATRIX FROZEN ROW/COLUMN
C     ELEMENTS AND THEN BACKTRANSFORMATION TO THE AO BASIS.
C
C     TO KEEP THE FROZEN ORBITALS EVEN MORE STEADIER, THE INITIAL
C     MO-S (DAF 318) WILL BE USED FOR TRANSFORMATION TO MO BASIS.
C
      IF(MFRZ) THEN
C
        CALL DAREAD(IDAF,IODA,X(LVEC),LL3,318,0)
        CALL TFTRI(X(LWRK1),X(LFAO),X(LVEC),X(LWRK),L0,L1,L1)
        CALL FRFOCK(X(LWRK1),L1)
        IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),LL2,12,0)
        CALL TFTRIB(X(LFAO),X(LWRK1),X(LS),X(LVEC),X(LWRK2),
     *              X(LIWRK),L0,L1,L2,L3)
        IF(.NOT.FDIFF  .AND.  NDFTFG.NE.1)
     *      CALL DAWRIT(IDAF,IODA,X(LFAO),LL2,14,0)
      END IF
C
C     THIS IS SOMETHING LEFT OVER FROM THE MINNESOTA SOLVENT CODES.
C     IF $CM2 IS NOT PROVIDE IN THE INPUT,
C     BOTH REACTF AND GBSCRF ARE DRY RUNS (DO NOTHING)
C
C-SM5-ETO=EHF+EN
C-SM5-CALL REACTF(ETO)
C-SM5-CALL GBSCRF(X(LFAO),L1)
C
C     ----- DEBUG PRINT OF ENERGY, FOCK MATRIX, AND LAGRANGIAN -----
C     -FV- AND -EIJ- AT LWRK1 AND LWRK2 ARE SQUARE MATRICES
C
      IF(OUT) THEN
         WRITE(IW,9080) EHF1,EHF2,EHF
         WRITE(IW,*) 'TOTAL FOCK OPERATOR'
         CALL PRTRIL(X(LFAO),L1)
      END IF
      IF(NPRINT.EQ.5 .OR. EXETYP.EQ.DEBUG .OR. EXETYP.EQ.DBUGME)
     *    CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
      IF(OUT) THEN
         CALL MAKFV(X(LFAO),X(LVEC),X(LWRK1),X(LWRK),IA,1,NA,L1,L1)
         CALL MAKEIJ(X(LVEC),X(LWRK1),X(LWRK2),X(LWRK),L0,L0,L1,L0,L1)
         WRITE(IW,*) 'LAGRANGE MULTIPLIER MATRIX'
         CALL PRSQ(X(LWRK2),NA,L0,L1)
      END IF
C
      ETOT0 = ETOT
      ETOT  = EHF+EN
C
C        ---- SOLVENT ENERGY CORRECTIONS ----
C
C     NOTE: ONSAGER MODEL PUT FREE ENERGY CORRECTIONS INTO -EN- ALREADY
C
C     IF PCM: CALCULATE THE CORRECT VARIATIONAL FREE ENERGY
C
      IF(IPCMIT.EQ.0) THEN
         IF((IPCM.EQ.1.AND.ISD.EQ.1).OR.IPCFP) ETOT=ETOT-HALF*(PB-PC)
      ELSE
         IF((IPCM.EQ.1.AND.ISD.EQ.1).OR.IPCFP) ETOT=ETOT+HALF*PX
      END IF
      IF(NFMOPCM.NE.0) ETOT=ETOT+HALF*(PC+PX)
C
      IF(IPCM.EQ.1) THEN
         ETOT=ETOT+(GCAVP+GDISP+GREP)/627.509541D+00
      END IF
C
C     SVP MODEL'S FREE ENERGY CORRECTION IS
C     +HALF*ATMSVP SINCE IT HAS NOT YET BEEN ACCOUNTED FOR, BUT
C     -HALF*ELCSVP SINCE EHF ALREADY IMPLICITLY CONTAINS ELCSVP
C
      IF(ISVP.EQ.1) THEN
         ETOT=ETOT+HALF*(ATMSVP-ELCSVP)
      END IF
C
      IF(ITER.EQ.1) E0 = ETOT
      DELE0 = DELE
      DELE  = ETOT-ETOT0
      IF(ITER.EQ.1) DEAVG = ZERO
      IF(ITER.EQ.2) DEAVG = ABS(DELE)
      IF(ITER.GE.3) DEAVG = (ABS(DELE)+ ABS(DELE0)+PT2*DEAVG)/TWOPT2
      CALL TSECND(TITER1)
C
C     ----- POSSIBLE SECOND ORDER SCF -----
C     ON THE VERY FIRST ITERATION OF THE VERY FIRST GEOMETRY, WE MUST
C     DO A DIAGONALIZATION TO GET EIGENVALUES TO APPROX. THE HESSIAN.
C     ALL THREE -LWRK- WORK ARRAYS ARE AVAILABLE FOR SCRATCH USAGE.
C     HESSIAN RUNS MAY NOT HAVE CANONICAL VIRTUAL ORBITALS READ IN,
C     AND IT IS PROBABLY A GOOD IDEA TO DIAGONALIZE ONCE ANYWAY, JUST
C     TO MIX SYMMETRIES UP WELL DURING NUMERICAL RUNS.
C
C     FMO DOES NOT ALWAYS HAVE ORTHONORMALISED INITIAL ORBITALS.
C     DUE TO THIS OR OTHER REASON, SOSCF RUNS WITHOUT PRECEEDING DIIS
C     CONVERGE TO TOTALLY WRONG ENERGIES. ALL OF THIS HAPPENS ONLY
C     WITH DIMERS WHEN INITIAL GUESS IS COOKED FROM MONOMERS (NOTE
C     THAT IN ANY CASE THE INITIAL DENSITY IS PHYSICALLY MEANINGFUL,
C     BUT IT DOES NOT ALWAYS EXACTLY CORRESPOND TO INITIAL ORBITALS).
C     DIIS USES ONLY DENSITY.  SECONDLY, NOW FMO WRITES FAKE INITIAL
C     ORBITALS EXCEPT WHEN DOING DFT.
C
      EIGAVL = ITER.GT.1  .OR.  NEVALS.GE.1
      IF(RUNTYP.EQ.HESS)   EIGAVL = ITER.GT.1
      IF(RUNTYP.EQ.MOROKM) EIGAVL = ITER.GT.1
      IF(NFG.NE.0)         EIGAVL = ITER.GT.1
C
      IF(SOSCF .AND.  EIGAVL) THEN
         CALL SOGRAD(X(LGRAD),X(LFAO),X(LVEC),X(LSCR),NPR,NA,
     *               L0,L1,ORBGRD)
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0007                      FLGU
C-------------------------------------------------------------------FLGU
         IF(ELGSO) CALL SOELG(X(LGRAD),NPR,ORBGRD,L0,NA,NOCC1,NVAC1)
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0007                        FLGU
C-------------------------------------------------------------------FLGU
C        SEE COMMENTS BELOW AT SIMILAR B'CASTS. ISGDDI SHOULD BE GOPARR.
         IF(ISGDDI) CALL DDI_BCAST(2421,'F',ORBGRD,1,MASTER)
         IF(ORBGRD.LT.SMALL) THEN
            DIFF = ZERO
            CVGING=.TRUE.
            GO TO 700
         END IF
         IF(ORBGRD.LT.SOGTOL  .OR.  ITSO.GT.0) THEN
            IF(ITSO.EQ.0) THEN
               DAMP = ZERO
               RRSHFT = ZERO
               IF(MASPRT) WRITE(IW,9200)
               CALL SOHESS(X(LHESS),X(LEIG),NPR,L0,NA,NA)
            END IF
C
            ITSO = ITSO+1
            CALL SONEWT(X(LHESS),X(LGRAD),X(LPGRAD),X(LDISPL),
     *                  X(LWRK1),X(LWRK2),X(LWRK3),
     *                  X(LWRK1+NPR),X(LWRK2+NPR),X(LWRK3+NPR),
     *                  ORBGRD,NPR,ITSO,NFT15)
            IF(ORBGRD.EQ.-123) GO TO 350
            CALL SOTRAN(X(LDISPL),X(LVEC),X(LWRK1),X(LSCR),
     *                  NPR,L0,L1,NA,NA,ORBGRD)
            CALL DCOPY(NPR,X(LGRAD),1,X(LPGRAD),1)
            GO TO 800
         END IF
      END IF
C
C     ----- POSSIBLE DIIS INTERPOLATION -----
C     THE RHF ERROR MATRIX ERR = FDS-SDF IS FORMED AT -LWRK3-
C     SQUARE FORMS OF -F- AND -S- ARE HELD AT -LWRK1- AND -LWRK2-
C     IF DIIS GETS TURNED ON BY -DIIS-, ITDIIS WILL BE .GT. 1
C
      IF(DODIIS) THEN
         IF(ABINIT) THEN
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),LL2,12,0)
            CALL EXPND(X(LFAO),X(LWRK1),L1,0)
            CALL EXPND(X(LS),X(LWRK2),L1,0)
            CALL DIISER(X(LWRK1),X(LD),X(LWRK2),X(LWRK3),X(LWRK),
     *                  L1,L2,1,1)
         ELSE
            CALL EXPND(X(LFAO),X(LWRK1),L1,0)
            CALL EXPND(X(LD),X(LWRK2),L1,0)
            CALL MRARBR(X(LWRK1),L1,L1,L1,X(LWRK2),L1,L1,X(LWRK3),L1)
            CALL SUBMT(X(LWRK3),L1)
         END IF
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LQ),LL3,45,0)
         CALL DIIS(RHF,IW,ITDIIS,X(LQ),X(LFAO),DMY,X(LWRK3),DMY,
     *             X(LWRK1),X(LADIIS),X(LXDIIS),X(LPDIIS),X(LBDIIS),
     *             X(LIODII),X(LWRK),L1,L2,L3,MAXIT,MAXIT2,4*MAXDII,
     *             ERDIIS,NOTOPN,MASPRT)
      END IF
C
C     ----- DAMP AND EXTRAPOLATE THE FOCK MATRIX -----
C     DAMPD COMPUTES THE DAMP FACTOR, EXTRAP ACTUALLY DOES THE DAMPING
C     LWRK1,LWRK2,LWRK3 HOLD THE 3 PREVIOUS SYMMETRIC FOCK MATRICES
C
C     CONVERGENCE ACCELERATIONS ARE SKIPPED IF WE ARE CONVERGING
C
      IF((DAMPH.AND.ITER.GT.2)  .AND.  ITDIIS.EQ.1
     *          .AND.   .NOT.CVGING)
     *   CALL DAMPD(DELE,DELE0,DEAVG,DAMP,DENTOL,DIFF,DIFFP,DMPTLC)
      IF(DAMP .LT. DMPCUT) DAMP = DMPCUT
C
      IF((DAMPH.OR.EXTRAH)  .AND.  ITDIIS.EQ.1  .AND.  .NOT.CVGING)
     *    CALL EXTRAP(DELE,DAMP,DAMP0,X(LFAO),X(LWRK1),X(LWRK2),
     *                X(LWRK3),L1,L2,LL2,NDAFD,ITERV,1,1)
C
C     ----- OPTIONAL DIRECT ENERGY MINIMIZATION -----
C     ON RETURN, -LVEC- WILL BE THE ORBITALS FROM THE DEM SEARCH,
C     AND -LWRK1- WILL HOLD THE FOCK OPERATOR IN THAT BASIS.  THIS
C     MUST BE BROUGHT INTO AO SPACE AT -LFAO- FOR FOLLOWING STEPS.
C     LWRK2 AND LWRK3 ARE SYMMETRIC, LWRK4 IS SQUARE WORK STORAGE
C
      NUMDEM = 0
      IF(DEM  .AND.  (DIFF.GT.DEMCUT .OR. ITER.EQ.1)) THEN
         DEMOFF = .FALSE.
         RSTRCT = .TRUE.
         CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
         CALL TFTRI(X(LWRK1),X(LFAO),X(LVEC),X(LWRK),L0,L1,L1)
         CALL DEMHF(IW,OUT,EHF,EN,X(LWRK3),X(LWRK1),X(LWRK2),X(LEIG),
     *              X(LOCC),IA,X(LSCR),X(LIWRK),X(LWRK4),X(LVEC),X(LD),
     *              X(LH1),X(LS),X(LWRK5),X(LBUF),X(LIBUF),
     *              L0,L1,L2,L3,NA,NINTMX,NUMDEM,NOPK)
         CALL TFTRIB(X(LFAO),X(LWRK1),X(LS),X(LVEC),X(LWRK4),X(LSCR),
     *               L0,L1,L2,L3)
         CALL DAREAD(IDAF,IODA,X(LD),LL2,16,0)
      ELSE
         DEMOFF = .TRUE.
         RSTRCT = RSTRSV
      END IF
C
C     ----- OPTIONAL LEVEL SHIFTING -----
C     LWRK1,LWRK2 USED AS SYMMETRIC, LWRK3 AS SQUARE SCRATCH STORAGE
C
      IF(VSHIFT  .AND.  ITDIIS.EQ.1) THEN
         IF(DEMOFF) CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
         CALL LEVELS(X(LFAO),X(LS),X(LVEC),X(LWRK1),X(LWRK2),X(LWRK3),
     *               X(LWRK),L0,L1,L2,L3,ITER,NA,0,DELE,DELE0,DIFF,
     *               ITERV,1,EXTRAH,CVGING)
      END IF
C
C     ----- TRANSFORM FOCK OPERATOR TO THE -Q- MATRIX BASIS -----
C     ----- DIAGONALIZE THE CURRENT FOCK MATRIX -----
C     ----- BACK-TRANSFORM THE EIGENVECTORS TO AO BASIS -----
C     FOCK OPERATOR IN ONB FOR DIAGONALIZATION MUST BE AT -LWRK1-
C
C-------------------------------------------------------------------FLGU
C  FENG LONG GU:  MODIFY GAMESS FOR ELONGATION :  START  - 0008     FLGU
C-------------------------------------------------------------------FLGU
C
C    1. TRANSFORM F(AO)-MAT TO LMO BASIS
C
         CALL TFTRI(X(MFLMO),X(LFAO),X(LCBMA),X(MWRK1),NWM,NWA,NWA)
C
C    2. SOLVE SCF EQUATIONS
C
         CALL GLDIAG(NWM,NWM,NWM,X(MFLMO),X(MJBIG),X(MEIG),X(MVEC),
     *      IERR,X(MBIG))
C
C    3. GO TO AO BASIS FROM LMO BASIS, OBTAIN WHOLE SYSTEM C
C
        CALL MOTRAO(X(MVEC),X(LCBMA),X(LCXAL),X(MTMP),X(LVEC),
     *              NUM,NAAO,JXX,NOCC,NOCC1,NOCC2,NOCBM,ITER)
C
            IF(ELGSO) THEN
               DO I=1,NOCC2+NOCCM
                  X(LEIG+NOCC1+I-1)=X(MEIG+I-1)
               ENDDO
               DO I=1,NVAC2+NVACM
                  X(LEIG+NOCC+NVAC1+I-1)=X(MEIG+NOCC2+NOCCM+I-1)
               ENDDO
            END IF
C-------------------------------------------------------------------FLGU
C  FENG LONG GU:  MODIFY GAMESS FOR ELONGATION :  END  - 0008       FLGU
C-------------------------------------------------------------------FLGU
  800 CONTINUE
C
C     ----- OPTIONAL RESTRICTION OF ORBITAL INTERCHANGES -----
C     READ PREVIOUS ITERATION'S ORBITALS TO -LWRK1-
C
      IF(RSTRCT.OR.MFRZ) THEN
         CALL DAREAD(IDAF,IODA,X(LWRK1),LL3,15,0)
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),LL2,12,0)
         CALL OVLSEL(X(LVEC),X(LEIG),X(LWRK1),X(LS),X(LWRK2),X(LWRK),
     *               X(LIWRK),X(LWRK),L0,L1,L2)
      END IF
C
      IF(OUT) THEN
         WRITE(IW,*) 'NEW ORBITALS'
         CALL PREV(X(LVEC),X(LEIG),L0,L1,L1)
      END IF
C
C     RECOVER FROM NOCC SHIFTING
C
      IF(DOMBAS.AND.ITER.EQ.1) THEN
         DO 100 I = 1, NA
            X(LOCC+I-1) = TWO
  100    CONTINUE
      END IF
C
C     ----- FORM THE NEW DENSITY MATRIX, AND ITS MAXIMUM CHANGE -----
C     OLD DENSITY IS COPIED TO LWRK1, AS A SYMMETRIC MATRIX
C
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0009                      FLGU
C-------------------------------------------------------------------FLGU
      IF(LCUT.AND.DIRSCF) CALL DCOPY(NTOTAL,X(LDTOT),1,X(LDTWRK),1)
      CALL DCOPY(L2,X(LD),1,X(LWRK1),1)
      CALL DMTX(X(LD),X(LVEC),X(LOCC),NA,L1,L1)
      IF(LCUT) THEN
         DO 50 I=0,NUM*(NUM+1)/2-1
            IF(I.LT.NDOFF) X(LD+I)=X(LD+I) + X(LDOFF+I)
 50      CONTINUE
         CALL DENCUT(X(LD),X(LD1),X(LDTOT),NUMOLD,NFRGBS,
     .        LL2,NDIM2,NTOTAL)
      ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0009                        FLGU
C-------------------------------------------------------------------FLGU
      DIFFP = DIFF
      CALL DDIFF(X(LWRK1),X(LD),L2,DIFF)
      IF(OUT) THEN
         WRITE(IW,*) 'NEW DENSITY MATRIX'
         CALL PRTRIL(X(LD),L1)
         WRITE(IW,*) '*** END OF DEBUG OUTPUT FOR ITERATION',ITER
      END IF
C
C     THIS IS SOMETHING LEFT OVER FROM THE MINNESOTA SOLVENT CODES.
C     CALCULATE CM2 CHARGES AND REACTION FIELD
C
C-SM5-CALL CM2CHG(L1,X(LD),X(LD),1)
C
C     ----- SAVE MO-S + DENSITY + ORBITAL ENERGIES -----
C
      CALL SCFSAV(X(LVEC),X(LD),X(LEIG),NDAF,LL1,LL2,LL3)
C
C     IF DOMBAS, TRANSFORM DENSITY TO AO BASIS
C
      IF(DOMBAS) THEN
         CALL DNMOAO(X(LD),X(LWRK2),X(LVEC),X(LWRK1),X(LOCC),NA,LL1,LL2)
      END IF
C
      CALL TSECND(TITER2)
      TFOCK  = TFOCK  + (TITER1-TITER0)
      TSOLVE = TSOLVE + (TITER2-TITER1)
      IF(ITER.EQ.1) TFOCK1 = TITER1 - TITER0
      TFOCKN = TITER1 - TITER0
C
C     ----- CHECK CONVERGENCE BEHAVIOR -----
C
  700 CONTINUE
      IF(SOSCF) THEN
         ERRORC = ORBGRD
      ELSE
         ERRORC = ERDIIS
      END IF
      IF(MASPRT) THEN
         IF(DAMPH  .OR.  VSHIFT) THEN
            IF(DIRSCF) THEN
               WRITE(IW,9090) ITER,ICALP,NUMDEM,ETOT,DELE,DIFF,ERRORC,
     *                        RRSHFT,DAMP,NINT,NSCHWZ
            ELSE
               WRITE(IW,9090) ITER,ICALP,NUMDEM,ETOT,DELE,DIFF,ERRORC,
     *                        RRSHFT,DAMP
            END IF
         ELSE
            IF(DIRSCF) THEN
               WRITE(IW,9100) ITER,ICALP,NUMDEM,ETOT,DELE,DIFF,ERRORC,
     *                        NINT,NSCHWZ
            ELSE
               WRITE(IW,9100) ITER,ICALP,NUMDEM,ETOT,DELE,DIFF,ERRORC
            END IF
         END IF
      END IF
      CALL FLSHBF(IW)
C
C     WILL THIS CURE MYSTERIOUS HANG-UPS?  (IN PARALLEL RUNS)
C     IT SEEMS THAT IN MIXED NODE ENVIRONMENT ONE MAY GET SOME NODE
C     CONVERGED AND OTHERS NOT (ACTUALLY, THIS IS SUPPOSED TO HOLD
C     TRUE NOT JUST FOR GDDI BUT ANY PARALLEL RUNS). TRY JUST GDDI 1ST.
C     POSSIBLE AGGRAVATION COMES FROM MINUTE NUMERIC ERRORS DUE TO
C     ADDING SMALL/LARGE NUMBERS (FROM FMO PROJECTORS).
C     SO THE PROBLEM IS POSSIBLY ENHANCED BY (BUT NOT LIMITED TO)
C     A) RUNNING FMO
C     B) USING SMART BLAS LIBRARIES THAT MAY GIVE SLIGHTLY DIFFERENT
C        ANSWERS ON DIFFERENT CPUS.
C     ISGDDI SHOULD REALLY BE GOPARR, PERHAPS, TO GET NON-FMO RUNS.
C
      IF(ISGDDI) THEN
         CALL DDI_BCAST(2421,'F',DIFF,1,MASTER)
         CALL DDI_BCAST(2421,'F',DELE,1,MASTER)
         IF(DODIIS) CALL DDI_BCAST(2421,'F',ERDIIS,1,MASTER)
      ENDIF
C
      ICALP = ICALP+1
      CVDENS = (DIFF.LT.DENTOL  .AND.  ABS(DELE).LT.ETOL2) .OR.
     *         (DIFF.LT.DENTOL/FIVE)
      CVENGY = ABS(DELE).LT.ENGTOL  .AND.  DIFF.LT.DTOL2
      IF(DODIIS) CVDIIS = ERDIIS.LT.DIITOL  .AND.  DIFF.LT.DTOL2
      CVGED  = (CVGING  .AND.  (CVDENS.OR.CVENGY.OR.CVDIIS))
      CVGED  = CVGED  .AND.  ISWOFF.EQ.0
      IF(NDFTFG.EQ.1) CVGED = CVGED  .AND.  GRIDTYP.EQ.FINE
      CVGING = CVDENS.OR.CVENGY.OR.CVDIIS
C
      IF(ISVP.EQ.1) THEN
         CVGED  = CVGED   .AND.  CVGSVP
         CVGING = CVGING  .AND.  CVGSVP
         CVGSVPNR = DIFF  .LT.  100.0D+00 * DENTOL
         CVGSVPDN = CVGING
         CVGSVPDN1 = CVGING
      END IF
C
C         TURN ON THE DFT IF PRELIMINARY SCF IS BECOMING CONVERGED.
C
      IF(ISWOFF.GT.0.AND.DIFF.LT.SWOFF) THEN
        IF(MASWRK) WRITE(IW,9355)
        DFTTYP(3)=HFSSAV
        NDFTFG=NDFTSV
        ISWOFF=0
        IDFTSWITCH=1
      END IF
C
C         DFT MUST SWITCH TO A TIGHTER GRID AS IT NEARS CONVERGENCE.
C
      IF(NDFTFG.EQ.1.AND.DIFF.LT.SWDFT) THEN
         IF(NRAD*NPHI*NTHE.LT.NRAD0*NPHI0*NTHE0) THEN
            IF(MASPRT) WRITE(IW,9330)
            CALL SWGRID
            GRIDTYP = FINE
            CALL DFTSET(X(IGRDDFT),0,.FALSE.)
            IDFTSWITCH=2
         END IF
      END IF
      IF(DIRSCF.AND.FDIFF.AND.ABS(DELE).LT.DIRTHR.AND.ISWDIR.GT.0) THEN
        ITDIR=ITDIR+1
        IF(ITDIR.GE.NITDIR) THEN
           ITDIR=0
           IF(MASWRK) WRITE(IW,9370)
           IDFTSWITCH=3
C          THIS IS NOT REALLY A DFT SWITCH BUT IT WILL DO THE TRICK
           ISWDIR=ISWDIR-1
        ENDIF
      ELSE
        ITDIR=0
      ENDIF
C
C       SWITCH FROM DIIS TO SOSCF!
C       OBVIOUSLY SUCH SWITCH CAN BE DONE ONLY ONCE IN ANY RUN.
C       NOTE THAT DENSITY DIFFERENCING (FDIFF) NEED NOT BE RESET.
C
      IF(DODIIS  .AND.  SWDIIS.GT.0.0D+00  .AND.  DIFF.LT.SWDIIS) THEN
        ITDIIS=1
        IF(.NOT.NOTOPN) CALL RACLOS(20,'DELETE')
        NOTOPN=.TRUE.
        DODIIS=.FALSE.
        SOSCF=.TRUE.
        IF(NFG.EQ.0) MCONV = MCONV - 16 + 64
        IF(MASWRK) WRITE(IW,9380)
        IDFTSWITCH=4
      END IF
C
C         ANY SUCH SWITCH IN GRIDS OR CONVERGERS MUST RESET CONVERGERS,
C         AND PERHAPS RESET THE DIFFERENTIAL FOCK FORMATION.
C
      IF(IDFTSWITCH.NE.0) THEN
        CVGED=.FALSE.
        CVGING=.FALSE.
        CVENGY=.FALSE.
        CVDIIS=.FALSE.
        CVDENS=.FALSE.
        EXTRAH = .FALSE.
        DAMPH  = .FALSE.
        VSHIFT = .FALSE.
        DEM    = .FALSE.
        IF(DODIIS) THEN
          ITDIIS=1
          IF(.NOT.NOTOPN) CALL RACLOS(20,'DELETE')
          NOTOPN=.TRUE.
        END IF
        IF(SOSCF) ITSO=0
        IF(ABINIT .AND. DIRSCF .AND. FDIFF .AND. IDFTSWITCH.NE.4) THEN
           IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
           CALL DAWRIT(IDAF,IODA,X(LH1),LL2,14,0)
           CALL VCLR(X(LWRK1),1,L2)
        END IF
        IDFTSWITCH=0
      END IF
C
C     THIS IS SOMETHING LEFT OVER FROM THE MINNESOTA SOLVENT CODES.
C     ONCE GAS PHASE CALCULATION IS CONVERGED, ACTIVATE SOLVATION OPTION
C     AND SET ALL CONVERGENCE FLAGS TO NEGATIVE
C
C-SM5-CALL DOSOLV(CVDENS,CVENGY,CVDIIS,CVGING,CVGED,ITDIIS,ITSO)
C
C         IF WE ARE FINISHED, CANONICALIZE THE 2ND ORDER SCF ORBITALS
C
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0010                      FLGU
C-------------------------------------------------------------------FLGU
      IF(CVGED  .AND.  SOSCF) THEN
C
C    1. TRANSFORM F(AO)-MAT TO LMO BASIS
C
         CALL TFTRI(X(MFLMO),X(LFAO),X(LCBMA),X(MWRK1),NWM,NWA,NWA)
C
C    2. SOLVE SCF EQUATIONS
C
         CALL GLDIAG(NWM,NWM,NWM,X(MFLMO),X(MJBIG),X(MEIG),X(MVEC),
     *      IERR,X(MBIG))
C
C    3. GO TO AO BASIS FROM LMO BASIS, OBTAIN WHOLE SYSTEM C
C
        CALL MOTRAO(X(MVEC),X(LCBMA),X(LCXAL),X(MTMP),X(LVEC),
     *              NUM,NAAO,JXX,NOCC,NOCC1,NOCC2,NOCBM,ITER)
C
               IF(ELGSO) THEN
                  DO 80 I=1,NOCC2+NOCCM
                     X(LEIG+NOCC1+I-1)=X(MEIG+I-1)
 80               CONTINUE
                  DO 90 I=1,NVAC2+NVACM
                     X(LEIG+NOCC+NVAC1+I-1)=X(MEIG+NOCC2+NOCCM+I-1)
 90               CONTINUE
               ENDIF
         CALL DMTX(X(LD),X(LVEC),X(LOCC),NA,L1,L1)
C
         IF(LCUT) THEN
            DO 110 I=0,NUM*(NUM+1)/2-1
               IF(I.LT.NDOFF) X(LD+I)=X(LD+I) + X(LDOFF+I)
 110        CONTINUE
            CALL DENCUT(X(LD),X(LD1),X(LDTOT),NUMOLD,NFRGBS,
     .           LL2,NDIM2,NTOTAL)
         ENDIF
         CALL SCFSAV(X(LVEC),X(LD),X(LEIG),NDAF,LL1,LL2,LL3)
      END IF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0010                        FLGU
C-------------------------------------------------------------------FLGU
C
C     THE COUPLED CLUSTER PROGRAM WANTS THE FOCK MATRIX THAT
C     CORRESPONDS -EXACTLY- TO THE FINAL ORBITALS.  EVEN AT
C     CONVERGENCE THERE IS ALWAYS SOME RESIDUAL OFF-DIAGONAL
C     FOCK MATRIX ELEMENTS, SO WE MUST COMPUTE IT ONCE MORE.
C
      IF(CVGED  .AND.  CCTYP.NE.ANONE) THEN
         ICCFLG=ICCFLG+1
         IF(MASPRT) WRITE(IW,9105)
         IF(ABINIT  .AND.  DIRSCF  .AND.  FDIFF) THEN
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
            CALL DAWRIT(IDAF,IODA,X(LH1),LL2,14,0)
            CALL VCLR(X(LWRK1),1,L2)
         END IF
         GO TO 310
      END IF
  290 CONTINUE
C
      IF(CVGED) THEN
C
C     --- PCM DISPERSION INTERACTION PROCEDURE ---
C     PCM STEP 2) SOLUTE AVERAGE TRANSITION FREQUENCY
C
         IF(IPCM.EQ.1  .AND.  IDP.EQ.1  .AND.  ISD.EQ.0) THEN
C                RESET ALL CONVERGER INFORMATION
            CVGED=.FALSE.
            CVGING=.FALSE.
            CVENGY=.FALSE.
            CVDIIS=.FALSE.
            CVDENS=.FALSE.
            EXTRAH = .FALSE.
            DAMPH  = .FALSE.
            VSHIFT = .FALSE.
            DEM    = .FALSE.
            IF(DODIIS) THEN
              ITDIIS=1
              IF(.NOT.NOTOPN) CALL RACLOS(20,'DELETE')
              NOTOPN=.TRUE.
            END IF
            IF(SOSCF) ITSO=0
            IF(ABINIT .AND. DIRSCF .AND. FDIFF) THEN
               IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),LL2,11,0)
               CALL DAWRIT(IDAF,IODA,X(LH1),LL2,14,0)
               CALL VCLR(X(LWRK1),1,L2)
            END IF
C                  TURN ON THE SOLUTE TERMS
            EVAC=ETOT
            CALL WTRANSA(X(LEIG),L1)
            CALL JMATDIS(X(LS),X(LH1),X(LWRK1),X(LWRK2),X(LWRK3),L1,L2,
     *                   X(LAXYZCT),X(LAXYZCT+MXTS),X(LAXYZCT+MXTS*2),
     *                   X(LQSN))
            ISD=1
            GO TO 333
         END IF
C
C             DFT FOCK MATRIX LEFT ON DISK MUST INCLUDE EXCHANGE TERMS
         IF(NDFTFG.EQ.1.AND.ABINIT.AND.DIRSCF.AND.FDIFF) THEN
            CALL DAREAD(IDAF,IODA,X(LFAO),LL2,308,0)
            CALL DAWRIT(IDAF,IODA,X(LFAO),LL2,14,0)
         END IF
C
         IF(CVDENS) THEN
            IF(MASPRT) WRITE(IW,9110)
            GO TO 400
         END IF
         IF(CVDIIS) THEN
            IF(MASPRT) WRITE(IW,9120)
            GO TO 400
         END IF
         IF(CVENGY) THEN
            IF(MASPRT) WRITE(IW,9130)
            GO TO 400
         END IF
      END IF
C
C     ----- EXIT IN CASE OF TIME LIMIT -----
C
      CALL TSECND(TIM1)
      TLEFT = TIMLIM - TIM1
      TIM0 = TIM1
      IF(TLEFT .GT. 2.0D+00*(TLEFTS-TLEFT)/ITER) GO TO 300
      IF(CVGING) THEN
         IF(MASPRT) WRITE(IW,9140)
         GO TO 400
      ELSE
         ETOT = ZERO
         EHF = -EN
         IF(MASPRT) WRITE(IW,9150)
         GO TO 400
      END IF
  300 CONTINUE
C
C           *********************
C     ***** END OF RHF ITERATIONS *****
C           *********************
C
C     FALLING OUT OF LOOP 300 MEANS WE HAVE FAILED TO CONVERGE
C
      IF(MASPRT) WRITE(IW,9160)
      ITER = MAXIT
  350 CONTINUE
      ETOT = ZERO
      EHF = -EN
C-------------------------------------------------------------------FLGU
C  FENG LONG GU:  MODIFY GAMESS FOR ELONGATION : START - 0011       FLGU
C-------------------------------------------------------------------FLGU
C
C     BRANCH TO HERE ON SUCCESFUL CONVERGENCE
C
  400 CONTINUE
C
      IF(RUNTYP.EQ.OPTMZE) OPTELG = .TRUE.
C-------------------------------------------------------------------FLGU
C  FENG LONG GU:  MODIFY GAMESS FOR ELONGATION :   END - 0011       FLGU
C-------------------------------------------------------------------FLGU
      TFITER = TFOCK/ITER
      TSITER = TSOLVE/ITER
      IF(MASPRT  .AND.  ISD.EQ.1) THEN
          IF(DIRSCF) THEN
             WRITE(IW,9300) TFOCK,TFITER,TFOCK1,TFOCKN,TSOLVE,TSITER
          ELSE
             WRITE(IW,9310) TFOCK,TFITER,TSOLVE,TSITER
          END IF
      END IF
C
C     IF SCF IS UNCONVERGED, GRID MAY HAVE BEEN LEFT IN REVERSE ORDER.
C     WE MAY LET SCF BE UNCONVERGED HOPING IT WILL CONVERGE IN THE NEXT
C     MONOMER SCF ITERATION.
C     NOW THE PROBLEM WITH REVERSE ORDER IS THAT THE NEXT DFT RUN WILL
C     NOT RUN! (MEMORY INADEQUATE)!
C
      IF(NFG.NE.0.AND.NDFTFG.EQ.1.AND.
     *   NRAD*NPHI*NTHE.LT.NRAD0*NPHI0*NTHE0) THEN
        CALL SWGRID
        GRIDTYP = FINE
      END IF
C
C     ----- POSSIBLE AB INITIO - FRAGMENT EXCHANGE REPULSION
C
      CALL PAULIA(EEXCH)
      ETOT = ETOT + EEXCH
C
C     ----- PRINT FINAL RESULTS -----
C
      IF(MASPRT) THEN
         WRITE(IW,9170) METHOD(1:LENMTH),ETOT,ITER
         IF(DFTTYP(1).NE.0.0D+00) WRITE(IW,9320) EXENA+EXENB
         IF(NDFTFG.EQ.1) THEN
            WRITE(IW,9320) EEXC
            WRITE(IW,9325) TOTELE
            IF (NEEDTAU) WRITE(IW,9327) TOTKIN
         END IF
         IF(MPCTYP.NE.NONE  .AND.  ETOT.NE.ZERO) THEN
            DELTAH = ETOT*627.52791D+00 + ATHEAT
            WRITE(IW,9175) DELTAH
         END IF
      END IF
C
C         SOLVATION OUTPUT FOR COSMO MODEL
C
      IF(ISEPS) THEN
         IF(MP2ITER.EQ.0) THEN
         WRITE(IW,*)
         WRITE(IW,*)"**********COSMO INFORMATION**RHFCL**************"
         WRITE(IW,*)
         WRITE(IW,*)"  NUMBER OF SURFACE SEGMENTS IS ",NPS
         WRITE(IW,*)
         AREA=0.0D+00
         DO 889 I=1,NPS
            AREA=AREA+AR(I)
            WRITE(IW,'(2I4,6F10.5)') I,IATSP(I),CORZAN(1,I),CORZAN(2,I),
     *                      CORZAN(3,I),COSZAN(I),AR(I),COSZAN(I)/AR(I)
 889     CONTINUE
         WRITE(IW,*)
         WRITE(IW,*)"  TOTAL SURFACE AREA OF CAVITY (A**2)     = ",AREA
         WRITE(IW,*)
         WRITE(IW,9400)
         WRITE(IW,*)'  SECORR                       = ',SECORR
         WRITE(IW,*)'  SECORR (KCAL)                = ',
     *                 SECORR*627.517D+00
         WRITE(IW,*)'  FINAL RHF SOLUTE             = ',ETOTS
         WRITE(IW,9400)
         END IF
C
C   IF WE ARE DOING COSMO, THEN, AT THIS POINT WE NEED TO DO
C   AN EVALUATION OF THE POTENTIAL AS GAMESS SEES IT, SO THAT
C   WE CAN MAKE A CORRECTION, SINCE COSMO POTENTIAL IS A BIT
C   DIFFERENT - BUT THIS IN ONLY FOR SCF, FOR MP2 THE OCE CALCULATION
C   IS SKIPPED AND DONE IN MP2GRD
C
         EOC1=0.0D+00
         IF(MPLEVL.EQ.0) THEN
            DO 5 II=1,1082
               QVPOT(II)=0.0D+00
  5         CONTINUE
            CALL COSPOT(QVPOT)
C
C   COSPOT GAVE US V'; NOW FORM QV'
C
C  NEW START
         IF(MP2ITER.EQ.0) THEN
         WRITE(IW,*)
         WRITE(IW,*)"**********COSMO INFORMATION**RHFCL**************"
         WRITE(IW,*)
         WRITE(IW,*)"  NUMBER OF SURFACE SEGMENTS IS ",NPS
         WRITE(IW,*)
         AREA=0.0D+00
         DO 891 I=1,NPS
            AREA=AREA+AR(I)
            WRITE(IW,'(2I5,9F15.9)') I,IATSP(I),CORZAN(1,I),CORZAN(2,I),
     1CORZAN(3,I),COSZAN(I),AR(I),COSZAN(I)/AR(I),CSPOT(I),
     1QVPOT(I)*TOBOHR,CSPOT(I)/(QVPOT(I)*TOBOHR)
 891     CONTINUE
         END IF
C  NEW END
            QVCORR=0.0D+00
            DO 6 I=1,NQS
               QVCORR = QVCORR + QVPOT(I)*COSZAN(I)
  6         CONTINUE
            WRITE(IW,*)"QV (GAMESS): QVCORR = ",QVCORR
            WRITE(IW,*)"QV (COSMO) : QVCOSMO= ",QVCOSMO
            EOC1=-QVCORR+QVCOSMO
            EOC2=EOC1*627.517D+00
            CHECK2=QVCORR*QVCORR-QVCOSMO*QVCOSMO
            CHECK3=EOC1-SECORR
            WRITE(IW,*)"-QV(GAMESS)+QV(COSMO):",EOC1
            WRITE(IW,*)"POTENTIAL NORM DIFFERENCE :",CHECK2
            WRITE(IW,*)"QVCOSMO/QVGAMESS:",QVCOSMO/QVCORR
            WRITE(IW,*)"ENERGY CORRECTION:",CHECK3
         END IF
C
C   PEDIFF6 IS NOW THE 'CORRECTED' TOTAL ENERGY, INCLUDES OCE
C   CORRECTION ONLY FOR SCF
C
         PEDIFF6=ETOT+EOC1-SECORR
         ETOT=PEDIFF6
C
         WRITE(IW,9400)
         WRITE(IW,9401) PEDIFF6
 9401 FORMAT(/1X,'FINAL TOTAL ENERGY =',F20.10/)
C
         IF(MPLEVL.EQ.0) THEN
         WRITE(IW,*)"  = E(SCF) - QV(GAMESS) + QV(COSMO) - .5QV(COSMO)"
         WRITE(IW,*)
         WRITE(IW,*)"  OUTLYING CHARGE EFFECT (A.U.)      =",EOC1
         WRITE(IW,*)"  OUTLYING CHARGE EFFECT (KCAL/MOL)  =",EOC2
         ELSE
         WRITE(IW,*)"  = E(SCF) - .5QV(COSMO)"
         WRITE(IW,*)
         END IF
C
C    RESET SOME ESSENTIAL PARAMETERS:
C
         WRITE(IW,9400)
         SAVESE=SECORR
         ITRIP2=0
         USEPS=.FALSE.
         ITRIP4=0
         ITRIPO=1
         ELAST=0.0D+00
         ITERC=0
      END IF
C
C         SOLVATION OUTPUT FOR PCM MODEL
C
      IF(IPCFP) THEN
         IPCM=1
         IEFP=1
         IPCFP=.FALSE.
      END IF
C
      QTT=0.0D+00
      DO I=0,NTS-1
C        QT=QSE(I)+QSN(I)+Q_FS(I)+Q_IND(I)
         QT=X(LQSE+I)+X(LQSN+I)+X(LQFS+I)+X(LQIND+I)
         QTT=QTT+QT
      ENDDO
      IF(IPCM.EQ.1  .AND.  MASPRT) THEN
         IF(IPCMIT.EQ.1) THEN
            WRITE(IW,*) ' '
            IF(ICOMP.EQ.0) WRITE(IW,'(A10,F18.10)') 'PCM ASC=',QTT
            IF(ICOMP.EQ.2) WRITE(IW,1120) QTT,QESC
         END IF
        WRITE(IW,'(A10,F18.10)') 'GCAVP  =',GCAVP/627.509541D+00
        WRITE(IW,'(A10,F18.10)') 'GDISP  =',GDISP/627.509541D+00
        WRITE(IW,'(A10,F18.10)') 'GREP   =', GREP/627.509541D+00
      END IF
C
      IF(MASPRT  .AND.  IPCM.EQ.1  .AND.  IPCMIT.EQ.0) THEN
         WRITE(IW,*)
         WRITE(IW,*)'-- INDUCED PCM ELECTRONIC CHARGES --'
         IF(ICOMP.EQ.0) WRITE(IW,1000) QET, TCH
         IF(ICOMP.EQ.1.OR.ICOMP.EQ.2) WRITE(IW,1100) QET, TCH, QETN
         IF(ICOMP.EQ.3) WRITE(IW,1110) QET, TCH, QESC, QETN
         WRITE(IW,*)'--------------------------------------'
      END IF
C
C         SOLVATION OUTPUT FOR SVP MODEL
C
      IF(ISVP.EQ.1  .AND.  MASWRK) THEN
         CALL SVPOUT(ETOT,ECHIP,NPRINT,'RHFCL ')
      END IF
C
C         SOLVATION OUTPUT FOR ONSAGER OR EFP MODELS
C
      IF(IZRFLS .OR. IEFP.EQ.1) THEN
      IF(MASPRT) WRITE(IW,9165) TMUX,TMUXD,TMUY,TMUYD,TMUZ,TMUZD
      END IF
C
C     ----- MODIFIED VIRTUAL ORBITALS -----
C     FMO,DENSITY AT LWRK1,LWRK2 ARE SYMMETRIC MATRICES
C     -LWRK3- IS USED AS A SCRATCH SQUARE MATRIX
C     OF COURSE, THIS OPTION MAKES NO SENSE AT ALL FOR MOROKUMA RUNS.
C
      IF(MVOQ.NE.0  .AND.  RUNTYP.NE.MOROKM) THEN
         NFROZ = NA
         CALL MVOS(X(LVEC),X(LEIG),X(LFAO),X(LWRK1),X(LSCR),
     *             X(LIWRK),X(LWRK3),X(LWRK2),X(LBUF),X(LIBUF),
     *             X(LDSH),X(LGHOND),X(LDDIJ),X(LXINTS),
     *             DIRSCF,SCHWRZ,NOPK,NINTMX,INTTYP,
     *             L0,L1,L2,L3,NSH2,MAXG,NFROZ,MVOQ,NE)
      END IF
C
C     --- GENERAL CORRELATION ADAPTED VIRTUAL ORBITALS ---
C     STORE SYMMETRIC -DCORE-, -DVAL- AT -WRK1-, WRK2-
C     STORE SYMMETRIC -JCORE-, -JVAL- AT -FAO-, -D-
C     STORE SQUARE -Q- MATRIX AT -WRK3-
C     BUT WE STILL NEED TWO ADDITIONAL SYMMETRIC MATRICS.
C
      IF(IACAVO.EQ.1  .AND.  RUNTYP.NE.MOROKM) THEN
         NFROZ = NA
         TDSKWRK = DSKWRK
         DSKWRK  = .TRUE.
         CALL ACAVO(PACAVO,X(LVEC),X(LEIG),X(LWRK1),X(LWRK2),
     *              X(LFAO),X(LD),X(LKCORE),X(LKVAL),
     *              X(LWRK3),X(LSCR),X(LIWRK),X(LBUF),X(LIBUF),
     *              NOPK,NINTMX,L0,L1,L2,L3,NFROZ)
         DSKWRK = TDSKWRK
      END IF
C
C     ----- ASSIGN SYMMETRY LABELS, AND PRINT FINAL RESULTS -----
C     -SYMBMO- AT X(LWRK)
C     NOTE THAT THE CALL TO SYMMOS WILL DESTROY THE -Q- MATRIX
C
      CALL DAREAD(IDAF,IODA,X(LVEC),LL3,15,0)
      CALL DAREAD(IDAF,IODA,X(LD)  ,LL2,16,0)
      CALL DAREAD(IDAF,IODA,X(LEIG),LL1,17,0)
      IF(MINMEM) THEN
         CALL DAREAD(IDAF,IODA,X(LS),LL2,12,0)
         CALL DAREAD(IDAF,IODA,X(LQ),LL3,45,0)
      END IF
      CALL SYMMOS(X(LWRK),X(LQ),X(LS),X(LVEC),X(LSCR),L0,L1,L0,L1)
      CALL DAWRIT(IDAF,IODA,X(LWRK),LL1,255,1)
C
      IF(SOME.AND.(RUNTYP.NE.MOROKM)) THEN
         CALL PRSELMO(X(LVEC),X(LEIG),X(LWRK),L0,L1,L1)
      END IF
      IF(PRDENS) THEN
         WRITE(IW,9190)
         CALL PRTRIL(X(LD),L1)
      END IF
C
C        ----- PUNCH THE ORBITALS -----
C
      IF(MPUNCH.GT.0 .AND. MASPRT) THEN
         CALL TMDATE(TIMSTR)
         IF(NFG.NE.0) THEN
            WRITE(IP,8005) TIMSTR,ICURFG,JCURFG,KCURFG,METHOD(1:LENMTH),
     *                     ETOT,EN,ITER
         ELSE
            WRITE(IP,8000) TIMSTR,TITLE,METHOD(1:LENMTH),ETOT,EN,ITER
         ENDIF
         LPUN = NA
         IF(MPUNCH .EQ. 2) LPUN = L0
         WRITE(IP, FMT='(5H $VEC)')
         CALL PUSQL(X(LVEC),LPUN,L1,L1)
         WRITE(IP, FMT='(5H $END)')
      END IF
C
C     IF MFRZ WE COMPUTE THE LAGRANGIAN FOR THE GEOMETRY OPTIMIZATION
C     USING THE NON-ZEROED FOCK MATRIX IN AO BASIS
C
      IF(MFRZ) THEN
          CALL DAREAD(IDAF,IODA,X(LWRK1),LL2,317,0)
          CALL RHFLAG(X(LWRK1),X(LD),X(LWRK2),X(LWRK),L1,L2,L3,OUT)
          CALL DAWRIT(IDAF,IODA,X(LWRK2),LL2,36,0)
      END IF
C
C     ----- TIDY UP AND EXIT -----
C
  500 CONTINUE
      IF(CVGED) IREST = 0
C
      IF(FT15OP) CALL SEQCLO(NFT15,'DELETE')
      FT15OP=.FALSE.
      IF(.NOT.NOTOPN) CALL RACLOS(20,'DELETE')
      NOTOPN=.TRUE.
C
C     SAVE FMM DATA FOR DERIVATIVE CALCULATIONS
C
      IF (QFMM) THEN
         CALL DERCHK(NDER)
         IF (NDER.GT.0) THEN
            CALL DENWZP(RHF,NCXYZ,X(LIYP),X(LINDX2),
     *         X(LIDXIJK),X(LIDXWS),X(LCXYZ),X(LIBS),X(LYZTBL),NTMPL,
     *         X(LYP),X(LZP),L2,X(LD),DUMMY,NTBOX,MAXWS,X(LYZPNT),
     *         X(LF),X(LG),X(LZLL),X(LCLM),X(LFLM),X(LIDXBOX),NSBOX,
     *         X(LISP),X(LIPP))
           CALL SHLDEN(RHF,X(LD),DUMMY,DUMMY,X(LDSH),IA,L1,L2,NSH2,1)
            CALL WRTFMM(X(LYP),X(LZP),NP,NTMPL,NCXYZ,X(LIYP),
     *         X(LINDX2),X(LIDXIJK),X(LIDXWS),X(LIBS),
     *         X(LYZTBL),NTBOX,MAXWS,X(LYZPNT),X(LCLM),
     *         X(LIDXBOX),NSBOX,X(LISP),X(LIPP),X(LEBOX),
     *         X(LMBOX),X(LINDX),X(LNUMWS),X(LDSH),X(LSLIST),
     *         X(LIDXSHL),X(LSLN),X(LXINTS),NSHELL,NSH2,NSHL2,NS)
         END IF
      END IF
      CALL RETFM(NEED)
C
      IF(RUNTYP.EQ.MOROKM) CALL EDRHF(NUM,NA,NB,NE,E0)
C
      IF(MASPRT)
     *   WRITE(IW,FMT='('' ...... END OF RHF CALCULATION ......'')')
      CALL TIMIT(1)
      RETURN
C
 8000 FORMAT('--- CLOSED SHELL ORBITALS --- GENERATED AT ',3A8/10A8/
     *       'E(',A,')=',F20.10,', E(NUC)=',F16.10,',',I5,' ITERS')
 8005 FORMAT('--- CLOSED SHELL ORBITALS --- GENERATED AT ',3A8/,
     *       'FMO ORBITALS',3I6/,
     *       'E(',A,')=',F20.10,', E(NUC)=',F16.10,',',I5,' ITERS')
C
 9000 FORMAT(/10X,26(1H-)/10X,A10,' SCF CALCULATION'/10X,26(1H-))
 9005 FORMAT(/1X,'OVERLAPPING STORAGE FOR H,S,Q MATRICES,',
     *        1X,'TO SAVE',I10,' WORDS.'/1X,'ADDING THIS AMOUNT',
     *        1X,'MAY IMPROVE EFFICIENCY SOMEWHAT.')
 9006 FORMAT(1X,'* * * ERROR * * *'/
     *       1X,'IT IS ILLOGICAL FOR THE GRID SWITCHING VALUE',
     *          ' $DFT SWITCH=',1P,E7.1/
     *       1X,'    TO BE SMALLER THAN THE DENSITY CONVERGEN',
     *          'CE $SCF CONV=',1P,E7.1)
 9007 FORMAT(5X,'NUCLEI-NUCLEAR POLARIZATION CHARGE INTERACTION = '
     *         ,F20.10,/
     *      ,5X,'TOTAL NUCLEAR ENERGY                           = '
     *         ,F20.10)
 9010 FORMAT(/5X,'NUCLEAR ENERGY = ',F20.10/
     *       5X,'MAXIT =',I5,5X,'NPUNCH=',I5/
     *       5X,'EXTRAP=',L1,'  DAMP=',L1,'  SHIFT=',L1,
     *          '  RSTRCT=',L1,'  DIIS=',L1,'  DEM=',L1,'  SOSCF=',L1)
 9012 FORMAT(5X,'DENSITY MATRIX CONV=',1P,E10.2)
 9013 FORMAT(5X,'      DENSITY MATRIX CONV=',1P,E10.2/
     *       5X,'DFT GRID SWITCH THRESHOLD=',1P,E10.2/
     *       5X,' DFT SWITCH OFF THRESHOLD=',1P,E10.2)
 9015 FORMAT(5X,'VTSCAL=',L1,'  MAXVT=',I3,'  VTCONV=',F12.8)
 9017 FORMAT(5X,'SOSCF WILL OPTIMIZE',I8,' ORBITAL ROTATIONS, SOGTOL=',
     *          F8.3)
 9020 FORMAT(5X,'MEMORY REQUIRED FOR RHF STEP=',I10,' WORDS.')
 9030 FORMAT(/1X,'DIRECT SCF CALCULATION, SCHWRZ=',L1,'   FDIFF=',L1,
     *       ',  DIRTHR=',E10.2,' NITDIR=',I2)
 9035 FORMAT(1X,'QFMM WILL USE ADDITIONAL MEMORY OF',I10,' WORDS')
 9039 FORMAT(/1X,'THE BUFFER ZONE DENSITY WILL BE EXCLUDED FROM THE ',
     *        'INTERACTION WITH THE EFP')
 9040 FORMAT(/' ITER EX DEM    TOTAL ENERGY       E CHANGE  DENSITY ',
     *        'CHANGE     ORB. GRAD      VIR. SHIFT       DAMPING')
 9050 FORMAT(/115X,'NONZERO     BLOCKS'/
     *        ' ITER EX DEM     TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE     ORB. GRAD      VIR. SHIFT       DAMPING',
     *        '        INTEGRALS    SKIPPED')
 9045 FORMAT(/' ITER EX DEM     TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    DIIS ERROR      VIR. SHIFT       DAMPING')
 9055 FORMAT(/115X,'NONZERO     BLOCKS'/
     *        ' ITER EX DEM     TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    DIIS ERROR      VIR. SHIFT       DAMPING',
     *        '        INTEGRALS    SKIPPED')
 9060 FORMAT(/' ITER EX DEM     TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE     ORB. GRAD')
 9070 FORMAT(/83X,'NONZERO     BLOCKS'/
     *        ' ITER EX DEM     TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE     ORB. GRAD      INTEGRALS    SKIPPED')
 9065 FORMAT(/' ITER EX DEM     TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    DIIS ERROR')
 9075 FORMAT(/83X,'NONZERO     BLOCKS'/
     *        ' ITER EX DEM     TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    DIIS ERROR      INTEGRALS    SKIPPED')
 9080 FORMAT(/8H EHF1 = ,F20.12,8H EHF2 = ,F20.12,7H EHF = ,F20.12)
 9090 FORMAT(1X,3I3,F20.10,F17.10,2F14.9,2F16.9,I15,I11)
 9100 FORMAT(1X,3I3,F20.10,F17.10,2F14.9,I15,I11)
 9105 FORMAT(/1X,'RHF HAS CONVERGED, NOW COMPUTING THE EXACT FOCK',
     *           ' MATRIX FOR USE'/
     *        1X,'DURING THE COUPLED CLUSTER CALCULATION THAT FOLLOWS.')
 9110 FORMAT(/10X,17(1H-)/10X,17HDENSITY CONVERGED/10X,17(1H-))
 9120 FORMAT(/10X,14(1H-)/10X,14HDIIS CONVERGED/10X,14(1H-))
 9130 FORMAT(/10X,16(1H-)/10X,16HENERGY CONVERGED/10X,16(1H-))
 9140 FORMAT(/1X,'... SCF HAS ALMOST CONVERGED BUT ROUTINE STOPPED',
     *           ' FOR TIMLIM BEFORE ULTIMATE CYCLE ...')
 9150 FORMAT(/1X,'SCF IS UNCONVERGED, TOO LITTLE TIME LEFT')
 9160 FORMAT(/1X,'SCF IS UNCONVERGED, TOO MANY ITERATIONS')
 9165 FORMAT(/10X,'INDUCED DIPOLE',5X,'ATOMIC UNITS',10X,'DEBYE',
     *       /10X,'      X(IND)  ',5X,F12.5,5X,F12.5,
     *       /10X,'      Y(IND)  ',5X,F12.5,5X,F12.5,
     *       /10X,'      Z(IND)  ',5X,F12.5,5X,F12.5)
 9170 FORMAT(/1X,'FINAL ',A,' ENERGY IS',F20.10,' AFTER',I4,
     *           ' ITERATIONS')
 9175 FORMAT(/1X,'HEAT OF FORMATION IS',F15.5,' KCAL/MOL')
 9190 FORMAT(/10X,14(1H-)/10X,14HDENSITY MATRIX/10X,14(1H-))
 9200 FORMAT(10X,15(1H-),'START SECOND ORDER SCF',15(1H-))
 9300 FORMAT(5X,'TIME TO FORM FOCK OPERATORS=',F10.1,' SECONDS (',
     *          F10.1,' SEC/ITER)'/
     *       5X,'FOCK TIME ON FIRST ITERATION=',F10.1,
     *          ', LAST ITERATION=',F10.1/
     *       5X,'TIME TO SOLVE SCF EQUATIONS=',F10.1,' SECONDS (',
     *          F10.1,' SEC/ITER)')
 9310 FORMAT(5X,'TIME TO FORM FOCK OPERATORS=',F10.1,' SECONDS (',
     *          F10.1,' SEC/ITER)'/
     *       5X,'TIME TO SOLVE SCF EQUATIONS=',F10.1,' SECONDS (',
     *          F10.1,' SEC/ITER)')
 9320 FORMAT(1X,'DFT EXCHANGE + CORRELATION ENERGY = ',F20.10)
 9325 FORMAT(1X,'TOTAL ELECTRON NUMBER             = ',F20.10)
 9326 FORMAT(/10X,'TOTAL KINETIC ENERGY DENSITY      = ',F20.10,1X/)
 9327 FORMAT(1X,'TOTAL KINETIC ENERGY DENSITY      = ',F20.10,1X)
 9330 FORMAT(1X,'DFT CODE IS SWITCHING BACK TO THE FINER GRID')
 9340 FORMAT(/1X,'DFT CODE IS SWITCHING FROM',3I3,' TO THE COARSER GRID'
     *          ,3I3)
 9350 FORMAT(1X,'DFT IS SWITCHED OFF, PERFORMING PURE SCF UNTIL SWOFF',
     *          ' THRESHOLD IS REACHED.')
 9355 FORMAT(1X,'CONVERGED TO SWOFF, SO DFT CALCULATION IS NOW',
     *          ' SWITCHED ON.')
 9370 FORMAT(1X,'ENERGY IS NOT DECREASING: FOCK MATRIX WILL BE ',
     *          'RECOMPUTED.')
 9380 FORMAT(9X,'SWDIIS THRESHOLD HAS BEEN REACHED:',
     *          ' SWITCHING DIIS OFF.')
 9400 FORMAT(2X,'***************************************************',
     *   '**************')
C
 1000 FORMAT(1X,'CALCULATED ',F10.5,' THEORETICAL ',
     * F10.5,' NOT RENORMALIZED',F10.5)
 1100 FORMAT(1X,'CALCULATED ',F10.5,' THEORETICAL ',
     * F10.5,' RENORMALIZED',F10.5)
 1110 FORMAT(1X,'CALCULATED',F10.5,' (THEOR= ',
     * F10.5,')  ESCAPED',F10.5,' FINAL', F10.5)
 1120 FORMAT(2X,'PCM ASC=',F18.10,' ( UNNORMALIZED=',F18.10,' )')
      END
C
C*MODULE ELGSCF  *DECK UHFELG
      SUBROUTINE UHFELG(SZ,S2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PACK2E,DBG,SOME,PRDENS,GOPARR,DSKWRK,MASWRK,TDSKWRK,
     *        MASPRT,CVGED,CVGING,CVDENS,CVENGY,CVDIIS,EXTRAH,DAMPH,
     *        CVGSVP,CVGSVPDN,CVGSVPDN1,CVGSVPNR,
     *        VSHIFT,RSTRCT,DODIIS,DIRSCF,FDIFF,SCHWRZ,NOTOPN,
     *        ABINIT,MINMEM,MFRZ,VTSCAL,VIROK,LVCLN,IZRFLS,
     *        SOSCF0,SOSCF,EIGAVL,FT15OP,SWGROK,QOPS,QFMM,SHLOUT,
     *        IPCFP,NEEDTAU,PRTTAU,SG1
      CHARACTER*11 METHOD
C
      DIMENSION TIMSTR(3),ASAVE(3),BSAVE(3)
      DIMENSION NSBOX(20)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXGSH=30, MXG2=MXGSH*MXGSH,
     *           MXATM=2000, MXFRG=1050, MXAO=8192, MXCAV=5810,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12, MXGRID=10)
      PARAMETER (NUMRA=23)
C
      COMMON /ACONV / RRSHFT,EXTTOL,DMPTOL,VSHTOL,IEXTIN
      COMMON /ATHEAT/ ATHEAT
      COMMON /CONV  / DENTOL,EN,ETOT,EHF,EHF0,DIFF,ITER,ICALP,ICBET
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,BSLRD(137),NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0,
     *                NANGPT(MXGRID),NANGPT0(MXGRID),SG1
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /DIISSO/ SOGTOL,ETHRSH,MAXDII,IRAF
      COMMON /DMPING/ SHIFTO,SHIFTV,DMPCUT,SWDIIS,DIRTHR
      COMMON /EFPBUF/ POLCHG(10),NBUFMO,LBUFF(MXAO),LBF,NAPOL,IAPOL(10)
      COMMON /FMCOM / X(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMOOPT/ ESPSCA(9),RESPAP(2),RESPPC(2),RESDIM,RESTRI(4),
     *                RCORSD,RESPCT,CONVFG,CNVDMP,COROFF,IXESP,MXITFG,
     *                NGUESS,NBSSE,MODORB,MODPAR,IRSTSTP,IRSTLAY,NPRFMO,
     *                NFMOPAL,MODPRP,MAXL1C,IPIEDA,MODGRD,MODESP,IVMUL
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /FUNCT / ENERGY,EGRAD(3,MXATM)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INDDIP/ TMUX,TMUY,TMUZ,TMUXD,TMUYD,TMUZD,MINMEM
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /METGGA/ NEEDTAU,PRTTAU
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
      COMMON /MOLMEC/ HTYPE(4),NHCO(4,200),NNHCO,ITYPE
      COMMON /MPCGEO/ GEO(3,MXATM)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHMP,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /N2ELCT/ N2EL
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCMCHG/ PB,PX,PC,UNZ,QNUC,FN,FE,UNZOR,PORT
      COMMON /PCMDIM/ MXSP,MXTS,MEMPCM1,MEMPCM2,NTS
      COMMON /PCMITR/ RCUT(2),THRES,IPCMIT,IMUL,MXDIIS,NREG,MXITR1,
     *                MXITR2,MODPAP
      COMMON /PCMOPT/ RABI,RASC,REFPOL,THRSLS,DENSLS,WB,WA,ETA2,GD,EVAC,
     *                RHOW,PM,AREATL,AREAKP,BONDRY,OMEGA,RET,FRO,EPSINF,
     *                EPS,DR,RSOLV,VMOL,TCE,STEN,DSTEN,CMF,TABS,IDIRCT,
     *                IPCDER,IDP,ICOMP,IFIELD,ICAV,IDISP,IPRINT,IRETCAV,
     *                ICENT,IFAST,NEVAL,IEFPOL,KEEPSM,IMGABI,IMGASC,NADD
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEF,IP_F,NFMOPCM
      COMMON /PCMPNT/ LXYZRE,LSSFE,LLIST,LALPCM,LRINPCM,LINAPCM,LINFPCM,
     *                LINIPCM,LMEPCM,LAXYZCT,LXYZCT2,LNVERT,LQSN,LQSE,
     *                LQFS,LQIND,LISPHE,LVAD,LQOR,LVECMUL,LAIPRJ,LFIPRJ
     *                ,LPEL
      COMMON /PCMPRT/ GCAVP,GCAVS,GDISP,GREP,EHFGAS
      COMMON /QMFM  / SIZE,EPSLN,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
      COMMON /FMMDER/ MAXWS, NTBOX,NCXYZ, NTMPL,MAXNYP
      COMMON /QFMMRA/IORA(NUMRA),IQRAF,MIJKL
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,NPREO(4)
      COMMON /SCFWFN/ AROHF(3),BROHF(3),PACAVO(6),IACAVO,IUHFNO,MVOQ
      COMMON /SHLT  / SHLTOL,CUTOFF,ICOUNT,SHLOUT
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /SVPSCM/ IADDR_SVP,ILAST_SVP
      COMMON /SVPNRG/ ATMSVP,ELCSVP,SVPSVP,SURSVP,VOLPLM,VOLSVP,RXNSVP
      COMMON /SVPOPT/ ISVP,NSVP
      COMMON /SVPTGR/ NVLPL,MTHSVP,IQORP,NSTAGE,IOPPRD,IRENRM,ISHAPE,
     *                ITRCAV,NDRCAV,ICVICK,IFRQUP,IRDRF,IONSTR,
     *                INTCAV,NPTLEB,NPTTHE,NPTPHI,IROTGR,ITRNGR,
     *                ICRD,LINEQ,IPNRF,IPRRF,IPNDN,IPRDN,IEX
      COMMON /SVPPAR/ CAVC(3,MXCAV),CAVW(MXCAV),CAVQ(MXCAV),
     1                CAVN(3,MXCAV),SPHW(MXCAV),CAVP(MXCAV),
     2                CENCAV(3),RNTCAV(3),NCAV,IQP
      COMMON /VIRIAL/ SCALTE,SCALTT,GVIR,VTCONV,MAXVT,VTSCAL,VIROK,LVCLN
      COMMON /ZRFPAR/ GZRF,FIND(3),GNUCF,EBORN,DIELEC,IZRF,ICALC
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00,
     *           FIVE=5.0D+00, TEN=1.0D+01,
     *           PT2=0.2D+00, TWOPT2=2.2D+00,
     *           ETOL=1.0D-09, HALF=5.0D-01, DMPTLC=1.0D-02)
C
      SAVE FT15OP
C
      DATA FT15OP/.FALSE./
C
      DATA CHECK/8HCHECK   /, DEBUG/8HDEBUG   /, DBUGME/8HUHFOP   /
      DATA ROHF/8HROHF    /, UHF/8HUHF     /
      DATA RMP,ZAPT/8HRMP     ,8HZAPT    /
      DATA OPTMZE/8HOPTIMIZE/, HESS/8HHESSIAN /
      DATA NONE,ANONE/4HNONE,8HNONE    /
      DATA COARSE,FINE/8HCOARSE  ,8HFINE    /
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0001                      FLGU
C-------------------------------------------------------------------FLGU
      COMMON /ELGFLS /NEG0,NEG1,NEG2,NEG3,NEG4,NEG5,NEG6,NEG7,NEG8,NEG9
      COMMON /ELGPMT/ NELONG,NATMM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      COMMON /ELGINF/ NAAO,NCUTP,NCUT,NCUTT,NLATOT,NLBTOT,NLA,NLB,
     *                IMOCUT,IMOCUTT,NWA,NWM,NWMT,NHB
      PARAMETER (MXSTP=500)
      DIMENSION NFZOC(MXSTP),NFZVT(MXSTP),NFZOCB(MXSTP),NFZVTB(MXSTP)
      DIMENSION NFZATM(MXSTP)
      LOGICAL LCUT,ELGSO
      COMMON /ELGIDX/ LCUT
      COMMON /OLDPAR/ NUMOLD,NATOLD,NSHOLD,ISOLD
      COMMON /NEWPAR/ NUMNEW,NATNEW,NSHNEW,ISNEW
      COMMON /ELGFRF/ NOCCA,NOCAA,NVCAA
      ELGSO=.FALSE.
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0001                        FLGU
C-------------------------------------------------------------------FLGU
C
C     ----- UNRESTRICTED HF-SCF CALCULATION -----
C     J.A.POPLE AND R.K.NESBET   J.CHEM.PHYS. 22, 571 (1954)
C     ----- HIGH SPIN RESTRICTED OPEN SHELL HF-SCF CALCULATION -----
C     M.F.GUEST AND V.SAUNDERS   MOL.PHYS. 28, 819 (1974)
C
      ABINIT = MPCTYP.EQ.NONE
C
      IF(SCFTYP.EQ.UHF) THEN
         METHOD='UHF        '
         IF(DFTYPE.NE.ANONE)
     *      WRITE(UNIT=METHOD,FMT='(''U-'',A8,'' '')') DFTYPE
         IF(MPCTYP.NE.NONE)
     *      WRITE(UNIT=METHOD,FMT='(''U-'',A4,''     '')') MPCTYP
      ELSE
         METHOD='ROHF       '
         IF(DFTYPE.NE.ANONE)
     *        WRITE(UNIT=METHOD,FMT='(''RO-'',A8)') DFTYPE
         IF(MPCTYP.NE.NONE)
     *      WRITE(UNIT=METHOD,FMT='(''RO-'',A4,''    '')') MPCTYP
      END IF
      LENMTH = LSTRNG(METHOD,11)
C
      IZRFLS = IZRF.NE.0
C
      DBG    = NPRINT.EQ. 5   .AND.   MASWRK  .AND.  NPRTGO.NE.2
      SOME   = NPRINT.NE.-5   .AND.   MASWRK  .AND.  NPRTGO.NE.2
      PRDENS = NPRINT.GT. 8   .AND.   MASWRK  .AND.  NPRTGO.NE.2
      MASPRT = MASWRK  .AND.  NPRTGO.NE.2 .AND.
     *   (NFG.EQ.0.OR.IAND(NPRFMO,3).LE.1)
      IF(EXETYP.EQ.DEBUG  .OR.  EXETYP.EQ.DBUGME) THEN
         DBG    = .TRUE. .AND. MASWRK
         SOME   = .TRUE. .AND. MASWRK
         PRDENS = .TRUE. .AND. MASWRK
      END IF
C
      IF(MASPRT.AND.(NFG.EQ.0.OR.NPRINT.NE.-5))
     *   WRITE(IW,9000) METHOD(1:LENMTH)
C
C           START SCF CLOCK
C
      TIM0 = ZERO
      TIM1 = ZERO
      CALL TSECND(TIM0)
      TLEFTS = TIMLIM - TIM0
C
      EXTRAH = MOD(MCONV,2)  .EQ. 1
      DAMPH  = MOD(MCONV,4)  .GE. 2
      VSHIFT = MOD(MCONV,8)  .GE. 4
      RSTRCT = MOD(MCONV,16) .GE. 8
      DODIIS = MOD(MCONV,32) .GE.16
      SOSCF0 = MOD(MCONV,128).GE.64
      SOSCF  = SOSCF0 .OR.  SWDIIS.GT.0.0D+00
C
      L0 = NQMT
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
      MAXIT2=(MAXIT*MAXIT+MAXIT)/2
C
      NSH2 = (NSHELL*NSHELL+NSHELL)/2
C
C     ----- GET MEMORY -----
C
      IFUHF = 1
      IF(SCFTYP.EQ.ROHF) IFUHF=0
      IFPK  = 1
      IF(NOPK.EQ.1) IFPK=0
C
      CALL VALFM(LOADFM)
      CALL GOTFM(NGOTMX)
      LSCR  = LOADFM + 1
      LIWRK = LSCR   + 8*L1
      LWRK1 = LIWRK  + L1
      LWRK2 = LWRK1  + MAX(L2,L3)
      LWRK3 = LWRK2  + MAX(L2,L3)
      LWRK4 = LWRK3  + MAX(L2,L3)
      LAST  = LWRK4  + MAX(L2,L3)
C
      LVA   = LAST
      LDA   = LVA    + L3
      LFA   = LDA    + L2
      LEA   = LFA    + L2
      LAOC  = LEA    + L1
      LVB   = LAOC   + L1
      LDB   = LVB    + L3 * IFUHF
      LFB   = LDB    + L2
      LEB   = LFB    + L2
      LBOC  = LEB    + L1 * IFUHF
      LAST  = LBOC   + L1
C
      IF(SCFTYP.EQ.ROHF) THEN
         LVB = LVA
         LEB = LEA
      END IF
C
      CALL BASCHK(LMAX)
                    NANGM =  4
      IF(LMAX.EQ.2) NANGM =  6
      IF(LMAX.EQ.3) NANGM = 10
      IF(LMAX.EQ.4) NANGM = 15
      IF(LMAX.EQ.5) NANGM = 21
      IF(LMAX.EQ.6) NANGM = 28
      MAXG = NANGM**4
C
      MINTMX=NINTMX
      IF(NINTIC.NE.0) MINTMX=0
C
C     MEMORY IS ALLOCATED ELSEWHERE
C     FANCY OPTIONS (LOOK FOR NINTMX BELOW) WILL NOT WORK WITH IN
C     CORE INTEGRAL STORAGE
C
      IF(ABINIT) THEN
         IF(DIRSCF) THEN
            LXP   = LAST
            LXK   = LAST
            LIXPK = LAST
            LXINTS= LAST
            LGHOND= LXINTS + NSH2
            LDSH  = LGHOND + MAXG
            LDDIJ = LDSH   + NSH2
            LAST  = LDDIJ  + 49*MXG2
         ELSE
            LXP   = LAST
            LXK   = LXP    + MINTMX
            LIXPK = LXK    + MINTMX * IFPK
            LAST  = LIXPK  + MINTMX
            LXINTS= LAST
            LGHOND= LAST
            LDSH  = LAST
            LDDIJ = LAST
         END IF
         IF(NINTIC.NE.0) THEN
            LXP  = LBUFPIC
            LIXPK= LIXIC
         END IF
         LTWOEI = LAST
         LPTOT2 = LAST
      ELSE
         LXP   = LAST
         LXK   = LAST
         LIXPK = LAST
         LAST  = LAST
         LXINTS= LAST
         LGHOND= LAST
         LDSH  = LAST
         LDDIJ = LAST
         LTWOEI= LAST
         LPTOT2= LTWOEI + N2EL
         LAST  = LPTOT2 + NAT*16
      END IF
C
      IF(DODIIS) THEN
         LADIIS = LAST
         LBDIIS = LADIIS + MAXDII*MAXDII
         LPDIIS = LBDIIS + MAXIT2
         LXDIIS = LPDIIS + MAXIT
         LIODII = LXDIIS + MAXIT
         LAST   = LIODII + 4*MAXDII
      ELSE
         LADIIS = LAST
         LBDIIS = LAST
         LPDIIS = LAST
         LXDIIS = LAST
         LIODII = LAST
      END IF
C
C     -- SET UP COMBINED EFP/PCM
C
      IF(IPCM.EQ.1 .AND. IEFP.EQ.1) THEN
         IPCM=0
         IEFP=0
         IPCFP=.TRUE.
      ELSE
         IPCFP=.FALSE.
      END IF
C
C     -- MEMORY FOR SOLVATION METHODS
C        THE ORDER MUST BE PCM, EFP, PCM/EFP.
C
      CALL PCMMEM3(IPCFP,L2,LAST,NTSPAR,LSOL,LCHG,LDMATM,LQPOT,LQFLD,
     *             LVPOT,LSE,LDE,LQ0,LQ1,LQ2,LQ3,LD0,LQA,LDIMAT,LQREP,
     *             LTMP0,LTMP1,LTMP2,LIPVT,LPOTTMP,LRMUL,LCHG2,
     *             LASCCRD,LASCCHG,LASCDIP,LASCQAD,LDISV,LDIS1,LDIS2,
     *             LCQEF,LQEFF,LELD,LXDINT,LYDINT,LZDINT,LEFLD,MADD,
     *             LABFLD,LVECMP,LVEC_2,LVEC_S,LAPROJ,LFPROJ)
C
      IF((IZRFLS .OR. IEFP.EQ.1 .OR. IPCFP)
     *    .AND. (DIRSCF.AND.FDIFF)) THEN
         NDIPER = LAST
         LDIPER = NDIPER  + L2
         LAST   = LDIPER  + L2
      ELSE
         NDIPER = LAST
         LDIPER =LAST
      END IF
C
C         MEMORY FOR SVP SOLVENT MODEL
C
      IF(ISVP.EQ.1) THEN
         NOPER=2
         IF(IQP.EQ.0.AND.MTHSVP.EQ.1) NOPER=1
         LENSVP=10*NCAV+NOPER*NCAV**2
         LSVP=LAST
         LAST=LSVP+LENSVP
      ELSE
         LSVP=LAST
         LENSVP=0
      END IF
C          AND A COUPLE OF INITIALIZATIONS FOR -SVP- MODEL
      IUPRXN = -1
      IF(ISVP.EQ.1) FDIFF=.FALSE.
C
C         FOR SOSCF CONVERGER
C
      NFT15=15
      NFT16=16
      NPRA=(L0-NA)*NA
      NPRB=(L0-NB)*NB
      NPRO=NPRA+(NA-NB)*NB
      ITSO=0
      ORBGRD=ZERO
      IF(SCFTYP.EQ.UHF) THEN
         IF(SOSCF) THEN
            LGRADA = LAST
            LHESSA = LGRADA + NPRA
            LPGRADA= LHESSA + NPRA
            LDISPLA= LPGRADA+ NPRA
            LGRADB = LDISPLA+ NPRA
            LHESSB = LGRADB + NPRB
            LPGRADB= LHESSB + NPRB
            LDISPLB= LPGRADB+ NPRB
            LAST = LDISPLB+ NPRB
         ELSE
            LGRADA = LAST
            LHESSA = LAST
            LPGRADA= LAST
            LDISPLA= LAST
            LGRADB = LAST
            LHESSB = LAST
            LPGRADB= LAST
            LDISPLB= LAST
         END IF
      END IF
      IF(SCFTYP.EQ.ROHF) THEN
         IF(SOSCF) THEN
            LGRADA = LAST
            LGRADB = LGRADA+ NPRA
            LGRADO = LGRADB+ NPRB
            LHESSO= LGRADO + NPRO
            LPGRADO= LHESSO + NPRO
            LDISPLO= LPGRADO+ NPRO
            LAST = LDISPLO+ NPRO
         ELSE
            LGRADA = LAST
            LGRADB = LAST
            LGRADO = LAST
            LHESSO = LAST
            LPGRADO= LAST
            LDISPLO= LAST
         END IF
      END IF
C
C     ----- FOR QFMM -----
C
      IF (QFMM) THEN
         CALL INITPRMT(NCXYZ,1)
         NSHL2=NSHELL*NSHELL
         IF (NCXYZ.LT.NUMRD) NUMRD=NCXYZ-1
         LCXYZ= LAST
         LIYP = LCXYZ    + NCXYZ*3
         LIBS = LIYP     + NCXYZ/NWDVAR+1
         LISP = LIBS     + NCXYZ*4/NWDVAR
         LIPP = LISP     + NCXYZ*2/NWDVAR
         LIDXWS = LIPP   + NCXYZ*2/NWDVAR
         LIDXIJK= LIDXWS + NCXYZ/NWDVAR+1
         LPTBL  = LIDXIJK+ NCXYZ*3/NWDVAR+2
         LYZTBL = LPTBL  + ((2**(NS+1)-1)**3+1)/NWDVAR+1
         LCLM   = LYZTBL + ((2**(NS+1)-1)**3+1)/NWDVAR+1
         LFLM   = LCLM   + 2*NP+1
         LPNTR  = LFLM   + 2*NP+1
         LG     = LPNTR  + 3*2**NS/NWDVAR+1
         LF     = LG     + 8*((NP*(NP+1)*(NP+2)*4/3)+(NP+1))
         LZLL   = LF     + 8*((NP*(NP+1)*(NP+2)*4/3)+(NP+1))
         LINDX  = LZLL   + (2*NP+2)*2
         LINDX2 = LINDX  + NCXYZ/NWDVAR+1
         LINDX3 = LINDX2 + NCXYZ/NWDVAR+1
         LDLIST = LINDX3 + NCXYZ/NWDVAR+1
         LSLIST = LDLIST + NSHL2/NWDVAR+1
         LDLN   = LSLIST + NSHL2/NWDVAR+1
         LSLN   = LDLN   + NSHELL/NWDVAR+2
         LMLIST   = LSLN   + NSHELL/NWDVAR+2
         LMLPNT = LMLIST + 4*NSHL2/NWDVAR+1
         LTS    = LMLPNT + 2*NSHELL/NWDVAR+1
         LMAXIJ = LTS    + NSHELL
         LIDXSHL= LMAXIJ + NSHELL
         LAST  = LIDXSHL+ NSH2/NWDVAR+2
      ELSE
         LCXYZ= LAST
         LIYP = LAST
         LIBS = LAST
         LISP = LAST
         LIPP = LAST
         LIDXWS = LAST
         LIDXIJK= LAST
         LPTBL  = LAST
         LYZTBL = LAST
         LCLM   = LAST
         LFLM   = LAST
         LPNTR  = LAST
         LG     = LAST
         LF     = LAST
         LZLL   = LAST
         LINDX  = LAST
         LINDX2 = LAST
         LINDX3 = LAST
         LDLIST = LAST
         LSLIST = LAST
         LDLN   = LAST
         LSLN   = LAST
         LMLIST = LAST
         LMLPNT = LAST
         LTS    = LAST
         LMAXIJ = LAST
         LIDXSHL= LAST
      END IF
C
C     ----- ADD IN GRID-BASED DFT MEMORY -----
C
      ISWOFF=0
      IF(NDFTFG.EQ.1) THEN
         LFXCA    = LAST
         LFXCB    = LFXCA + L2
         IGRDDFT  = LFXCB + L2
         CALL GRDDFT(L2,NGRDMEM)
         LAST     = IGRDDFT + NGRDMEM
         IF((NEVALS.EQ.0 .OR. NFG.NE.0)  .AND.  SWOFF.NE.0) ISWOFF=1
      END IF
      HFSSAV=DFTTYP(3)
      NDFTSV=NDFTFG
      IDFTSWITCH=0
C
C     ----- ADD IN GRID-FREE DFT MEMORY-----
C
      MEMDFT=LAST
      IF(DFTTYP(1) .NE. 0.0D+00) THEN
         CALL DFTMEM(IDFTMEM)
         LAST=LAST+IDFTMEM
         NEED  = LAST -LOADFM -1
      END IF
C
C        WE CAN REDUCE MEMORY NEED BY 2N**2 BY DOING MORE DAREADS,
C        TO OVERLAP -H1- AND -WRK1-, -Q- AND -WRK2-, -S- AND -WRK3-.
C
      NEED = LAST - LOADFM - 1
      NSAVE = 2*L2 + L3
      NEEDI = NEED + NSAVE
C     IF((NEEDI.LT.NGOTMX)  .OR.
C    *  (VSHIFT .OR. IZRFLS .OR. IEFP.EQ.1)) THEN
      IF((NEEDI.LT.NGOTMX)  .OR.
     *  (VSHIFT .OR. IZRFLS .OR.
     *   IPCFP  .OR. IPCM.EQ.1 .OR. IEFP.EQ.1)) THEN
         MINMEM = .FALSE.
         LH1   = LAST
         LQ    = LH1    + L2
         LS    = LQ     + L3
         LAST  = LS     + L2
         NEED  = LAST -LOADFM -1
      ELSE
         MINMEM = .TRUE.
         IF(SOME) WRITE(IW,9005) NSAVE
         LH1 = LWRK1
         LQ  = LWRK2
         LS  = LWRK3
      END IF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0002                      FLGU
C-------------------------------------------------------------------FLGU
      IF(NELONG.GE.3) THEN
C
      IF(SOSCF) ELGSO=.TRUE.
      CALL SEQREW(NEG1)
      CALL SEQREW(NEG5)
      READ (NEG1) JXX,JWW,NAAO,NOCAA,NOCBA,NOCAB,NOCBB,MULAB,NHB,NATX
      READ (NEG1) NATOC,NCTMO,NCUT,NCTAO,NCYCLE
      READ (NEG1) (NFZOC(I),I=1,NCYCLE),(NFZVT(I),I=1,NCYCLE)
      READ (NEG1) (NFZOCB(I),I=1,NCYCLE),(NFZVTB(I),I=1,NCYCLE)
      READ (NEG1) (NFZATM(I),I=1,NCYCLE)
C
      IF(MASWRK) THEN
       WRITE(6,*)'JXX,JWW,NAAO,NOCAA,NOCBA,NHB,NOCAB,NOCBB='
       WRITE(6,*) JXX,JWW,NAAO,NOCAA,NOCBA,NHB,NOCAB,NOCBB
       WRITE(6,*)'NATOC,NCTMO,NAT,NSHELL=',NATOC,NCTMO,NAT,NSHELL
      ENDIF
C
       IF(NCUT.NE.0) NOCUT = NFZOC(NCUT)
C
      IF(NEG1.LT.0) THEN
         ISUM = NOCUT + NFZVT(1) + NFZVTB(1) + NFZATM(1) + NFZOCB(1)
     *        + MULAB + NATX
         WRITE(6,*) 'STRICTLY TO FOOL FTNCHEK: ISUM=',ISUM
      END IF
C
C   NUMBER OF MOS IN B+M REGION: NWM, LARGER THAN JWW
C        SO NEED SOME INITIAL GUESS MOS FOR M-REGION
C
         NWA = NUM
         NWM = NUM - JXX
         NWMT = NWM + JXX
         NOCCA  = NA
         NOCCB  = NB
         NOCMA = NOCCA - NOCAA - NOCBA
         NVCMA = NWM - JWW - NOCMA
         NOCMB = NOCCB - NOCAB - NOCBB
         NVCMB = NWM - JWW - NOCMB
         NWM2 = NWM*(NWM+1)/2
         NOCBMA = NOCCA - NOCAA
         NOCBMB = NOCCB - NOCAB
         NTOT = NUM
         NVCAA = JXX-NOCAA
         NVCAB = JXX-NOCAB
         NVCBA = JWW-NOCBA
         NVCBB = JWW-NOCBB
         IF(NCTAO.NE.0) NTOT  = NUM + NCTMO
C----------------------------------------------------------------------
       IF(MASWRK) THEN
       WRITE(IW,'(40(1H-))')
       WRITE(IW,*)'   DOUBLY OCCUPIED MOLECULAR ORBITALS'
       WRITE(IW,'(40(1H-))')
       WRITE(IW,*)'                 ALPHA           BETA   '
       WRITE(IW,'(40(1H-))')
       WRITE(IW,'('' REGION A:'',8X,I4,11X,I4)') NOCAA,NOCAB
       WRITE(IW,'('' REGION B:'',8X,I4,11X,I4)') NOCBA,NOCBB
       WRITE(IW,'('' REGION M:'',8X,I4,11X,I4)') NOCMA,NOCMB
       WRITE(IW,'(40(1H-))')
       WRITE(IW,*)'        VACANT MOLECULAR ORBITALS'
       WRITE(IW,'(40(1H-))')
       WRITE(IW,'('' REGION A:'',8X,I4,11X,I4)') JXX-NOCAA,JXX-NOCAB
       WRITE(IW,'('' REGION B:'',8X,I4,11X,I4)') JWW-NOCBA,JWW-NOCBB
       WRITE(IW,'('' REGION M:'',8X,I4,11X,I4)') NVCMA,NVCMB
       WRITE(IW,'(40(1H-))')
       WRITE(IW,*)'          SUBSYSTEMS DIMENSIONS'
       WRITE(IW,'(40(1H-))')
       WRITE(IW,'('' FROZEN REGION   A: '',I6)') JXX
       WRITE(IW,'('' ACTIVE REGION B+M: '',I6)') NWM
       WRITE(IW,'(40(1H-))')
       ENDIF
C----------------------------------------------------------------------
C
         LSW   = LAST
         LCXAL = LSW     + NUM*NUM
         LCXBT = LCXAL   + JXX*NAAO
         LCWAL = LCXBT   + JXX*NAAO      ! A REGION CL
         LCWBT = LCWAL   + JWW*NAAO
         LCBMA = LCWBT   + JWW*NAAO      ! B REGION CL
         LCBMB = LCBMA   + NWM*NWA
         MFLMO = LCBMB   + NWM*NWA       ! B+M REGION
         MSLMO = MFLMO   + NWM2
         MVEC  = MSLMO   + NWM2
         MEIG  = MVEC    + NWM*NWM
         MJBIG = MEIG    + NWM
         MBIG  = MJBIG   + 8*NWM
         MSCR  = MBIG    + NWM
         MWRK  = MSCR    + 8*NWM
         MWRK1 = MWRK    + NWM
         MIWRK = MWRK1   + NWA
         MD    = MIWRK   + NWM
         MTMP  = MD      + NUM*NUM
         MSCR2 = MTMP    + NUM*NUM
         LAD   = MSCR2   + NWM*NWM
         LBD   = LAD     + NWM*NWM
         MVA   = LBD     + NWM*NWM
         MVB   = MVA     + NWM*NWM
         LSM   = MVB     + NWM*NWM
         LFM   = LSM     + NWM*NWM
         LSDG  = LFM     + NWM*NWM
         LTMP  = LSDG    + NWM*NWM
         LTAO  = LTMP    + NAAO*NAAO
         LAST  = LTAO    + NUM*(NUM+1)/2
        IF(LCUT) THEN
         CALL SEQREW(NEG4)
         READ(NEG4)
         READ(NEG4) NCTATM,NCTAOX,I,I,I,NUMX
C
         IF(NEG4.LT.0) THEN
            WRITE(6,*) 'STRICTLY TO FOOL FTNCHEK: NCTATM=',NCTATM
         END IF
C
         NFRGSH = NUMX - NCTAOX
         NFRGBS = NUMNEW-NUMOLD
         NDIM1  = NFRGBS*(NFRGBS+1)/2 + NFRGBS*NFRGSH
         NDIM2  = NFRGBS*(NFRGBS+1)/2 + NFRGBS*NUM
         NTOT   = NUMNEW
         NTOTAL = NTOT*(NTOT+1)/2
         NDOFF  = NAAO*(NAAO+1)/2
C
         LD1A    = LAST
         LD1B    = LD1A   + NDIM2
         LDAOFF  = LD1B   + NDIM2
         LDBOFF  = LDAOFF + NDOFF
         LDATOT  = LDBOFF + NDOFF
         LDBTOT  = LDATOT + NTOTAL
         LAST    = LDBTOT + NTOTAL
        END IF
C
         NEED  = LAST -LOADFM -1
C
        CALL GETFM(NEED)
C
        READ(NEG5) (X(LCXAL+ID-1),ID=1,JXX*NAAO)
        IF(SCFTYP.EQ.ROHF) THEN
         LCXBT = LCXAL
         LCWBT = LCWAL
         LCBMB = LCBMA
        ELSE
         READ(NEG5) (X(LCXBT+ID-1),ID=1,JXX*NAAO)       ! A-REGION
        ENDIF
        READ(NEG5) (X(LCWAL+ID-1),ID=1,JWW*NAAO)
        IF(SCFTYP.EQ.UHF) THEN
         READ(NEG5) (X(LCWBT+ID-1),ID=1,JWW*NAAO)       ! B-REGION
        ENDIF
C
        IF(LCUT) THEN
C
         CALL VCLR(X(LD1A),1,NDIM2)
         CALL VCLR(X(LD1B),1,NDIM2)
         CALL VCLR(X(LDAOFF),1,NAAO*(NAAO+1)/2)
         CALL VCLR(X(LDBOFF),1,NAAO*(NAAO+1)/2)
         CALL VCLR(X(LDATOT),1,NTOTAL)
         CALL VCLR(X(LDBTOT),1,NTOTAL)
C
          READ(NEG4)
          READ(NEG4)
          READ(NEG4)
          READ(NEG4)
          READ(NEG4) (X(LD1A+J),J=0,NDIM1-1)
          READ(NEG4) (X(LD1B+J),J=0,NDIM1-1)
        ENDIF
C
C
C     ----- GET MEMORY -----
C
      ELSE
       CALL GETFM(NEED)
      ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0002                        FLGU
C-------------------------------------------------------------------FLGU
      II = 0
      DO 100 I = 1,L1
         IA(I) = II
         II = II + I
  100 CONTINUE
C
C     ----- INITIALIZE -SVP- MODEL -----
C
      IF(ISVP.EQ.1) THEN
         IADDR_SVP=LSVP
         ILAST_SVP=LSVP+LENSVP-1
         CALL SVPSET
C        IF(IFGAS.NE.0) THEN
C           SOLVNT=.FALSE.
C        ELSE
C           SOLVNT=.TRUE.
C        END IF
      END IF
C
C        MOPAC HAS A MOLECULAR MECHANICS PEPTIDE BOND CORRECTION
C
      EHNCO = ZERO
      IF(MPCTYP.NE.NONE) THEN
         DO I=1,NNHCO
            CALL DIHED(GEO,NHCO(1,I),NHCO(2,I),
     *                     NHCO(3,I),NHCO(4,I),ANGLE,SIGNA)
            SINANG = SIN(ANGLE)
            EHNCO = EHNCO + HTYPE(ITYPE)*SINANG*SINANG
         ENDDO
         EHNCO = EHNCO/627.52791D+00
      END IF
C
C     ----- OCCUPATION NUMBERS -----
C
      DO 120 I = 1,L1
         X(I+LAOC-1) = ZERO
         X(I+LBOC-1) = ZERO
         IF(I.LE.NA) X(I+LAOC-1) = ONE
         IF(I.LE.NB) X(I+LBOC-1) = ONE
  120 CONTINUE
C
C     ----- INITIALIZE VARIABLES -----
C
      ERDIIS = ZERO
      ITDIIS = 1
      ETHSAV = ETHRSH
      ETHNEW = ETHRSH
      SOGSAV = SOGTOL
      SOGNEW = SOGTOL
      DIISDMP= 0.9D+00
      NONDMX = 5
      ITNOND = NONDMX
      NOTOPN = .TRUE.
C
      IF(MAXIT.LE.0) MAXIT = 30
C
C        LOOSEN CONVERGENCE FOR DIRECT SCF BY JUST A BIT
C        AT THE BEGINNING OF GEOMETRY OPTS, WE CAN BE A BIT COARSER
C
      IF(DIRSCF) THEN
         DENTOL = TWO * CONVHF
         ENGTOL = 1.0D-08
         DIITOL = 1.0D-06
      ELSE
         DENTOL = CONVHF
         ENGTOL = 1.0D-09
         DIITOL = 1.0D-07
      END IF
      IF(NDFTFG.NE.1) THEN
         SW0=ZERO
      ELSE
         IF(SW0.LT.CONVHF) THEN
            IF(MASWRK) WRITE(IW,9006) SW0,CONVHF
            CALL ABRT
         END IF
      END IF
      SWDFT = SW0
      IF(RUNTYP.EQ.OPTMZE  .AND.  NEVALS.GT.0.AND.NFG.EQ.0) THEN
         GRMS = DDOT(3*NAT,EGRAD,1,EGRAD,1)
         GRMS = SQRT(GRMS/(3*NAT))
                               CFACT =  1.0D+00
         IF(GRMS.GT.0.005D+00) CFACT =  5.0D+00
         IF(GRMS.GT.0.020D+00) CFACT = 20.0D+00
         IF(GRMS.GT.0.100D+00) CFACT = 50.0D+00
         DENTOL = CFACT*DENTOL
         ENGTOL = CFACT*ENGTOL
         DIITOL = CFACT*ENGTOL
         SWDFT  = CFACT*SWDFT
      END IF
      DTOL2 = TWO * DENTOL
      ETOL2 = TEN * ENGTOL
      CVDIIS = .FALSE.
      CVGING = .FALSE.
      CVGED  = .FALSE.
C
C     CVGSVP KEEPS TRACK OF WHETHER SVP CHARGES/DIPOLES APPEAR CONVERGED
C
      CVGSVP    = .FALSE.
      CVGSVPDN  = .FALSE.
      CVGSVPDN1 = .FALSE.
      CVGSVPNR  = .FALSE.
C
      MPUNCH = NPUNCH
      EHF = ZERO
      ETOT= ZERO
      EEXC= ZERO
      EDFA= ZERO
      EDFB= ZERO
      ITERV= 0
      ICALP = 0
      ICBET = 0
      ICAB  = 0
      DAMP  = ZERO
      DAMP0 = ZERO
      IF(DMPCUT .LE. ZERO) DMPCUT = ZERO
      RRSHFT = ZERO
      ITERLV = 0
      DIFF = ZERO
      DIFFP= ZERO
      DIFFA= ZERO
      DIFFB= ZERO
      DELE  = ZERO
      DEAVG = ZERO
      NDAFA = 23
      NDAFB = 26
      IF(DAMPH .OR. VSHIFT) DAMP = ONE
      SWGROK=.TRUE.
C
C        READ INVERSE D MATRIX FOR PCM (SKIP FOR ITERATIVE SOLVER)
C
      IF(IPCMIT.EQ.0  .AND.  (IPCM.EQ.1 .OR. IPCFP)) THEN
         NTS3 = NTS*NTS
         CALL SEQREW(NFT26)
         CALL DERCHK(NDER)
         IF(NDER.EQ.1.AND.IPCDER.EQ.1) THEN
            CALL SEQADV(NFT26)
            CALL SEQADV(NFT26)
            CALL SEQADV(NFT26)
            CALL SEQADV(NFT26)
         END IF
         IF(IEF.GT.0.AND.IEF.LT.3) THEN
            CALL SEQADV(NFT26)
            CALL SEQADV(NFT26)
            CALL SQREAD(NFT26,X(LSE),NTS3)
            CALL SQREAD(NFT26,X(LDE),NTS3)
         END IF
         CALL SQREAD(NFT26,X(LDMATM),NTS3)
         CALL SEQREW(NFT26)
      END IF
C
C
C     ----- PRINT NUCLEAR ENERGY, CONTROL PARAMETERS -----
C
      IF(MASPRT.AND.(NFG.EQ.0.OR.NPRINT.NE.-5)) THEN
         IF(SOME) WRITE(IW,9020) EN,MAXIT,MPUNCH,MUL,EXTRAH,DAMPH,
     *                  VSHIFT,RSTRCT,DODIIS,SOSCF
         IF(NDFTFG.NE.1) THEN
            IF(MASPRT) WRITE(IW,9012) DENTOL
         ELSE
            IF(MASPRT) WRITE(IW,9013) DENTOL,SWDFT,SWOFF
         END IF
         IF(SOME  .AND.  VTSCAL) WRITE(IW,9015) VTSCAL,MAXVT,VTCONV
         IF(SOME  .AND.  SCFTYP.EQ.ROHF) WRITE(IW,9030)
     *                              (AROHF(I),I=1,3),(BROHF(I),I=1,3)
         IF(SOME  .AND.  SOSCF) THEN
           IF(SCFTYP.EQ.ROHF) THEN
              WRITE(IW,9017) NPRO,SOGTOL
           ELSE
              WRITE(IW,9018) NPRA,NPRB,SOGTOL
           END IF
         END IF
         IF(SOME) WRITE(IW,9040) NEED
      END IF
C
C     ----- EXCHANGE INTEGRALS FOR DIRECT SCF THRESHOLD TESTS -----
C
      NINT=0
      NSCHWZ=0
      IF(DIRSCF.AND.ABINIT) THEN
         SCHWRZ = ISCHWZ.GT.0
         IF(MASPRT) WRITE(IW,9045) SCHWRZ,FDIFF
         IF(SCHWRZ) CALL EXCHNG(X(LXINTS),X(LGHOND),X(LDDIJ),
     *                          NSH2,MAXG,INTTYP)
      ELSE
         SCHWRZ=.FALSE.
      END IF
C
C     ----- READ IN MOPAC 2-ELECTRON INTEGRALS -----
C
      IF(MPCTYP.NE.NONE  .AND.  N2EL.GT.0)
     *   CALL DAREAD(IDAF,IODA,X(LTWOEI),N2EL,53,0)
C
C     ----- READ CORE HAMILTONIAN -----
C     ----- READ OVERLAP MATRIX -----
C     ----- READ SYMMETRY ADDAPTED Q MATRIX -----
C     L0 = NUMBER OF CANONICAL ORTHONORMAL VECTORS KEPT.
C
      IF(.NOT.MINMEM) THEN
         CALL DAREAD(IDAF,IODA,X(LH1),L2,11,0)
         CALL DAREAD(IDAF,IODA,X(LS) ,L2,12,0)
         CALL DAREAD(IDAF,IODA,X(LQ) ,L3,45,0)
      END IF
C
C     ----- READ INITIAL ORBITALS AND DENSITY -----
C
      CALL DAREAD(IDAF,IODA,X(LVA),L3,15,0)
      CALL DAREAD(IDAF,IODA,X(LDA),L2,16,0)
      IF(SCFTYP.EQ.UHF) CALL DAREAD(IDAF,IODA,X(LVB),L3,19,0)
      CALL DAREAD(IDAF,IODA,X(LDB),L2,20,0)
C
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0003                      FLGU
C-------------------------------------------------------------------FLGU
       IF(SCFTYP.EQ.ROHF) THEN
         CALL BMCL_UHF(X(LCWAL),X(LCBMA),
     *                 NAAO,JWW,NHB,NWA,NWM,NOCBA,NOCMA,NVCMA)
       ELSE
         CALL GESTST(X(LCXAL),X(LCWAL),X(LVA),X(LCBMA),X(MTMP),
     *            X(LS),X(MWRK1),NUM,L2,NAAO,JXX,JWW,
     *            NOCAA,NVCAA,NOCBA,NVCBA,NOCMA,NVCMA,NOCCA,NWA,NWM,NHB)
       ENDIF
C
         IF(SCFTYP.EQ.UHF)
     *   CALL GESTST(X(LCXBT),X(LCWBT),X(LVB),X(LCBMB),X(MTMP),
     *            X(LS),X(MWRK1),NUM,L2,NAAO,JXX,JWW,
     *            NOCAB,NVCAB,NOCBB,NVCBB,NOCMB,NVCMB,NOCCB,NWA,NWM,NHB)
C
       IF(LCUT) THEN
         READ(NEG5) (X(LDA+I),I=0,(NAAO-NHB-NCTAO)
     *                           *(NAAO-NHB-NCTAO+1)/2-1)
         READ(NEG5) (X(LDB+I),I=0,(NAAO-NHB-NCTAO)
     *                           *(NAAO-NHB-NCTAO+1)/2-1)
         READ(NEG5) (X(LDAOFF+I-1),I=1,NFRGSH*(NFRGSH+1)/2)
         READ(NEG5) (X(LDBOFF+I-1),I=1,NFRGSH*(NFRGSH+1)/2)
C
          CALL MOELIN(X(LCBMA),X(LCXAL),X(LVA),
     *        NUM,NAAO,JXX,NOCAA,NOCBMA)
          IF(SCFTYP.EQ.UHF) CALL MOELIN(X(LCBMB),X(LCXBT),X(LVB),
     *        NUM,NAAO,JXX,NOCAB,NOCBMB)
C
         CALL DENCUT(X(LDA),X(LD1A),X(LDATOT),NUMOLD,NFRGBS,
     *               L2,NDIM2,NTOTAL)
         CALL DENCUT(X(LDB),X(LD1B),X(LDBTOT),NUMOLD,NFRGBS,
     *               L2,NDIM2,NTOTAL)
       ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0003                        FLGU
C-------------------------------------------------------------------FLGU
      IF(SOSCF) THEN
         CALL DAREAD(IDAF,IODA,X(LEA),L1,17,0)
         IF(SCFTYP.EQ.UHF) CALL DAREAD(IDAF,IODA,X(LEB),L1,21,0)
         TDSKWRK = DSKWRK
         DSKWRK = .FALSE.
         IF(.NOT.FT15OP) THEN
            FT15OP = .TRUE.
            CALL SEQOPN(NFT15,'WORK15','UNKNOWN',.FALSE.,'UNFORMATTED')
            IF(SCFTYP.EQ.UHF) CALL SEQOPN(NFT16,'WORK16','UNKNOWN',
     *                                     .FALSE.,'UNFORMATTED')
            CALL SEQREW(NFT15)
            IF(SCFTYP.EQ.UHF) CALL SEQREW(NFT16)
         ELSE
            CALL SEQREW(NFT15)
            IF(SCFTYP.EQ.UHF) CALL SEQREW(NFT16)
         END IF
         DSKWRK = TDSKWRK
      END IF
C
C     ----- PREVIOUS DENSITY IS ZERO, PREVIOUS FOCK MAT. IS HCORE -----
C
      IF(DIRSCF  .AND.  FDIFF) THEN
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),L2,11,0)
         CALL DAWRIT(IDAF,IODA,X(LH1),L2,14,0)
         CALL DAWRIT(IDAF,IODA,X(LH1),L2,18,0)
         CALL VCLR(X(LWRK1),1,L2)
         CALL VCLR(X(LWRK2),1,L2)
      END IF
C
C     ----- IF SCRF SAVE PRISTINE ONE ELEC. HAM. -----
C     -----    AND READ IN DIPOLE INTEGRALS      -----
      IF(IZRFLS) THEN
         CALL DAREAD(IDAF,IODA,X(LXDINT),L2,95,0)
         CALL DAREAD(IDAF,IODA,X(LYDINT),L2,96,0)
         CALL DAREAD(IDAF,IODA,X(LZDINT),L2,97,0)
      END IF
      IF(IZRFLS  .OR.  IEFP.EQ.1  .OR.  IPCFP  .OR.  ISVP.EQ.1) THEN
         CALL DAWRIT(IDAF,IODA,X(LH1),L2,87,0)
      END IF
C
C     THIS IS SOMETHING LEFT OVER FROM THE MINNESOTA SOLVENT CODES.
C     SETUP S-HALF MATRIX, CALCULATE BORN RADII
C
C-SM5-CALL SETSOL(X(LS),L1,ABINIT)
C
C     ----- SETTING FOR GRID DFT -----
C
      IF (NDFTFG.EQ.1) THEN
C          PCM HAS A BUG RESETTING THE GRID, SO DON'T LET IT
        IF(IPCM.EQ.1) THEN
           NRAD0 = NRAD
           NPHI0 = NPHI
           NTHE0 = NTHE
        END IF
        IF(NRAD*NPHI*NTHE.GT.NRAD0*NPHI0*NTHE0) THEN
          IF(MASPRT) WRITE(IW,9340) NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0
          CALL SWGRID
          GRIDTYP = COARSE
        ELSE
          GRIDTYP = FINE
        END IF
        CALL DFTSET(X(IGRDDFT),1,.FALSE.)
C
C         SWITCH OFF DFT AT THIS POINT IF THE USER SO REQUESTED.
C
        IF(ISWOFF.GT.0) THEN
          IF(MASWRK  .AND.  NDFTFG.NE.0) WRITE(IW,9350)
          DFTTYP(3)=1.0D+00
          NDFTFG=0
        END IF
      END IF
C
C     ----- SETTING FOR QFMM -----
C
      IF (QFMM) THEN
         CALL QFMMUP(L2,LS,NSHL2,LSLIST,NSHELL,LSLN,LTS,
     *     NCXYZ,LCXYZ,LIYP,LIBS,LISP,LIPP,LIDXWS,LINDX,MAXWS,
     *     MAXNYP,NSH2,LIDXSHL,LPNTR,NBOX,NTBOX,LCLM,LFLM,
     *     LAST,LIDXBOX,LMBOX,LEBOX,LNBR,LNUMWS,LYZPNT,LTMPGPS,
     *     LTMPGPL,NEED1,NEED,LAST1,LINDX2,LINDX3,
     *     LIDXIJK,LPTBL,LYZTBL,NSBOX,NTMPL,
     *     MTIJ,MIJKL,LYP,LZP,LITSP,LITPP,LITSP2,
     *     LITPP2,IJTPP,KLTPP,IJSPP,KLSPP,IJTBLP,IJTBL,LAST2,NEED2)
C
C           THERE ARE ADDITIONAL MEMORY ALLOCATIONS INSIDE ROUTINES
C           -QFMMBOX- AND -NEARJ-, WHICH THE CHECK RUN WILL BRANCH
C           AROUND W/O CALLING WHEN BRANCHING PAST THE ITERS BELOW.
C           THESE MEMORY NEEDS ARE NOT SIMULTANEOUSLY NECESSARY.
         MQBOX = 3*NCXYZ + 2*NCXYZ/NWDVAR + 3*2**NS/NWDVAR + 3
         MNEARJ= 6*MIJKL + 2
         IF(EXETYP.EQ.CHECK) THEN
            NEED2 = NEED2 + MAX(MQBOX,MNEARJ)
         ELSE
            IF(MASPRT) WRITE(IW,9035) NEED2 + MAX(MQBOX,MNEARJ)
         END IF
         CALL GETFM(NEED2)
         NEED=NEED+NEED2
      END IF
C
      IF(EXETYP.EQ.CHECK) GO TO 800
C
C     ----- PRINT ITERATION HEADER -----
C
      SOSCF = SOSCF0
C
      IF(MASPRT) THEN
         IF(NBUFMO.GT.0) THEN
           WRITE(IW,9039)
         END IF
         IF(DAMPH  .OR.  VSHIFT) THEN
            IF(SOSCF) THEN
               IF(.NOT.DIRSCF) WRITE(IW,9048)
               IF(     DIRSCF) WRITE(IW,9049)
            ELSE
               IF(.NOT.DIRSCF) WRITE(IW,9050)
               IF(     DIRSCF) WRITE(IW,9055)
            END IF
         ELSE
            IF(SOSCF) THEN
               IF(.NOT.DIRSCF) WRITE(IW,9058)
               IF(     DIRSCF) WRITE(IW,9059)
            ELSE
               IF(.NOT.DIRSCF) WRITE(IW,9060)
               IF(     DIRSCF) WRITE(IW,9065)
            END IF
         END IF
      END IF
C
C           *************************
C     ***** START UHF/ROHF ITERATIONS *****
C           *************************
C
      DO 500 ITER=1,MAXIT
C
C     ----- CONSTRUCT SKELETON 2 ELECTRON FOCK MATRIX -----
C     FOR DIRECT SCF,
C     EITHER -LWRK1- AND -LWRK2- SHOULD BE THE CHANGE IN THE DENSITY,
C     WITH THE CHANGE IN THE FOCK MATRICES TO BE COMPUTED AT -LFA-
C     AND -LFB-, OR THEY SHOULD CONTAIN THE TOTAL DENSITY WITH THE
C     ENTIRE TWO ELECTRON FOCK OPERATORS TO BE FORMED.
C
C-------------------------------------------------------------------FLGU
C  MARCIN MAKOWSKI                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0004                      FLGU
C-------------------------------------------------------------------FLGU
      IF(ABINIT) THEN
         IF(DIRSCF) THEN
            IF(FDIFF) THEN
               IF(LCUT) THEN
                 CALL VSUB(X(LWRK1),1,X(LDATOT),1,X(LWRK1),1,NTOTAL)
                 CALL VSUB(X(LWRK2),1,X(LDBTOT),1,X(LWRK2),1,NTOTAL)
               ELSE
                 CALL VSUB(X(LWRK1),1,X(LDA),1,X(LWRK1),1,L2)
                 CALL VSUB(X(LWRK2),1,X(LDB),1,X(LWRK2),1,L2)
               END IF
            ELSE
                IF(LCUT) THEN
                  CALL DCOPY(NTOTAL,X(LDATOT),1,X(LWRK1),1)
                  CALL DCOPY(NTOTAL,X(LDBTOT),1,X(LWRK2),1)
                ELSE
                  CALL DCOPY(L2,X(LDA),1,X(LWRK1),1)
                  CALL DCOPY(L2,X(LDB),1,X(LWRK2),1)
                ENDIF
            END IF
            IF(SCHWRZ) THEN
               DUMMY = 0.0D+00
               IF(LCUT) THEN
                 CALL SHLDEN(SCFTYP,X(LWRK1),X(LWRK2),DUMMY,X(LDSH),
     *                       IA,NTOT,NTOTAL,NSH2,1)
               ELSE
                 CALL SHLDEN(SCFTYP,X(LWRK1),X(LWRK2),DUMMY,X(LDSH),
     *                       IA,L1,L2,NSH2,1)
               END IF
            END IF
            CALL VCLR(X(LFA),1,L2)
            CALL VCLR(X(LFB),1,L2)
C
C         ----- LINEAR SCALING TWO-ELECTRON INTEGRAL COMPUTATION -----
C
            IF (QFMM) THEN
               CALL LSTWOEI(LDLIST,NSHL2,LDLN,LTS,NSHELL,LMAXIJ,LDSH,
     *            NSH2,NINT,L1,L2,LXINTS,LGHOND,MAXG,LDDIJ,LWRK1,LFA,
     *            LSLIST,LMLIST,LIDXSHL,LIPP,LINDX2,LIDXIJK,
     *            LIDXWS,NCXYZ,LSLN,LMLPNT,LIYP,LCXYZ,LIBS,LYZTBL,
     *            NTMPL,LYP,LZP,NTBOX,MAXWS,LYZPNT,LF,LG,LZLL,LCLM,
     *            LFLM,LIDXBOX,NSBOX,NZ,LISP,
     *            SCHWRZ,NSCHWZ,LINDX,LITSP,LITPP,LITSP2,LITPP2,LMBOX,
     *            LEBOX,LNBR,LNUMWS,MIJKL,LWRK2,LFB,
     *            IJTPP,KLTPP,IJSPP,KLSPP,IJTBLP,IJTBL)
C
C          ----- DIRECT TWO-ELECTRON INTEGRAL COMPUTATION -----
C
            ELSE
               CUTSV  = CUTOFF
               CUTOFF = MIN(CUTOFF,1.0D-10)
               IF(FDIFF) CUTOFF=CUTOFF/TWO
               IF(LCUT) THEN
                  CALL ADDINT(SCFTYP,DIRSCF,.FALSE.,.FALSE.,.FALSE.,
     *                 SCHWRZ,NINT,NSCHWZ,L2,
     *                 DUMMY,DUMMY,IDUMMY,1,
     *                 X(LXINTS),NSH2,X(LGHOND),MAXG,
     *                 IA,X(LWRK1),X(LFA),X(LWRK2),X(LFB),X(LDSH),
     *                 .FALSE.,NTOT,L2,NTOTAL)
               ELSE
               CALL TWOEI(SCFTYP,DIRSCF,.FALSE.,.FALSE.,.FALSE.,
     *                 INTTYP,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *                 DUMMY,DUMMY,IDUMMY,1,
     *                 X(LXINTS),NSH2,X(LGHOND),MAXG,X(LDDIJ),
     *                 IA,X(LWRK1),X(LFA),X(LWRK2),X(LFB),X(LDSH),
     *                 DUMMY,DUMMY,1)
                END IF
               CUTOFF = CUTSV
            END IF
            CALL DSCAL(L2,HALF,X(LFA),1)
            CALL DSCAL(L2,HALF,X(LFB),1)
            II=LFA-1
            JJ=LFB-1
            DO 210 I=1,L1
               II = II+I
               JJ = JJ+I
               X(II) = X(II) + X(II)
               X(JJ) = X(JJ) + X(JJ)
  210       CONTINUE
C
C          ----- TWO-ELECTRON INTEGRALS TAKEN FROM DISK -----
C
         ELSE
            TDSKWRK = DSKWRK
            DSKWRK  = .TRUE.
            CALL SEQREW(IS)
           IF(LCUT) THEN
            CALL HSTEGU(X(LDATOT),X(LFA),X(LDBTOT),X(LFB),X(LXP),
     *                  X(LIXPK),NINTMX,IA,NOPK)
           ELSE
            CALL HSTARU(X(LDA),X(LFA),X(LDB),X(LFB),X(LXP),
     *                  X(LIXPK),X(LXP),X(LXK),NINTMX,IA,NOPK)
           ENDIF
C-------------------------------------------------------------------FLGU
C  MARCIN  MAKOWSKI                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0004                        FLGU
C-------------------------------------------------------------------FLGU
            DSKWRK  = TDSKWRK
         END IF
C
C     ----- ADD GRID DFT CONTRIBUTION TO 2E- FOCK OPERATOR -----
C     TRANSPOSING ALLOWS UNIT STRIDE ACCESS INSIDE THE DFT CODES
C
         IF (NDFTFG.EQ.1) THEN
           SWGROK=.TRUE.
           CALL TRPOSE(X(LVA),X(LWRK1),L1,L1,1)
           IF(SCFTYP.EQ.UHF) CALL TRPOSE(X(LVB),X(LWRK1),L1,L1,1)
           CALL DFTEXCOR(X(IGRDDFT),X(LFXCA),X(LFXCB),X(LVA),X(LVB),
     *                   L1,L2,EEXC,TOTELE,TOTKIN)
           CALL TRPOSE(X(LVA),X(LWRK1),L1,L1,1)
           IF(SCFTYP.EQ.UHF) CALL TRPOSE(X(LVB),X(LWRK1),L1,L1,1)
           CALL SYMH(X(LFXCA),X(LWRK1),IA)
           CALL SYMH(X(LFXCB),X(LWRK1),IA)
           IF(DBG) THEN
             WRITE(IW,*) 'ALPHA DFT FOCK MATRIX'
             CALL PRTRIL(X(LFXCA),L1)
             WRITE(IW,*) 'BETA  DFT FOCK MATRIX'
             CALL PRTRIL(X(LFXCB),L1)
           END IF
           CALL DDI_GSUMF(2310,EEXC,1)
           CALL DDI_GSUMF(2311,TOTELE,1)
           IF (PRTTAU) THEN
             CALL DDI_GSUMF(2317,TOTKIN,1)
             WRITE(IW,9311) TOTKIN
           END IF
           IF(.NOT.(ABINIT.AND.DIRSCF.AND.FDIFF)) THEN
             EDFA=TRACEP(X(LDA),X(LFXCA),L1)/TWO
             EDFB=TRACEP(X(LDB),X(LFXCB),L1)/TWO
             CALL DDI_GSUMF(2314,EDFA,1)
             CALL DDI_GSUMF(2315,EDFB,1)
             CALL VADD(X(LFA),1,X(LFXCA),1,X(LFA),1,L2)
             CALL VADD(X(LFB),1,X(LFXCB),1,X(LFB),1,L2)
           END IF
         END IF
C
         IF(GOPARR) THEN
            CALL DDI_GSUMF(1000,X(LFA),L2)
            CALL DDI_GSUMF(1001,X(LFB),L2)
            CALL DDI_GSUMI(1002,NINT  ,1)
            CALL DDI_GSUMI(1003,NSCHWZ,1)
         END IF
C
C           ----- MOPAC SEMI-EMPIRICAL 2E- FOCK OPERATOR -----
C
      ELSE
         HFCO = -ONE
         CALL MPCG(X(LFA),X(LFB),X(LWRK1),X(LDA),X(LDB),X(LPTOT2),
     *             X(LTWOEI),L2,HFCO)
      END IF
C
C     ----- ADD POSSIBLE GRID-FREE DFT TERMS TO FOCK MATRIX
C
      IF(DFTTYP(1) .NE. 0.0D+00) THEN
         CALL DFTDRVR(X(MEMDFT),X(LFA),X(LFB),X(LDA),X(LDB),X(LVA))
         IF(DBG .OR. PRDENS) THEN
            WRITE(IW,9210) EXENA
            WRITE(IW,9220) EXENB
         END IF
      ELSE
         EXENA=0.0D+00
         EXENB=0.0D+00
         EXENC=0.0D+00
      END IF
C
C           AT THIS POINT, THE SKELETON 2E- FOCK OPERATOR IS FINISHED
C
      IF(DBG) THEN
         WRITE(IW,*) '*** START OF DEBUG OUTPUT FOR ITERATION',ITER
         WRITE(IW,*) 'ALPHA SKELETON FOCK MATRIX'
         CALL PRTRIL(X(LFA),L1)
         WRITE(IW,*) 'BETA SKELETON FOCK MATRIX'
         CALL PRTRIL(X(LFB),L1)
      END IF
C
C     ----- SYMMETRIZE THE SKELETON FOCK MATRICES -----
C     TRIANGULAR SCRATCH AREA AT -LWRK1-
C
      CALL SYMH(X(LFA),X(LWRK1),IA)
      CALL SYMH(X(LFB),X(LWRK1),IA)
      IF(DBG) THEN
         WRITE(IW,*) 'ALPHA SYMMETRIZED FOCK MATRIX'
         CALL PRTRIL(X(LFA),L1)
         WRITE(IW,*) 'BETA SYMMETRIZED FOCK MATRIX'
         CALL PRTRIL(X(LFB),L1)
      END IF
C
C     * * * * * SOLVATION MODEL CORRECTIONS TO 1E- TERM * * * * *
C
C                ----- ONSAGER REACTION FIELD -----
C     GET PRISTINE ONE ELEC. HAM., CALC. INDUCED DIPOLES, ADD PERTURB.
C
        IF(IZRFLS) THEN
           CALL VADD(X(LDA),1,X(LDB),1,X(LWRK1),1,L2)
           CALL DAREAD(IDAF,IODA,X(LH1),L2,87,0)
C
C        ----- CALC. INDUCED DIPOLES, AND ADD PERTURBATION. -----
           IF(DIRSCF .AND. FDIFF) THEN
              CALL RCNFLD(X(LH1),X(LFA),X(LFB),X(LWRK1),X(NDIPER),
     *                X(LDIPER),X(LXDINT),X(LYDINT),X(LZDINT),L2,L1,0)
           ELSE
              CALL RCNFLD(X(LH1),DUMMY,DUMMY,X(LWRK1),DUMMY,
     *                  DUMMY,X(LXDINT),X(LYDINT),X(LZDINT),L2,L1,0)
           END IF
        END IF
C
C     ----- SURFACE AND VOLUME POLARIZATION FOR ELECTROSTATICS -----
C
      IF(ISVP.EQ.1) THEN
         CALL SVPCHG(X(LDA),X(LDB),X(LH1),X(LWRK1),IADDR_SVP,ILAST_SVP,
     1               L2,L1,ESVP,ITER,
     2               CVGSVPDN,CVGSVPDN1,CVGSVPNR,IUPRXN,CHGDIF,CVGSVP)
      END IF
C
C     ----- POLARIZABLE CONTINUUM MODEL CALCULATION -----
C
      IF(IPCM.EQ.1) THEN
         CALL VADD(X(LDA),1,X(LDB),1,X(LWRK1),1,L2)
C
C        USE THE 'BUFFERLESS' DENSITY IN PCMFLD (LWRK2)
C
         IF(NBUFMO.GT.0) THEN
            CALL DAREAD(IDAF,IODA,X(LVA),L3,15,0)
            CALL DMTX(X(LWRK3),X(LVA),X(LAOC),NBUFMO,L1,L1)
            CALL VSUB(X(LWRK3),1,X(LWRK1),1,X(LWRK2),1,L2)
            IF(NB.GT.0) THEN
              CALL DAREAD(IDAF,IODA,X(LVB),L3,19,0)
              CALL DMTX(X(LWRK3),X(LVB),X(LBOC),NBUFMO,L1,L1)
              CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
            END IF
         ELSE
            CALL DCOPY(L2,X(LWRK1),1,X(LWRK2),1)
         END IF
C
         CALL PCMFLD(X(LFA),X(LFB),X(LWRK1),X(LSOL),X(LCHG),X(LWRK4),
     *               X(LDISV),X(LDIS1),X(LDIS2),X(LWRK3),X(LSCR),
     *               X(LDMATM),X(LCQEF),X(LQEFF),X(LELD),X(LQPOT),
     *               X(LQFLD),X(LVPOT),X(LSE),X(LDE),
     *               X(LQ0),X(LQ1),X(LQ2),X(LQ3),
     *               X(LD0),X(LQA),X(LDIMAT),X(LQREP),
     *               X(LTMP0),X(LTMP1),X(LTMP2),X(LIPVT),
     *               X(LPOTTMP),X(LRMUL),TCH,QET,QETN,QESC,1,NFT27,
     *               .FALSE.,L1,L2,NTSPAR,X(LAXYZCT),X(LAXYZCT+MXTS),
     *               X(LAXYZCT+MXTS*2),X(LXYZCT2),X(LXYZCT2+MXTS),
     *               X(LXYZCT2+MXTS*2),X(LAXYZCT+MXTS*3),
     *               X(LQSN),X(LQSE),X(LQFS),X(LVECMUL),
     *               X(LCHG2),X(LQIND+MXTS),X(LPEL),X(LASCCRD),
     *               X(LASCCHG),X(LASCDIP),X(LASCQAD),X(LXYZRE),
     *               X(LXYZRE+MXSP),X(LXYZRE+MXSP*2),X(LXYZRE+MXSP*3),
     *               X(LISPHE),X(LLIST))
      END IF
C
C               ------ COMBINED PCM/EFP METHOD ------
C
      IF(IPCFP) THEN
         CALL VADD(X(LDA),1,X(LDB),1,X(LWRK1),1,L2)
C
C        USE THE 'BUFFERLESS' DENSITY IN PCMFLD AND CHGIND (LWRK2)
C
         IF(NBUFMO.GT.0) THEN
            CALL DAREAD(IDAF,IODA,X(LVA),L3,15,0)
            CALL DMTX(X(LWRK3),X(LVA),X(LAOC),NBUFMO,L1,L1)
            CALL VSUB(X(LWRK3),1,X(LWRK1),1,X(LWRK2),1,L2)
            IF(NB.GT.0) THEN
              CALL DAREAD(IDAF,IODA,X(LVB),L3,19,0)
              CALL DMTX(X(LWRK3),X(LVB),X(LBOC),NBUFMO,L1,L1)
              CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
            END IF
         ELSE
            CALL DCOPY(L2,X(LWRK1),1,X(LWRK2),1)
         END IF
C
         CALL PCMFLD(X(LFA),X(LFB),X(LWRK1),X(LSOL),X(LCHG),X(LWRK4),
     *               X(LDISV),X(LDIS1),X(LDIS2),X(LWRK3),X(LSCR),
     *               X(LDMATM),X(LCQEF),X(LQEFF),X(LELD),X(LQPOT),
     *               X(LQFLD),X(LVPOT),X(LSE),X(LDE),
     *               X(LQ0),X(LQ1),X(LQ2),X(LQ3),
     *               X(LD0),X(LQA),X(LDIMAT),X(LQREP),
     *               X(LTMP0),X(LTMP1),X(LTMP2),X(LIPVT),
     *               X(LPOTTMP),X(LRMUL),TCH,QET,QETN,QESC,1,NFT27,
     *               IPCFP,L1,L2,NTSPAR,X(LAXYZCT),X(LAXYZCT+MXTS),
     *               X(LAXYZCT+MXTS*2),X(LXYZCT2),X(LXYZCT2+MXTS),
     *               X(LXYZCT2+MXTS*2),X(LAXYZCT+MXTS*3),X(LQSN),
     *               X(LQSE),X(LQFS),X(LVECMUL),
     *               X(LCHG2),X(LQIND+MXTS),X(LPEL),X(LASCCRD),
     *               X(LASCCHG),X(LASCDIP),X(LASCQAD),X(LXYZRE),
     *               X(LXYZRE+MXSP),X(LXYZRE+MXSP*2),X(LXYZRE+MXSP*3),
     *               X(LISPHE),X(LLIST))
C
         CALL DAREAD(IDAF,IODA,X(LH1),L2,87,0)
         IF(DIRSCF .AND. FDIFF) THEN
            CALL CHGIND(X(LH1),X(LFA),X(LFB),X(LWRK2),
     *                  X(NDIPER),X(LDIPER),
     *                  X(LDMATM),X(LXDINT),X(LYDINT),X(LZDINT),
     *                  X(LEFLD),X(MADD),X(LABFLD),X(LVECMP),X(LVEC_2),
     *                  X(LVEC_S),L2,L1,0,
     *                  X(LAXYZCT),X(LAXYZCT+MXTS),X(LAXYZCT+MXTS*2),
     *                  X(LAXYZCT+MXTS*3),X(LQSN),X(LQSE),X(LQFS),
     *                  X(LQIND),X(LAIPRJ),X(LFIPRJ))
         ELSE
            CALL CHGIND(X(LH1),DUMMY,DUMMY,X(LWRK2),
     *                  DUMMY,DUMMY,
     *                  X(LDMATM),X(LXDINT),X(LYDINT),X(LZDINT),
     *                  X(LEFLD),X(MADD),X(LABFLD),X(LVECMP),X(LVEC_2),
     *                  X(LVEC_S),L2,L1,0,
     *                  X(LAXYZCT),X(LAXYZCT+MXTS),X(LAXYZCT+MXTS*2),
     *                  X(LAXYZCT+MXTS*3),X(LQSN),X(LQSE),X(LQFS),
     *                  X(LQIND),X(LAIPRJ),X(LFIPRJ))
         END IF
C
      END IF
C
C           ---- EFFECTIVE FRAGMENT POTENTIAL MODEL -----
C
      IF(IEFP.EQ.1) THEN
         CALL VADD(X(LDA),1,X(LDB),1,X(LWRK1),1,L2)
         CALL DAREAD(IDAF,IODA,X(LH1),L2,87,0)
C   IF BUFFER MOS ARE THERE, WE USE THE 'BUFFERLESS' DENSITY IN EFPCMP
         IF(NBUFMO.GT.0) THEN
            CALL DAREAD(IDAF,IODA,X(LVA),L3,15,0)
            CALL DMTX(X(LWRK2),X(LVA),X(LAOC),NBUFMO,L1,L1)
            CALL VSUB(X(LWRK2),1,X(LWRK1),1,X(LWRK1),1,L2)
            IF(NB.GT.0) THEN
               CALL DAREAD(IDAF,IODA,X(LVB),L3,19,0)
               CALL DMTX(X(LWRK3),X(LVB),X(LBOC),NBUFMO,L1,L1)
               CALL VSUB(X(LWRK3),1,X(LWRK1),1,X(LWRK1),1,L2)
            END IF
         END IF
C
C        ----- CALC. INDUCED DIPOLES, AND ADD PERTURBATION. -----
C
         IF(DIRSCF .AND. FDIFF) THEN
            CALL EFPCMP(X(LH1),X(LFA),X(LFB),X(LWRK1),X(NDIPER),
     *                  X(LDIPER),X(LXDINT),X(LYDINT),X(LZDINT),
     *                  X(LEFLD),X(MADD),X(LABFLD),L2,L1,0)
         ELSE
            CALL EFPCMP(X(LH1),DUMMY,DUMMY,X(LWRK1),DUMMY,DUMMY,
     *                  X(LXDINT),X(LYDINT),X(LZDINT),X(LEFLD),X(MADD),
     *                  X(LABFLD),L2,L1,0)
         END IF
      END IF
C
C     * * * * * END OF SOLVATION MODEL CORRECTIONS TO 1E- TERM * * * * *
C
C     ----- COMPLETE THE FOCK MATRIX -----
C     WE EITHER ADD THE FOCK OPERATOR OF THE PREVIOUS ITERATION TO
C     THE CHANGE IN THE FOCK MATRIX, OR WE ADD THE ONE ELECTRON
C     HAMILTONIAN TO THE FULLY COMPUTED TWO ELECTRON OPERATOR.
C
      IF(ABINIT  .AND.  DIRSCF  .AND.  FDIFF) THEN
         CALL DAREAD(IDAF,IODA,X(LWRK1),L2,14,0)
         CALL DAREAD(IDAF,IODA,X(LWRK2),L2,18,0)
         CALL VADD(X(LFA),1,X(LWRK1),1,X(LFA),1,L2)
         CALL VADD(X(LFB),1,X(LWRK2),1,X(LFB),1,L2)
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),L2,11,0)
      ELSE
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),L2,11,0)
         CALL VADD(X(LFA),1,X(LH1),1,X(LFA),1,L2)
         CALL VADD(X(LFB),1,X(LH1),1,X(LFB),1,L2)
      END IF
C
      CALL DAWRIT(IDAF,IODA,X(LFA),L2,14,0)
      CALL DAWRIT(IDAF,IODA,X(LFB),L2,18,0)
C
      IF(DBG) THEN
         WRITE(IW,*) 'ALPHA TOTAL FOCK MATRIX'
         CALL PRTRIL(X(LFA),L1)
         WRITE(IW,*) 'BETA TOTAL FOCK MATRIX'
         CALL PRTRIL(X(LFB),L1)
      END IF
C
C     ----- CALCULATE ENERGY -----
C
C   SUBTRACT INTERACTIONS OF THE EFP WITH THE BUFFER ZONE
C   DURING THE QM/MM CALCULATION
C     IF(NBUFMO.GT.0) THEN
C        CALL DAREAD(IDAF,IODA,X(LVA),L3,15,0)
C        CALL DMTX(X(LWRK2),X(LVA),X(LAOC),NBUFMO,L1,L1)
C        IF(NB.GT.0) THEN
C          CALL DAREAD(IDAF,IODA,X(LVB),L3,19,0)
C          CALL DMTX(X(LWRK3),X(LVB),X(LBOC),NBUFMO,L1,L1)
C        END IF
C        CALL VADD(X(LWRK2),1,X(LWRK3),1,X(LWRK2),1,L2)
C        CALL DAREAD(IDAF,IODA,X(LWRK1),L2,319,0)
C        CALL VSUB(X(LWRK1),1,X(LH1),1,X(LWRK1),1,L2)
C        EEFP=TRACEP(X(LWRK2),X(LWRK1),0)
C     END IF
C
C   HERE WE DEFINE EEFP AS THE INTERACTION OF THE EFP(MULTIPOLE
C   POINTS AND POLARIZABLE POINTS) WITH THE BUFFER ZONE DENSITY
C   I.E. (1)BUFFER ELECTRON -- MULTIPOLE POINTS
C        (2)BUFFER ELECTRON -- POLARIZABLE POINTS(INDUCED DIPOLE)
C   ANY PCM ASC ASSOCIATED INTERACTION IS NOT CONSIDERED AS A
C   PART OF EEFP.
C
      IF(NBUFMO.GT.0) THEN
         CALL DAREAD(IDAF,IODA,X(LVA),L3,15,0)
         CALL DMTX(X(LWRK4),X(LVA),X(LAOC),NBUFMO,L1,L1)
         IF(NB.GT.0) THEN
           CALL DAREAD(IDAF,IODA,X(LVB),L3,19,0)
           CALL DMTX(X(LWRK3),X(LVB),X(LBOC),NBUFMO,L1,L1)
           CALL VADD(X(LWRK3),1,X(LWRK4),1,X(LWRK4),1,L2)
         END IF
         CALL DAREAD(IDAF,IODA,X(LWRK2),L2,319,0)
         CALL VSUB(X(LWRK2),1,X(LH1),1,X(LWRK2),1,L2)
C
        IF(IPCMIT.EQ.0) THEN
          IF(IPCM.EQ.1) THEN
             CALL DAREAD(IDAF,IODA,X(LWRK3),L2,263,0)
             CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
             CALL DAREAD(IDAF,IODA,X(LWRK3),L2,264,0)
             CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
          END IF
          IF(IPCFP) THEN
             CALL DAREAD(IDAF,IODA,X(LWRK3),L2,263,0)
             CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
             CALL DAREAD(IDAF,IODA,X(LWRK3),L2,264,0)
             CALL VSUB(X(LWRK3),1,X(LWRK2),1,X(LWRK2),1,L2)
             CALL VSUB(X(LVEC_2),1,X(LWRK2),1,X(LWRK2),1,L2)
          END IF
        END IF
C
        EEFP= TRACEP(X(LWRK4),X(LWRK2),L1)
      ELSE
        EEFP = ZERO
      END IF
C
      EHF0 = EHF
      EHFA = TRACEP(X(LDA),X(LH1),L1) + TRACEP(X(LDA),X(LFA),L1)
      EHFB = TRACEP(X(LDB),X(LH1),L1) + TRACEP(X(LDB),X(LFB),L1)
      EHF  = (EHFA+EHFB)/TWO
      EHF  = EHF+EXENA+EXENB+EXENC+EEXC-EDFA-EDFB+EHNCO
      IF(NBUFMO.GT.0) EHF = EHF - EEFP
C
      ETOT0= ETOT
      ETOT = EHF+EN
C
C        ---- SOLVENT ENERGY CORRECTIONS ----
C     NOTE: ONSAGER MODEL PUT FREE ENERGY CORRECTIONS INTO -EN- ALREADY
C
C     IF PCM: CALCULATE THE CORRECT VARIATIONAL FREE ENERGY
C
      IF(IPCMIT.EQ.0) THEN
         IF(IPCM.EQ.1.OR.IPCFP) ETOT=ETOT-HALF*(PB-PC)
      ELSE
         IF(IPCM.EQ.1.OR.IPCFP) ETOT=ETOT+HALF*PX
      END IF
      IF(IPCM.EQ.1) THEN
        ETOT=ETOT+(GCAVP+GDISP+GREP)/627.509541D+00
      END IF
C
C     SVP MODEL'S FREE ENERGY CORRECTION IS
C     +HALF*ATMSVP SINCE IT HAS NOT YET BEEN ACCOUNTED FOR, BUT
C     -HALF*ELCSVP SINCE EHF ALREADY IMPLICITLY CONTAINS ELCSVP
C
      IF(ISVP.EQ.1) THEN
         ETOT=ETOT+HALF*(ATMSVP-ELCSVP)
      END IF
C
      DELE0= DELE
      DELE = ETOT-ETOT0
C
      IF(NDFTFG.EQ.1.AND.ABINIT.AND.DIRSCF.AND.FDIFF) THEN
        CALL DDI_GSUMF(2312,X(LFXCA),L2)
        CALL DDI_GSUMF(2313,X(LFXCB),L2)
        CALL VADD(X(LFA),1,X(LFXCA),1,X(LFA),1,L2)
        CALL VADD(X(LFB),1,X(LFXCB),1,X(LFB),1,L2)
      END IF
C
C     THIS IS SOMETHING LEFT OVER FROM THE MINNESOTA SOLVENT CODES.
C     MODIFY FOCK MATRIX WITH GENERALIZED BORN MODEL
C
C-SM5-CALL REACTF(ETOT)
C-SM5-CALL GBSCRF(X(LFA),L1)
C-SM5-CALL GBSCRF(X(LFB),L1)
C
      IF(ITER.EQ.1) DEAVG = ZERO
      IF(ITER.EQ.2) DEAVG = ABS(DELE)
      IF(ITER.GE.3) DEAVG = (ABS(DELE)+ABS(DELE0)+PT2*DEAVG)/TWOPT2
C
C     KURT'S TRICK TO MAKE DIIS SWITCH OFF IF ENERGY RISES
C     ON ANY ITERATION MORE THAN IT WENT DOWN ON THE PREVIOUS
C     ITERATION.  PRESENTLY APPLIED ONLY FOR THE UHF CASE, WHICH
C     SOMETIMES DOES THIS, LOCKING ONTO A LESS SPIN-CONTAMINATED
C     HIGHER ENERGY SOLUTION.  HOPEFULLY, SHUTTING DIIS OFF
C     WILL LET THE PROGRAM CONTINUE DOWNWARD IN ENERGY, UNTIL
C     EVENTUALLY DIIS CAN TURN ON AGAIN (NOTE THAT -DIISDMP-
C     LOWERS THE ETHRSH FOR EVENTUALLY RE-ENGAGING DIIS).
C     THE NON-DIIS ITERATION COUNTER ENSURES THAT IF DIIS
C     GOES OFF, IT SHOULD STAY OFF FOR -NONDMX- ITERATIONS.
C     DIISDMP AND NONDMX ARE CLEARLY ADJUSTABLE PARAMETERS.
C     SET UP FOR EXTRAPOLATION/DAMPING WHILE DIIS IS OFF.
C
      IF(SCFTYP.EQ.UHF  .AND.
     *   DODIIS  .AND.  ITDIIS.NE.1  .AND.  ITNOND.GT.NONDMX  .AND.
     *   DELE.GT.ZERO  .AND.  DELE.LT.0.005D+00  .AND.
     *  (DELE+DELE0).GT.1.0D-06) THEN
C           READ IN FOCK MATRIX FROM ONE OR TWO ITERATIONS BEFORE
         LRAFFA= MAXDII*2
         LRAFFB= MAXDII*3
C           IF THE LAST TWO STEPS HAVE BEEN UPHILL, GRAB TWO ITERS AGO.
C           IF ONLY THE LAST ONE STEP IS UPHILL, GRAB FROM ONE ITER AGO.
         IF (DELE0 .GT. 0) THEN
           IDUMMY = MOD(ITDIIS-3,MAXDII) + 1
         ELSE
           IDUMMY = MOD(ITDIIS-2,MAXDII) + 1
         END IF
C           JUST TO BE SAFE (DON'T WANT NONEXISTANT RECORDS)
         IF (IDUMMY .LT. 1) IDUMMY = 1
         LFCKA = LRAFFA + IDUMMY
         LFCKB = LRAFFB + IDUMMY
         CALL RAREAD(IRAF,X(LIODII),X(LFA),L2,LFCKA,0)
         CALL RAREAD(IRAF,X(LIODII),X(LFB),L2,LFCKB,0)
C
         ITDIIS=1
         ITNOND=0
         IF(.NOT.NOTOPN) CALL RACLOS(20,'DELETE')
         NOTOPN=.TRUE.
         ETHNEW = MIN(ERDIIS,ETHRSH) * DIISDMP
         IF(MASPRT) WRITE(IW,9235) NONDMX,ETHNEW
         CVGING=.FALSE.
         ITERLV=0
         RRSHFT=ZERO
         IF(DAMPH .OR. VSHIFT) DAMP = ONE
         CALL WDISK(X(LFA),X(LFA),X(LFA),NDAFA,L2)
         CALL WDISK(X(LFB),X(LFB),X(LFB),NDAFB,L2)
C            MAKE SURE WE DON'T ACCIDENTALLY SWITCH TO FINE DFT GRID
         IF(NDFTFG.EQ.1) SWGROK=.FALSE.
      END IF
C
C     NOW STOP SOSCF IF NEEDED
C
      IF(SCFTYP.EQ.UHF  .AND.  SOSCF  .AND. ITSO.GT.0 .AND.
     *   DELE.GT.ZERO  .AND.  DELE.LT.0.005D+00  .AND.
     *  (DELE+DELE0).GT.1.0D-08) THEN
         ITSO=0
         ITNOND = 0
         SOGNEW = MIN(ORBGRD,SOGTOL) * DIISDMP
         CVGING=.FALSE.
         ITERLV=0
         RRSHFT=ZERO
         IF(DAMPH .OR. VSHIFT) DAMP = ONE
         IF(MASPRT) WRITE(IW,9236) NONDMX,SOGNEW
         CALL WDISK(X(LFA),X(LFA),X(LFA),NDAFA,L2)
         CALL WDISK(X(LFB),X(LFB),X(LFB),NDAFB,L2)
         IF(NDFTFG.EQ.1) SWGROK=.FALSE.
      END IF
C
      ITNOND = ITNOND+1
      ETHRSH = ETHSAV
      SOGTOL = SOGNEW
      IF(ITNOND.LE.NONDMX) ETHRSH = ZERO
      IF(ITNOND.LE.NONDMX) SOGTOL = ZERO
C
C     ----- POSSIBLE SECOND ORDER SCF -----
C     ON THE VERY FIRST ITERATION OF THE VERY FIRST GEOMETRY, WE MUST
C     DO A DIAGONALIZATION TO GET EIGENVALUES TO APPROX. THE HESSIAN.
C     ALL THREE -LWRK- WORK ARRAYS ARE AVAILABLE FOR SCRATCH USAGE.
C
      EIGAVL = ITER.GT.1  .OR.  NEVALS.GE.1
      IF(RUNTYP.EQ.HESS) EIGAVL = ITER.GT.1
      IF(NFG.NE.1)       EIGAVL = ITER.GT.1
C
      IF(SOSCF .AND.  EIGAVL) THEN
         IF(SCFTYP.EQ.ROHF) THEN
            IF (NDFTFG.EQ.0) THEN
               CALL DAWRIT(IDAF,IODA,X(LFA)  ,L2,51,0)
            ELSE
               CALL DAREAD(IDAF,IODA,X(LWRK1),L2,14,0)
               CALL DAWRIT(IDAF,IODA,X(LWRK1),L2,51,0)
            END IF
         END IF
C
         CALL SOGRAD(X(LGRADA),X(LFA),X(LVA),X(LSCR),NPRA,NA,
     *               L0,L1,ORBGRA)
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0005                      FLGU
C-------------------------------------------------------------------FLGU
         IF(ELGSO) THEN
            IF(SCFTYP.EQ.UHF) CALL SOELG(X(LGRADA),NPRA,ORBGRA,L0,NA,
     *           NOCAA,NVCAA)
            IF(SCFTYP.EQ.ROHF) CALL SORELG(X(LGRADA),NPRA,ORBGRA,L0,
     *           NA,NB,NOCAA,NVCAA,NOCAB,NVCAB,1)
         ENDIF
         IF(NB.GT.0) THEN
            CALL SOGRAD(X(LGRADB),X(LFB),X(LVB),X(LSCR),NPRB,NB,
     *                  L0,L1,ORBGRB)
            IF(ELGSO) THEN
               IF(SCFTYP.EQ.UHF) CALL SOELG(X(LGRADB),NPRB,ORBGRB,L0,NB,
     *                                            NOCAB,NVCAB)
               IF(SCFTYP.EQ.ROHF) CALL SORELG(X(LGRADB),NPRB,ORBGRB,L0,
     *                             NA,NB,NOCAA,NVCAA,NOCAB,NVCAB,2)
            ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0005                        FLGU
C-------------------------------------------------------------------FLGU
         ELSE
            ORBGRB=ZERO
         END IF
         ORBGRD = MAX(ORBGRA,ORBGRB)
         IF(SCFTYP.EQ.ROHF) CALL SOGRRO(X(LGRADO),X(LGRADA),
     *                                  X(LGRADB),NPRO,NPRA,NPRB,
     *                                  L0,NA,NB,ORBGRD)
C
         IF(ORBGRD.LT.SOGTOL  .OR.  ITSO.GT.0) THEN
            ITERLV=0
            RRSHFT=ZERO
            IF(DAMPH .OR. VSHIFT) DAMP = ONE
            IF(ITSO.EQ.0) THEN
              DAMP = ZERO
              RRSHFT = ZERO
              IF(MASPRT) WRITE(IW,9200)
              IF(SCFTYP.EQ.UHF) THEN
                CALL SOHESS(X(LHESSA),X(LEA),NPRA,L0,NA,NA)
                IF(NB.GT.0) CALL SOHESS(X(LHESSB),X(LEB),NPRB,L0,NB,NB)
              ELSE
                CALL SOHESS(X(LHESSO),X(LEA),NPRO,L0,NA,NB)
              END IF
            END IF
C
            ITSO = ITSO+1
            IF(SCFTYP.EQ.UHF) THEN
               CALL SONEWT(X(LHESSA),X(LGRADA),X(LPGRADA),X(LDISPLA),
     *                     X(LWRK1),X(LWRK2),X(LWRK3),
     *                     X(LWRK1+NPRA),X(LWRK2+NPRA),X(LWRK3+NPRA),
     *                     ORBGRA,NPRA,ITSO,NFT15)
               IF(ORBGRD.EQ.-123) GO TO 550
               CALL SOTRAN(X(LDISPLA),X(LVA),X(LWRK1),X(LSCR),
     *                     NPRA,L0,L1,NA,NA,ORBGRA)
               CALL DCOPY(NPRA,X(LGRADA),1,X(LPGRADA),1)
               IF(NB.GT.0) THEN
               CALL SONEWT(X(LHESSB),X(LGRADB),X(LPGRADB),X(LDISPLB),
     *                     X(LWRK1),X(LWRK2),X(LWRK3),
     *                     X(LWRK1+NPRB),X(LWRK2+NPRB),X(LWRK3+NPRB),
     *                     ORBGRB,NPRB,ITSO,NFT16)
               IF(ORBGRD.EQ.-123) GO TO 550
               CALL SOTRAN(X(LDISPLB),X(LVB),X(LWRK1),X(LSCR),
     *                     NPRB,L0,L1,NB,NB,ORBGRB)
               CALL DCOPY(NPRB,X(LGRADB),1,X(LPGRADB),1)
           ENDIF
            END IF
            IF(SCFTYP.EQ.ROHF) THEN
               CALL SONEWT(X(LHESSO),X(LGRADO),X(LPGRADO),X(LDISPLO),
     *                     X(LWRK1),X(LWRK2),X(LWRK3),
     *                     X(LWRK1+NPRO),X(LWRK2+NPRO),X(LWRK3+NPRO),
     *                     ORBGRD,NPRO,ITSO,NFT15)
               IF(ORBGRD.EQ.-123) GO TO 550
               CALL SOTRAN(X(LDISPLO),X(LVA),X(LWRK1),X(LSCR),
     *                       NPRO,L0,L1,NA,NB,DUMMY)
               CALL DCOPY(NPRO,X(LGRADO),1,X(LPGRADO),1)
            END IF
            GO TO 400
         END IF
      END IF
C
C     ----- ASSEMBLE THE HIGH SPIN ROHF TOTAL FOCK MATRIX -----
C     -LWRK1- IS TRIANGULAR, -LWRK2- IS SQUARE SCRATCH STORAGE.
C
      IF(SCFTYP.EQ.ROHF) THEN
         IF (NDFTFG.EQ.0) THEN
            CALL DAWRIT(IDAF,IODA,X(LFA)  ,L2,51,0)
         ELSE
            CALL DAREAD(IDAF,IODA,X(LWRK1),L2,14,0)
            CALL DAWRIT(IDAF,IODA,X(LWRK1),L2,51,0)
         END IF
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
         CALL ROFOCK(X(LFA),X(LFB),X(LWRK1),X(LVA),X(LSCR),X(LS),
     *               X(LWRK2),NA,NB,0,L0,L1,L2,L3,DBG)
         CALL DAWRIT(IDAF,IODA,X(LFA),L2,14,0)
      END IF
C
C     ----- PERFORM DIIS INTERPOLATION -----
C     THE TOTAL DIIS ERROR MATRIX IS FORMED AT -LWRK3-
C     FOR ROHF, ERR = F*D*S-S*D*F, WHERE D=DA+DB.
C     FOR  UHF, ERR = FA*DA*S-S*DA*FA + FB*DB*S-S*DB*FB.
C     -LWRK1,LWRK2,LWRK3- ARE USED AS SQUARE STORAGE.
C
      IF(DODIIS) THEN
         IF(SCFTYP.EQ.ROHF) THEN
            CALL VADD(X(LDB),1,X(LDA),1,X(LDA),1,L2)
            IF(ABINIT) THEN
               IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
               CALL EXPND(X(LFA),X(LWRK1),L1,0)
               CALL EXPND(X(LS),X(LWRK2),L1,0)
               CALL DIISER(X(LWRK1),X(LDA),X(LWRK2),X(LWRK3),X(LSCR),
     *                     L1,L2,1,1)
            ELSE
               CALL EXPND(X(LFA),X(LWRK1),L1,0)
               CALL EXPND(X(LDA),X(LWRK2),L1,0)
               CALL MRARBR(X(LWRK1),L1,L1,L1,X(LWRK2),L1,L1,X(LWRK3),L1)
               CALL SUBMT(X(LWRK3),L1)
            END IF
            CALL VSUB(X(LDB),1,X(LDA),1,X(LDA),1,L2)
         END IF
C
         IF(SCFTYP.EQ.UHF) THEN
            IF(ABINIT) THEN
               IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
               CALL EXPND(X(LS),X(LWRK2),L1,0)
               CALL EXPND(X(LFA),X(LWRK1),L1,0)
               CALL DIISER(X(LWRK1),X(LDA),X(LWRK2),X(LWRK3),X(LSCR),
     *                     L1,L2,1,1)
               CALL EXPND(X(LFB),X(LWRK1),L1,0)
               CALL DIISER(X(LWRK1),X(LDB),X(LWRK2),X(LWRK4),X(LSCR),
     *                     L1,L2,1,1)
            ELSE
               CALL EXPND(X(LFA),X(LWRK1),L1,0)
               CALL EXPND(X(LDA),X(LWRK2),L1,0)
               CALL MRARBR(X(LWRK1),L1,L1,L1,X(LWRK2),L1,L1,X(LWRK3),L1)
               CALL EXPND(X(LDB),X(LWRK1),L1,0)
               CALL MTARBR(X(LFB),L1,X(LWRK1),L1,X(LWRK2),L1,1)
               CALL VADD(X(LWRK3),1,X(LWRK2),1,X(LWRK3),1,L3)
               CALL SUBMT(X(LWRK3),L1)
            END IF
         END IF
C
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
         CALL DIIS(SCFTYP,IW,ITDIIS,X(LQ),X(LFA),X(LFB),X(LWRK3),
     *             X(LWRK4),X(LWRK1),X(LADIIS),X(LXDIIS),X(LPDIIS),
     *             X(LBDIIS),X(LIODII),X(LSCR),L1,L2,L3,MAXIT,MAXIT2,
     *             4*MAXDII,ERDIIS,NOTOPN,MASWRK)
         IF(ITDIIS.GT.1) THEN
            ITERLV=0
            RRSHFT=ZERO
            IF(DAMPH .OR. VSHIFT) DAMP = ONE
         END IF
      END IF
C
C                    ******************
C                    * ALPHA ORBITALS *
C                    ******************
C
C     ----- BEGIN CONVERGENCE ACCELERATION STEPS -----
C        SKIP ALL OF THESE IF THE RUN IS CONVERGING
C        OR IF DIIS INTERPOLATION IS ON (ITDIIS.GT.1).
C
C     ----- DAMP AND EXTRAPOLATE THE ALPHA FOCK MATRIX -----
C     -LFA-   CURRENT FOCK MATRIX.
C     -LWRK1- SCRATCH AREA WITH OLD FOCK MATRIX (N-1 TH MATRIX)
C     -LWRK2- SCRATCH AREA WITH ANCIENT FOCK MATRIX (N-2 TH MATRIX)
C     -LWRK3- SCRATCH AREA WITH PREHISTORIC FOCK MATRIX (N-3 TH MATRIX)
C
      IF((DAMPH.AND.ITER.GT.2)  .AND.  ITDIIS.EQ.1
     *         .AND.   .NOT.CVGING)
     *   CALL DAMPD(DELE,DELE0,DEAVG,DAMP,DENTOL,DIFF,DIFFP,DMPTLC)
      IF(DAMP .LT. DMPCUT) DAMP = DMPCUT
C
      IF((EXTRAH.OR.DAMPH)  .AND.  ITDIIS.EQ.1   .AND.  .NOT.CVGING)
     *   CALL EXTRAP(DELE,DAMP,DAMP0,X(LFA),X(LWRK1),X(LWRK2),
     *               X(LWRK3),L1,L2,L2,NDAFA,ITERV,1,1)
      IF(ICALP.EQ.0) ICAB=0
C
C     ----- OPTIONAL LEVEL SHIFTING OF ALPHA FOCK MATRIX -----
C     LWRK1,LWRK2 USED AS SYMMETRIC, LWRK3 AS SQUARE SCRATCH STORAGE
C
      IF(VSHIFT  .AND.  ITDIIS.EQ.1) THEN
         IF(SCFTYP.EQ.ROHF) THEN
            NDOCC = NB
            NHOCC = NA - NB
         ELSE
            NDOCC = NA
            NHOCC = 0
         END IF
         ITERLV=ITERLV+1
         CALL LEVELS(X(LFA),X(LS),X(LVA),X(LWRK1),X(LWRK2),X(LWRK3),
     *               X(LSCR),L0,L1,L2,L3,ITERLV,NDOCC,NHOCC,DELE,DELE0,
     *               DIFF,ITERV,1,EXTRAH,CVGING)
      END IF
C
C     ----- TRANSFORM ALPHA FOCK MATRIX TO -Q- ORTHONORMAL BASIS -----
C     ----- DIAGONALIZE ALPHA FOCK MATRIX -----
C     ----- BACK-TRANSFORM TO AO BASIS -----
C
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0006                      FLGU
C-------------------------------------------------------------------FLGU
      IF(SCFTYP.EQ.ROHF) THEN
        MOPAC = 1
        IF(ABINIT) MOPAC = 0
            ITERTMP = ITER
            CALL ELGUHF(NAAO,NWA,NWM,JXX,NUM,LS,LFA,LVA,
     *           LSW,LCBMA,LCXAL,MJBIG,MBIG,
     *           MSLMO,MFLMO,MWRK1,MTMP,LAD,LSM,LFM,
     *           MEIG,LSDG,MVEC,NOCCA,NOCAB,
     *           NOCBMA,NOCBMB,ITERTMP,MOPAC)
      ELSE
C
C    1. TRANSFORM F(AO)-MAT TO LMO BASIS
C
         CALL TFTRI(X(MFLMO),X(LFA),X(LCBMA),X(MWRK1),NWM,NWA,NWA)
C
C    2. SOLVE SCF EQUATIONS
C
         CALL GLDIAG(NWM,NWM,NWM,X(MFLMO),X(MJBIG),X(MEIG),X(MVEC),
     *      IERR,X(MBIG))
C
C    3. GO TO AO BASIS FROM LMO BASIS, OBTAIN WHOLE SYSTEM C
C
C       IF(SCFTYP.EQ.ROHF) THEN
C          CALL MOAORO(X(MVEC),X(LCBMA),X(LCXAL),X(MTMP),X(LVA),
C     *        NUM,NAAO,JXX,NOCAA,NOCBMA,NOCAB,NOCBMB,ITER)
C       ELSE
          CALL MOTRAO(X(MVEC),X(LCBMA),X(LCXAL),X(MTMP),X(LVA),
     *        NUM,NAAO,JXX,NOCCA,NOCAA,NOCBA,NOCBMA,ITER)
C
       ENDIF
C
            IF(ELGSO) THEN
               CALL VCLR(X(LEA),1,NUM)
               DO I=1,NOCBA+NOCMA
                  X(LEA+NOCAA+I-1)=X(MEIG+I-1)
               ENDDO
               DO I=1,NVCBA+NVCMA
                  X(LEA+NOCCA+NVCAA+I-1)=X(MEIG+NOCBA+NOCMA+I-1)
               ENDDO
               CALL SCHMELG(X(LVA),X(LS),X(MWRK1),NUM,
     *              NUM,NUM,NOCAA,NOCCA,NVCAA)
            ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0006                        FLGU
C-------------------------------------------------------------------FLGU
C
C                   *****************
C                   * BETA ORBITALS *
C                   *****************
C
C     FOR ROHF, WE JUST NEED TO FORM THE DENSITY MATRICES.
C
      IF(NB.EQ.0) GO TO 400
      IF(SCFTYP.EQ.ROHF) GO TO 400
C
C     ----- DAMP AND EXTRAPOLATE THE BETA FOCK MATRIX -----
C     -LWRK1-, -LWRK2-, -LWRK3- USED AS TRIANGULAR SCRATCH SPACE
C
      IF(EXTRAH  .AND.  ITDIIS.EQ.1  .AND.  .NOT.CVGING)
     *    CALL EXTRAP(DELE,DAMP,DAMP0,X(LFB),X(LWRK1),X(LWRK2),
     *                X(LWRK3),L1,L2,L2,NDAFB,ITERV,2,1)
      IF(ICBET.EQ.0) ICAB=0
C
C     ----- OPTIONAL LEVEL SHIFTING OF BETA FOCK MATRIX -----
C     LWRK1,LWRK2 USED AS SYMMETRIC, LWRK3 AS SQUARE SCRATCH STORAGE
C
      IF(VSHIFT  .AND.  ITDIIS.EQ.1) THEN
         NDOCC = NB
         NHOCC = 0
         CALL LEVELS(X(LFB),X(LS),X(LVB),X(LWRK1),X(LWRK2),X(LWRK3),
     *               X(LSCR),L0,L1,L2,L3,ITERLV,NDOCC,NHOCC,DELE,DELE0,
     *               DIFF,ITERV,2,EXTRAH,CVGING)
      END IF
C
C     ----- TRANSFORM BETA FOCK MATRIX TO -Q- ORTHONORMAL BASIS -----
C     ----- DIAGONALIZE BETA FOCK MATRIX -----
C     ----- BACK-TRANSFORM TO AO BASIS -----
C
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0007                      FLGU
C-------------------------------------------------------------------FLGU
C
C    1. TRANSFORM F(AO)-MAT TO LMO BASIS
C
         CALL TFTRI(X(MFLMO),X(LFB),X(LCBMB),X(MWRK1),NWM,NWA,NWA)
C
C    2. SOLVE SCF EQUATIONS
C
         CALL GLDIAG(NWM,NWM,NWM,X(MFLMO),X(MJBIG),X(MEIG),X(MVEC),
     *      IERR,X(MBIG))
C
C    3. GO TO AO BASIS FROM LMO BASIS, OBTAIN WHOLE SYSTEM C
C
          CALL MOTRAO(X(MVEC),X(LCBMB),X(LCXBT),X(MTMP),X(LVB),
     *        NUM,NAAO,JXX,NOCCB,NOCAB,NOCBB,NOCBMB,ITER)
C
         IF(ELGSO) THEN
           DO I=1,NOCBB+NOCMB
            X(LEB+NOCAB+I-1)=X(MEIG+I-1)
           ENDDO
           DO I=1,NVCBB+NVCMB
            X(LEB+NOCCB+NVCAB+I-1)=X(MEIG+NOCBB+NOCMB+I-1)
           ENDDO
           CALL SCHMELG(X(LVB),X(LS),X(MWRK1),NUM,
     *          NUM,NUM,NOCAB,NOCCB,NVCAB)
         ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0007                        FLGU
C-------------------------------------------------------------------FLGU
  400 CONTINUE
C
C     ----- OPTIONAL RESTRICTION OF ORBITAL INTERCHANGES -----
C     READ PREVIOUS ITERATION'S ORBITALS TO -LWRK1-
C
      IF(RSTRCT.OR.MFRZ) THEN
         CALL DAREAD(IDAF,IODA,X(LWRK1),L3,15,0)
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
         CALL OVLSEL(X(LVA),X(LEA),X(LWRK1),X(LS),X(LWRK2),X(LSCR),
     *               X(LIWRK),X(LSCR),L0,L1,L2)
         IF(SCFTYP.EQ.UHF  .AND.  NB.GT.0) THEN
            CALL DAREAD(IDAF,IODA,X(LWRK1),L3,19,0)
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
            CALL OVLSEL(X(LVB),X(LEB),X(LWRK1),X(LS),X(LWRK2),X(LSCR),
     *                  X(LIWRK),X(LSCR),L0,L1,L2)
         END IF
      END IF
C
      IF(DBG) THEN
         WRITE(IW,*) 'NEW ALPHA ORBITALS'
         CALL PREV(X(LVA),X(LEA),L0,L1,L1)
         IF(SCFTYP.EQ.UHF  .AND.  NB.GT.0) THEN
            WRITE(IW,*) 'NEW BETA ORBITALS'
            CALL PREV(X(LVB),X(LEB),L0,L1,L1)
         END IF
      END IF
C
C     ----- FORM NEW ALPHA AND BETA DENSITY MATRIX -----
C     FORMER DENSITY MATRICES ARE COPIED TO -LWRK1- AND -LWRK2-
C
      CALL DCOPY(L2,X(LDA),1,X(LWRK1),1)
      CALL DMTX(X(LDA),X(LVA),X(LAOC),NA,L1,L1)
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0008                      FLGU
C-------------------------------------------------------------------FLGU
       IF(LCUT) THEN
        DO I=0,NDOFF-1
          X(LDA+I)=X(LDA+I) + X(LDAOFF+I)
        ENDDO
         CALL DENCUT(X(LDA),X(LD1A),X(LDATOT),NUMOLD,NFRGBS,
     *               L2,NDIM2,NTOTAL)
       ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0008                        FLGU
C-------------------------------------------------------------------FLGU
      CALL DDIFF(X(LWRK1),X(LDA),L2,DIFFA)
      IF(NB.GT.0) THEN
         CALL DCOPY(L2,X(LDB),1,X(LWRK2),1)
         CALL DMTX(X(LDB),X(LVB),X(LBOC),NB,L1,L1)
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0009                      FLGU
C-------------------------------------------------------------------FLGU
       IF(LCUT) THEN
        DO I=0,NDOFF-1
          X(LDB+I)=X(LDB+I) + X(LDBOFF+I)
        ENDDO
         CALL DENCUT(X(LDB),X(LD1B),X(LDBTOT),NUMOLD,NFRGBS,
     *               L2,NDIM2,NTOTAL)
       ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0009                        FLGU
C-------------------------------------------------------------------FLGU
         CALL DDIFF(X(LWRK2),X(LDB),L2,DIFFB)
      ELSE
         CALL VCLR(X(LWRK2),1,L2)
         IF(SCFTYP.EQ.ROHF) THEN
            CALL VCLR(X(LDB),1,L2)
         ELSE
            CALL ZEROD(X(LVB),X(LDB),X(LEB),L1,L2,L3)
         END IF
         DIFFB=ZERO
      END IF
      DIFFP = DIFF
      DIFF  = DIFFA+DIFFB
      IF(DBG) THEN
         WRITE(IW,*) 'NEW ALPHA DENSITY MATRIX'
         CALL PRTRIL(X(LDA),L1)
         WRITE(IW,*) 'NEW BETA DENSITY MATRIX'
         CALL PRTRIL(X(LDB),L1)
         WRITE(IW,*) '*** END OF DEBUG OUTPUT FOR ITERATION',ITER
      END IF
C
C     THIS IS SOMETHING LEFT OVER FROM THE MINNESOTA SOLVENT CODES.
C     CALCULATE CM2 CHARGE AND REACTION FIELD
C
C-SM5-CALL CM2CHG(L1,X(LDA),X(LDB),0)
C
C     ----- RESTORE ALPHA ONLY PART OF FOCK MATRIX -----
C
      IF(SCFTYP.EQ.ROHF) THEN
         CALL DAREAD(IDAF,IODA,X(LFA),L2,51,0)
         CALL DAWRIT(IDAF,IODA,X(LFA),L2,14,0)
      END IF
C
C     ----- PRINT THIS ITERATION'S RESULTS -----
C
      IF(MASPRT) THEN
         IF(SOSCF) THEN
            ERRORC = ORBGRD
         ELSE
            ERRORC = ERDIIS
         END IF
      IF(DAMPH  .OR.  VSHIFT) THEN
         IF(DIRSCF) THEN
            WRITE(IW,9070) ITER,ICAB,ETOT,DELE,DIFF,ERRORC,RRSHFT,DAMP,
     *                     NINT,NSCHWZ
         ELSE
            WRITE(IW,9070) ITER,ICAB,ETOT,DELE,DIFF,ERRORC,RRSHFT,DAMP
         END IF
      ELSE
         IF(DIRSCF) THEN
            WRITE(IW,9075) ITER,ICAB,ETOT,DELE,DIFF,ERRORC,NINT,NSCHWZ
         ELSE
            WRITE(IW,9075) ITER,ICAB,ETOT,DELE,DIFF,ERRORC
         END IF
      END IF
      CALL FLSHBF(IW)
      END IF
      ICALP = ICALP+1
      ICBET = ICBET+1
      ICAB  = ICAB+1
C
C     ----- CHECK CONVERGENCE BEHAVIOR -----
C
      CVDENS = (DIFF.LT.DENTOL  .AND.  ABS(DELE).LT.ETOL2) .OR.
     *         (DIFF.LT.DENTOL/FIVE)
      CVENGY = ABS(DELE).LT.ETOL  .AND.  DIFF.LT.DTOL2
      IF(DODIIS) CVDIIS = ERDIIS.LT.DIITOL  .AND.  DIFF.LT.DTOL2
      CVGED  = CVGING  .AND.  (CVDENS.OR.CVENGY.OR.CVDIIS)
      CVGED  = CVGED  .AND.  ISWOFF.EQ.0
      IF(NDFTFG.EQ.1) CVGED = CVGED  .AND.  GRIDTYP.EQ.FINE
      CVGING = CVDENS.OR.CVENGY.OR.CVDIIS
C
      IF(ISVP.EQ.1) THEN
         CVGED  = CVGED   .AND.  CVGSVP
         CVGING = CVGING  .AND.  CVGSVP
         CVGSVPNR = DIFF  .LT.  100.0D+00 * DENTOL
         CVGSVPDN = CVGING
         CVGSVPDN1 = CVGING
      END IF
C
C         TURN ON THE DFT IF PRELIMINARY SCF IS BECOMING CONVERGED.
C
      IF(ISWOFF.GT.0.AND.DIFF.LT.SWOFF) THEN
        IF(MASWRK) WRITE(IW,9355)
        DFTTYP(3)=HFSSAV
        NDFTFG=NDFTSV
        ISWOFF=0
        IDFTSWITCH=1
      END IF
C
C         DFT MUST SWITCH TO A TIGHTER GRID AS IT NEARS CONVERGENCE.
C
      IF(NDFTFG.EQ.1.AND.DIFF.LT.SWDFT  .AND.  SWGROK) THEN
         IF(NRAD*NPHI*NTHE.LT.NRAD0*NPHI0*NTHE0) THEN
            IF(MASPRT) WRITE(IW,9330)
            CALL SWGRID
            GRIDTYP = FINE
            CALL DFTSET(X(IGRDDFT),0,.FALSE.)
            IDFTSWITCH=2
         END IF
      END IF
C
C       SWITCH FROM DIIS TO SOSCF!
C       OBVIOUSLY SUCH SWITCH CAN BE DONE ONLY ONCE IN ANY RUN.
C       NOTE THAT DENSITY DIFFERENCING (FDIFF) NEED NOT BE RESET.
C
      IF(DODIIS  .AND.  SWDIIS.GT.0.0D+00  .AND.  DIFF.LT.SWDIIS) THEN
        ITDIIS=1
        IF(.NOT.NOTOPN) CALL RACLOS(20,'DELETE')
        NOTOPN=.TRUE.
        DODIIS=.FALSE.
        SOSCF=.TRUE.
        IF(NFG.EQ.0) MCONV = MCONV - 16 + 64
        IF(MASWRK) WRITE(IW,9380)
        IDFTSWITCH=4
      END IF
C
C         ANY SUCH SWITCH IN GRIDS OR CONVERGERS MUST RESET CONVERGERS,
C         AND PERHAPS RESET THE DIFFERENTIAL FOCK FORMATION.
C
      IF(IDFTSWITCH.NE.0) THEN
         EXTRAH = .FALSE.
         DAMPH  = .FALSE.
         VSHIFT = .FALSE.
         IF(DODIIS) THEN
           ITDIIS=1
           IF(.NOT.NOTOPN) CALL RACLOS(20,'DELETE')
           NOTOPN=.TRUE.
         END IF
         IF(SOSCF) ITSO=0
         IF(ABINIT .AND. DIRSCF .AND. FDIFF .AND. IDFTSWITCH.NE.4) THEN
           IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LH1),L2,11,0)
           CALL DAWRIT(IDAF,IODA,X(LH1),L2,14,0)
           CALL DAWRIT(IDAF,IODA,X(LH1),L2,18,0)
           CALL VCLR(X(LWRK1),1,L2)
           CALL VCLR(X(LWRK2),1,L2)
         END IF
         IDFTSWITCH=0
      END IF
C
C     THIS IS SOMETHING LEFT OVER FROM THE MINNESOTA SOLVENT CODES.
C     ONCE GAS PHASE CALCULATION IS CONVERGED, ACTIVATE SOLVATION OPTION
C     AND SET ALL CONVERGENCE FLAGS TO NEGATIVE
C
C-SM5-CALL DOSOLV(CVDENS,CVENGY,CVDIIS,CVGING,CVGED,ITDIIS,ITSO)
C
      IF(CVGED .AND. CVDENS) THEN
         IF(MASPRT) WRITE(IW,9080)
         GO TO 600
      END IF
      IF(CVGED .AND. CVENGY) THEN
         IF(MASPRT) WRITE(IW,9090)
         GO TO 600
      END IF
      IF(CVGED .AND. CVDIIS) THEN
         IF(MASPRT) WRITE(IW,9100)
         GO TO 600
      END IF
C
C     ----- EXIT IN CASE OF TIME LIMIT -----
C
      CALL TSECND(TIM1)
      TLEFT = TIMLIM - TIM1
      TIM0 = TIM1
      IF(TLEFT .GT. 2.0D+00*(TLEFTS-TLEFT)/ITER) GO TO 500
      IF(CVGING) THEN
         IF(MASPRT) WRITE(IW,9110)
         GO TO 600
      ELSE
         IF(MASPRT) WRITE(IW,9120)
         GO TO 550
      END IF
  500 CONTINUE
C
C           *********************
C     ***** END OF UHF ITERATIONS *****
C           *********************
C
C     FALLING OUT OF LOOP 500 MEANS WE HAVE FAILED TO CONVERGE
C
      IF(MASPRT) WRITE(IW,9130)
      ITER = MAXIT
C
C     SET ENERGY TO ZERO IF WE'VE FAILED TO CONVERGE
C
  550 CONTINUE
      ETOT = ZERO
      EHF = -EN
C
C     BRANCH TO HERE ON SUCCESFUL CONVERGENCE
C
  600 CONTINUE
C
C     SAVE GRID DFT FOCK MATRICES
C
      IF (NDFTFG.EQ.1.AND.ABINIT.AND.DIRSCF.AND.FDIFF) THEN
         IF (SCFTYP.EQ.ROHF) THEN
            CALL VADD(X(LFA),1,X(LFXCA),1,X(LFA),1,L2)
            CALL DAWRIT(IDAF,IODA,X(LFA),L2,14,0)
            CALL DAREAD(IDAF,IODA,X(LFB),L2,18,0)
            CALL VADD(X(LFB),1,X(LFXCB),1,X(LFB),1,L2)
            CALL DAWRIT(IDAF,IODA,X(LFB),L2,18,0)
         ELSE
            CALL DAWRIT(IDAF,IODA,X(LFA),L2,14,0)
            CALL DAWRIT(IDAF,IODA,X(LFB),L2,18,0)
         END IF
      END IF
C
C     ----- CANONICALIZE THE ORBITALS -----
C 2ND ORDER SCF PROCESS HAS NOT BEEN DIAGONALIZING DURING THE ITERS.
C THE CANONICALIZATION OF ZAPT THEORY MUST BE THAT OF GUEST AND SAUNDERS
C
      IF(MPLEVL.EQ.2  .AND.  OSPT.EQ.ZAPT) THEN
         IF(SOME) WRITE(IW,9230)
         CALL DAREAD(IDAF,IODA,X(LFA),L2,14,0)
         CALL DAREAD(IDAF,IODA,X(LFB),L2,18,0)
         DO 610 I=1,3
            ASAVE(I) = AROHF(I)
            BSAVE(I) = BROHF(I)
            AROHF(I) = HALF
            BROHF(I) = HALF
  610    CONTINUE
      END IF
C
      IF(SOSCF  .OR.  (MPLEVL.EQ.2  .AND.  OSPT.EQ.ZAPT)) THEN
         IF(SCFTYP.EQ.ROHF) THEN
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
            CALL ROFOCK(X(LFA),X(LFB),X(LWRK1),X(LVA),X(LSCR),X(LS),
     *                  X(LWRK2),NA,NB,0,L0,L1,L2,L3,DBG)
         END IF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0010                      FLGU
C-------------------------------------------------------------------FLGU
      IF(SCFTYP.EQ.ROHF) THEN
        MOPAC = 1
        IF(ABINIT) MOPAC = 0
            CALL ELGUHF(NAAO,NWA,NWM,JXX,NUM,LS,LFA,LVA,
     *           LSW,LCBMA,LCXAL,MJBIG,MBIG,
     *           MSLMO,MFLMO,MWRK1,MTMP,LAD,LSM,LFM,
     *           MEIG,LSDG,MVEC,NOCAA,
     *           NOCAB,NOCBMA,NOCBMB,ITER,MOPAC)
      ELSE
C
C    1. TRANSFORM F(AO)-MAT TO LMO BASIS
C
         CALL TFTRI(X(MFLMO),X(LFA),X(LCBMA),X(MWRK1),NWM,NWA,NWA)
C
C    2. SOLVE SCF EQUATIONS
C
         CALL GLDIAG(NWM,NWM,NWM,X(MFLMO),X(MJBIG),X(MEIG),X(MVEC),
     *      IERR,X(MBIG))
C
C    3. GO TO AO BASIS FROM LMO BASIS, OBTAIN WHOLE SYSTEM C
C
          CALL MOTRAO(X(MVEC),X(LCBMA),X(LCXAL),X(MTMP),X(LVA),
     *        NUM,NAAO,JXX,NOCCA,NOCAA,NOCBA,NOCBMA,ITER)
       ENDIF
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0010                        FLGU
C-------------------------------------------------------------------FLGU
         IF(RSTRCT.OR.MFRZ) THEN
            CALL DAREAD(IDAF,IODA,X(LWRK1),L3,15,0)
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
            CALL OVLSEL(X(LVA),X(LEA),X(LWRK1),X(LS),X(LWRK2),X(LSCR),
     *                  X(LIWRK),X(LSCR),L0,L1,L2)
         END IF
         IF(SCFTYP.EQ.ROHF) GO TO 650
         IF(NB.EQ.0) GO TO 650
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : START - 0011                      FLGU
C-------------------------------------------------------------------FLGU
C
C    1. TRANSFORM F(AO)-MAT TO LMO BASIS
C
         CALL TFTRI(X(MFLMO),X(LFB),X(LCBMB),X(MWRK1),NWM,NWA,NWA)
C
C    2. SOLVE SCF EQUATIONS
C
         CALL GLDIAG(NWM,NWM,NWM,X(MFLMO),X(MJBIG),X(MEIG),X(MVEC),
     *      IERR,X(MBIG))
C
C    3. GO TO AO BASIS FROM LMO BASIS, OBTAIN WHOLE SYSTEM C
C
          CALL MOTRAO(X(MVEC),X(LCBMB),X(LCXBT),X(MTMP),X(LVB),
     *        NUM,NAAO,JXX,NOCCB,NOCAB,NOCBB,NOCBMB,ITER)
C-------------------------------------------------------------------FLGU
C  JACEK KORCHOWIEC                                                 FLGU
C  MODIFY GAMESS FOR ELONGATION : END - 0011                        FLGU
C-------------------------------------------------------------------FLGU
         IF(RSTRCT.OR.MFRZ) THEN
            CALL DAREAD(IDAF,IODA,X(LWRK1),L3,15,0)
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
            CALL OVLSEL(X(LVB),X(LEB),X(LWRK1),X(LS),X(LWRK2),
     *                  X(LSCR),X(LIWRK),X(LSCR),L0,L1,L2)
         END IF
      END IF
C
  650 CONTINUE
      IF(MPLEVL.EQ.2  .AND.  OSPT.EQ.ZAPT) THEN
         DO 660 I=1,3
            AROHF(I) = ASAVE(I)
            BROHF(I) = BSAVE(I)
  660    CONTINUE
      END IF
C
C     ----- PRINT FINAL RESULTS -----
C
      IF(MASPRT) THEN
         WRITE(IW,9140) METHOD(1:LENMTH),ETOT,ITER
         IF(DFTTYP(1) .NE. 0.0D+00) THEN
            WRITE(IW,9210) EXENA
            WRITE(IW,9220) EXENB
         END IF
         IF(NDFTFG.EQ.1) THEN
            WRITE(IW,9320) EEXC
            WRITE(IW,9310) TOTELE
            IF (NEEDTAU) WRITE(IW,9312) TOTKIN
         END IF
         IF(MPCTYP.NE.NONE  .AND.  ETOT.NE.ZERO) THEN
            DELTAH = ETOT*627.52791D+00 + ATHEAT
            WRITE(IW,9145) DELTAH
         END IF
      END IF
C
C     ----- SPIN EXPECTATION VALUES -----
C     -LWRK1- USED AS TRIANGULAR SCRATCH SPACE
C
      IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
      CALL SPIN(SZ,S2,X(LDA),X(LDB),X(LS),X(LWRK1),X(LSCR),
     *          IA,NA,NB,L1,L2)
      IF(MASPRT) WRITE(IW,9148) SZ,S2
C
C     ----- SAVE ORBITALS AND DENSITIES AND ENERGIES -----
C
      NDAF = 15
      CALL SCFSAV(X(LVA),X(LDA),X(LEA),NDAF,L1,L2,L3)
      NDAF = 19
      CALL SCFSAV(X(LVB),X(LDB),X(LEB),NDAF,L1,L2,L3)
C
C         SOLVATION OUTPUT FOR PCM MODEL
C
      IF(IPCFP) THEN
         IPCM=1
         IEFP=1
         IPCFP=.FALSE.
      END IF
C
      QTT=0.0D+00
      DO I=0,NTS-1
C        QT=QSE(I)+QSN(I)+Q_FS(I)+Q_IND(I)
         QT=X(LQSE+I)+X(LQSN+I)+X(LQFS+I)+X(LQIND+I)
         QTT=QTT+QT
      ENDDO
      IF(IPCM.EQ.1.AND.IPCMIT.EQ.1) THEN
        IF(MASWRK) WRITE(IW,*) ' '
        IF(MASWRK) WRITE(IW,'(A10,F18.10)')'PCM ASC=',QTT
      END IF
      IF(IPCM.EQ.1) THEN
         IF(MASWRK) WRITE(IW,'(A10,F18.10)')
     *      'GCAVP  =',GCAVP/627.509541D+00
         IF(MASWRK) WRITE(IW,'(A10,F18.10)')
     *      'GDISP  =',GDISP/627.509541D+00
         IF(MASWRK) WRITE(IW,'(A10,F18.10)')
     *      'GREP   =',GREP/627.509541D+00
      END IF
      IF(NFG.NE.0.AND.NDFTFG.EQ.1.AND.
     *   NRAD*NPHI*NTHE.LT.NRAD0*NPHI0*NTHE0) THEN
         CALL SWGRID
         GRIDTYP = FINE
      END IF
C
      IF(MASWRK  .AND.  IPCM.EQ.1  .AND.  IPCMIT.EQ.0) THEN
         WRITE(IW,*)
         WRITE(IW,*)'-- INDUCED PCM ELECTRONIC CHARGES --'
         IF(ICOMP.EQ.0) WRITE(IW,1000) QET, TCH
         IF(ICOMP.EQ.2) WRITE(IW,1100) QET, TCH, QETN
         IF(ICOMP.EQ.3) WRITE(IW,1110) QET, TCH, QESC, QETN
         WRITE(IW,*)'--------------------------------------'
      END IF
C
C         SOLVATION OUTPUT FOR SVP MODEL
C
      IF(ISVP.EQ.1  .AND.  MASPRT) THEN
         CALL SVPOUT(ETOT,ECHIP,NPRINT,'UHFOP ')
      END IF
C
C         SOLVATION OUTPUT FOR ONSAGER OR EFP MODELS
C
      IF(IZRFLS .OR. IEFP.EQ.1) THEN
         IF(MASPRT) WRITE(IW,9135) TMUX,TMUXD,TMUY,TMUYD,TMUZ,TMUZD
      END IF
C
C     ----- MODIFIED VIRTUAL ORBITALS -----
C     -LFA-, -LFB-, -LWRK2- USED AS TRIANGULAR SCRATCH STORAGE,
C     -LWRK1- IS USED AS A SQUARE SCRATCH MATRIX.
C
      IF(MVOQ.NE.0  .AND.  SCFTYP.EQ.ROHF) THEN
         NFROZ = NA
         CALL MVOS(X(LVA),X(LEA),X(LFA),X(LFB),X(LSCR),
     *             X(LIWRK),X(LWRK1),X(LWRK2),X(LXP),X(LIXPK),
     *             X(LDSH),X(LGHOND),X(LDDIJ),X(LXINTS),
     *             DIRSCF,SCHWRZ,NOPK,NINTMX,INTTYP,
     *             L0,L1,L2,L3,NSH2,MAXG,NFROZ,MVOQ,NE)
      END IF
C
C     --- GENERAL CORRELATION ADAPTED VIRTUAL ORBITALS ---
C     STORE SYMMETRIC -DCORE-, -DVAL- AT -WRK1-, WRK2-
C     STORE SYMMETRIC -JCORE-, -JVAL- AT -FA-, -FB-
C     STORE SYMMETRIC -KCORE-, -KVAL- AT -DA-, -DB-
C     STORE SQUARE -Q- MATRIX AT -WRK3-
C
      IF(IACAVO.EQ.1  .AND.  SCFTYP.EQ.ROHF) THEN
         NFROZ = NA
         TDSKWRK = DSKWRK
         DSKWRK  = .TRUE.
         CALL ACAVO(PACAVO,X(LVA),X(LEA),X(LWRK1),X(LWRK2),
     *              X(LFA),X(LFB),X(LDA),X(LDB),
     *              X(LWRK3),X(LSCR),X(LIWRK),X(LXP),X(LIXPK),
     *              NOPK,NINTMX,L0,L1,L2,L3,NFROZ)
         DSKWRK  = TDSKWRK
      END IF
C
C     ----- OUTPUT ALPHA ORBITAL RESULTS -----
C     NOTE THAT CALLING -SYMMOS- DESTROYS THE -Q- MATRIX
C
      CALL DAREAD(IDAF,IODA,X(LVA),L3,15,0)
      CALL DAREAD(IDAF,IODA,X(LDA),L2,16,0)
      CALL DAREAD(IDAF,IODA,X(LEA),L1,17,0)
      IF(MINMEM) THEN
         CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
         CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
      END IF
      CALL SYMMOS(X(LIWRK),X(LQ),X(LS),X(LVA),X(LSCR),L0,L1,L0,L1)
      CALL DAWRIT(IDAF,IODA,X(LIWRK),L1,255,1)
      IF(SOME) THEN
         IF(SCFTYP.EQ.UHF) WRITE(IW,9150)
         WRITE(IW,9170)
         CALL PREVS(X(LVA),X(LEA),X(LIWRK),L0,L1,L1,1)
      END IF
      IF(PRDENS) THEN
         WRITE(IW,9180)
         CALL PRTRIL(X(LDA),L1)
      END IF
C
C     ----- OUTPUT BETA ORBITAL RESULTS -----
C
      IF(NB.EQ.0) GO TO 700
      IF(SCFTYP.EQ.ROHF) GO TO 700
C
      CALL DAREAD(IDAF,IODA,X(LVB),L3,19,0)
      CALL DAREAD(IDAF,IODA,X(LDB),L2,20,0)
      CALL DAREAD(IDAF,IODA,X(LEB),L1,21,0)
      CALL DAREAD(IDAF,IODA,X(LQ) ,L3,45,0)
      IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
      CALL SYMMOS(X(LIWRK),X(LQ),X(LS),X(LVB),X(LSCR),L0,L1,L0,L1)
      CALL DAWRIT(IDAF,IODA,X(LIWRK),L1,256,1)
      IF(SOME) THEN
         WRITE(IW,9160)
         WRITE(IW,9170)
         CALL PREVS(X(LVB),X(LEB),X(LIWRK),L0,L1,L1,1)
      END IF
      IF(PRDENS) THEN
         WRITE(IW,9180)
         CALL PRTRIL(X(LDB),L1)
      END IF
C
C     ----- PUNCH THE ORBITALS -----
C
  700 CONTINUE
      IF(MPUNCH.NE.0  .AND.  MASPRT) THEN
         CALL TMDATE(TIMSTR)
         WRITE(IP,8000) TIMSTR,TITLE,METHOD(1:LENMTH),ETOT,EN,ITER
         LPUN = NA
         IF(MPUNCH.EQ.2) LPUN = L0
         WRITE(IP, FMT='(5H $VEC)')
         CALL PUSQL(X(LVA),LPUN,L1,L1)
         IF(SCFTYP.EQ.UHF  .AND.  NB.GT.0) THEN
            LPUN = NB
            IF(MPUNCH.EQ.2) LPUN = L0
            CALL PUSQL(X(LVB),LPUN,L1,L1)
         END IF
         WRITE(IP, FMT='(5H $END)')
      END IF
C
C     ----- ROHF-MP2 CALCULATION -----
C       FOCK MATRICES OF ALPHA AND BETA ARE NEEDED AND WILL BE
C       DIAGONALIZED IN OCCUPIED AND VIRTUAL SPACES FOR BOTH SPINORS
C
      IF(SCFTYP.EQ.ROHF  .AND.  MPLEVL.EQ.2  .AND.  OSPT.EQ.RMP) THEN
         CALL DAREAD(IDAF,IODA,X(LFA),L2,14,0)
         CALL DAREAD(IDAF,IODA,X(LFB),L2,18,0)
         CALL RMPFCK(X(LFA),X(LFB),X(LVA),NA,NB,L0,L1,L2,L3,
     *               X(LWRK1),X(LEA),X(LWRK3),X(LSCR),X(LIWRK),MASPRT)
      END IF
C
C     ----- GENERATE UHF/ROHF LAGRANGIAN -----
C     -LFA- AND -LDA- ARE USED FOR BOTH ALPHA AND BETA.
C     -LWRK2- IS USED AS A SCRATCH SQUARE MATRIX.
C     -FA- IS TOTAL FOCK FOR ROHF, WE NEED JUST ALPHA FOR LAGRANGIAN.
C
      CALL ROLAG(X(LFA),X(LDA),X(LWRK2),X(LSCR),L1,L2,L3,DBG)
C
C     ----- GENERATE THE UHF NATURAL ORBITALS -----
C     -LVA- AND -LQ- AND -LWRK2- ARE USED AS SCRATCH SQUARE STORAGE.
C
      IF(NB.EQ.0) GO TO 800
      IF(SCFTYP.EQ.ROHF) GO TO 800
C
      IF(IUHFNO.NE.0  .AND. CVGED) THEN
         IF(SOME  .OR.  NPUNCH.GT.0)
     *      CALL UHFNOS(X(LEA),X(LIWRK),X(LSCR),X(LDA),X(LDB),
     *                  X(LVA),X(LQ),X(LWRK2),L0,L1,L2,1)
            CALL DAREAD(IDAF,IODA,X(LQ) ,L3,45,0)
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
            CALL SYMMOS(X(LIWRK),X(LQ),X(LS),X(LVA),X(LSCR),L0,L1,L0,L1)
         IF(SOME) THEN
            WRITE(IW,9190)
            CALL PREVS(X(LVA),X(LEA),X(LIWRK),L0,L1,L1,1)
         END IF
         IF((NPUNCH.GT.0) .AND. MASPRT) THEN
            WRITE(IP, FMT='(''UHF OCCUPATION NUMBERS'')')
            WRITE(IP, FMT='(8F10.6)') (X(LEA+I-1),I=1,L0)
            WRITE(IP, FMT='(''UHF NATURAL ORBITALS''/'' $VEC'')')
            CALL PUSQL(X(LVA),L0,L1,L1)
            WRITE(IP, FMT='(5H $END)')
         END IF
      END IF
C
C        TIDY UP, AND EXIT
C
  800 CONTINUE
      IF(CVGED) IREST = 0
      ETHRSH = ETHSAV
      SOGTOL = SOGSAV
C
      IF(FT15OP) THEN
         CALL SEQCLO(NFT15,'DELETE')
         IF(SCFTYP.EQ.UHF) CALL SEQCLO(NFT16,'DELETE')
         FT15OP=.FALSE.
      END IF
      IF(.NOT.NOTOPN) CALL RACLOS(20,'DELETE')
      NOTOPN=.TRUE.
C
C     SAVE FMM DATA FOR DERIVATIVE CALCULATIONS
C
      IF (QFMM) THEN
         CALL DERCHK(NDER)
         IF (NDER.GT.0) THEN
            CALL DENWZP(SCFTYP,NCXYZ,X(LIYP),X(LINDX2),
     *         X(LIDXIJK),X(LIDXWS),X(LCXYZ),X(LIBS),X(LYZTBL),NTMPL,
     *         X(LYP),X(LZP),L2,X(LDA),X(LDB),NTBOX,MAXWS,X(LYZPNT),
     *         X(LF),X(LG),X(LZLL),X(LCLM),X(LFLM),X(LTMPGPS),NSBOX,
     *         X(LISP),X(LIPP))
            CALL SHLDEN(SCFTYP,X(LDA),X(LDB),DUMMY,X(LDSH),IA,L1,L2,
     *         NSH2,1)
            CALL WRTFMM(X(LYP),X(LZP),NP,NTMPL,NCXYZ,X(LIYP),
     *         X(LINDX2),X(LIDXIJK),X(LIDXWS),X(LIBS),
     *         X(LYZTBL),NTBOX,MAXWS,X(LYZPNT),X(LCLM),
     *         X(LIDXBOX),NSBOX,X(LISP),X(LIPP),X(LEBOX),
     *         X(LMBOX),X(LINDX),X(LNUMWS),X(LDSH),X(LSLIST),
     *         X(LIDXSHL),X(LSLN),X(LXINTS),NSHELL,NSH2,NSHL2,NS)
         END IF
      END IF
      CALL RETFM(NEED)
C
      IF((SCFTYP.EQ.UHF) .AND. MASPRT)
     *  WRITE(IW,FMT='('' ...... END OF UHF CALCULATION ......'')')
      IF((SCFTYP.EQ.ROHF) .AND. MASPRT)
     *  WRITE(IW,FMT='('' ...... END OF ROHF CALCULATION ......'')')
      CALL TIMIT(1)
      RETURN
C
 8000 FORMAT('--- OPEN SHELL ORBITALS --- GENERATED AT ',3A8/10A8/
     *    'E(',A,')=',F20.10,', E(NUC)=',F16.10,',',I5,' ITERS')
C
 9000 FORMAT(/10X,27(1H-)/10X,A11,' SCF CALCULATION'/10X,27(1H-))
 9005 FORMAT(/1X,'OVERLAPPING STORAGE FOR H,S,Q MATRICES,',
     *        1X,'TO SAVE',I10,' WORDS.'/1X,'ADDING THIS AMOUNT',
     *        1X,'MAY IMPROVE EFFICIENCY SOMEWHAT.')
 9006 FORMAT(1X,'* * * ERROR * * *'/
     *       1X,'IT IS ILLOGICAL FOR THE GRID SWITCHING VALUE',
     *          ' $DFT SWITCH=',1P,E7.1/
     *       1X,'    TO BE SMALLER THAN THE DENSITY CONVERGEN',
     *          'CE $SCF CONV=',1P,E7.1)
 9012 FORMAT(5X,'DENSITY MATRIX CONV=',1P,E10.2)
 9013 FORMAT(5X,'      DENSITY MATRIX CONV=',1P,E10.2/
     *       5X,'DFT GRID SWITCH THRESHOLD=',1P,E10.2/
     *       5X,' DFT SWITCH OFF THRESHOLD=',1P,E10.2)
 9015 FORMAT(5X,'VTSCAL=',L1,'  MAXVT=',I3,'  VTCONV=',F12.8)
 9017 FORMAT(5X,'SOSCF WILL OPTIMIZE',I8,' ORBITAL ROTATION ANGLES.',
     *          ' SOGTOL=',1P,E10.3)
 9018 FORMAT(5X,'SOSCF WILL OPTIMIZE',I8,' ALPHA AND',I8,
     *          ' BETA ROTATION ANGLES.'/5X,'SOGTOL=',1P,E10.3)
 9020 FORMAT(/5X,'NUCLEAR ENERGY = ',F20.10/
     *       5X,'MAXIT =',I3,5X,'NPUNCH=',I3,5X,'MULT=',I3/
     *       5X,'EXTRAP=',L1,'  DAMP=',L1,'  SHIFT=',L1,
     *          '  RSTRCT=',L1,'  DIIS=',L1,'  SOSCF=',L1)
 9030 FORMAT(5X,'ROHF CANONICALIZATION PARAMETERS'/
     *       5X,8X,'C-C',5X,'O-O',5X,'V-V'/
     *       5X,'ALPHA',3F8.4/5X,'BETA ',3F8.4)
 9035 FORMAT(1X,'QFMM WILL USE ADDITIONAL MEMORY OF',I10,' WORDS')
 9039 FORMAT(/1X,'THE BUFFER ZONE DENSITY WILL BE EXCLUDED FROM THE ',
     *        'INTERACTION WITH THE EFP')
 9040 FORMAT(5X,'MEMORY REQUIRED FOR UHF/ROHF STEP=',I10,' WORDS.')
 9045 FORMAT(/1X,'DIRECT SCF CALCULATION, SCHWRZ=',L1,'   FDIFF=',L1)
 9048 FORMAT(/' ITER EX      TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    ORB. GRAD       VIR. SHIFT       DAMPING')
 9049 FORMAT(/112X,'NONZERO     BLOCKS'/
     *        ' ITER EX      TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    ORB. GRAD       VIR. SHIFT       DAMPING',
     *        '        INTEGRALS    SKIPPED')
 9050 FORMAT(/' ITER EX      TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    DIIS ERROR      VIR. SHIFT       DAMPING')
 9055 FORMAT(/112X,'NONZERO     BLOCKS'/
     *        ' ITER EX      TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    DIIS ERROR      VIR. SHIFT       DAMPING',
     *        '        INTEGRALS    SKIPPED')
 9058 FORMAT(/' ITER EX      TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    ORB. GRAD ')
 9059 FORMAT(/80X,'NONZERO     BLOCKS'/
     *        ' ITER EX      TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    ORB. GRAD       INTEGRALS    SKIPPED')
 9060 FORMAT(/' ITER EX      TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    DIIS ERROR')
 9065 FORMAT(/80X,'NONZERO     BLOCKS'/
     *        ' ITER EX      TOTAL ENERGY        E CHANGE  DENSITY ',
     *        'CHANGE    DIIS ERROR      INTEGRALS    SKIPPED')
 9070 FORMAT(1X,2I3,F20.10,F17.10,2F14.9,2F16.9,I15,I11)
 9075 FORMAT(1X,2I3,F20.10,F17.10,2F14.9,I15,I11)
 9080 FORMAT(/10X,17(1H-)/10X,17HDENSITY CONVERGED/10X,17(1H-))
 9090 FORMAT(/10X,16(1H-)/10X,16HENERGY CONVERGED/10X,16(1H-))
 9100 FORMAT(/10X,14(1H-)/10X,14HDIIS CONVERGED/10X,14(1H-))
 9110 FORMAT(1X,'... SCF HAS ALMOST CONVERGED BUT ROUTINE STOPPED',
     *       1X,' FOR TIMLIM BEFORE ULTIMATE CYCLE ...')
 9120 FORMAT(/1X,'SCF IS UNCONVERGED, TOO LITTLE TIME')
 9130 FORMAT(/1X,'SCF IS UNCONVERGED, TOO MANY ITERATIONS')
 9135 FORMAT(/10X,'INDUCED DIPOLE',5X,'ATOMIC UNITS',10X,'DEBYE',
     *       /10X,'      X(IND)  ',5X,F12.5,5X,F12.5,
     *       /10X,'      Y(IND)  ',5X,F12.5,5X,F12.5,
     *       /10X,'      Z(IND)  ',5X,F12.5,5X,F12.5)
 9140 FORMAT(/1X,'FINAL ',A,' ENERGY IS',F20.10,' AFTER',I4,
     *           ' ITERATIONS')
 9145 FORMAT(/1X,'HEAT OF FORMATION IS',F15.5,' KCAL/MOL')
 9148 FORMAT(/10X,20(1H-)/10X,12HSPIN SZ   = ,F8.3/
     *        10X,12HS-SQUARED = ,F8.3/10X,20(1H-))
 9150 FORMAT(/1X,' ----- ALPHA SET ----- ')
 9160 FORMAT(/1X,' ----- BETA SET ----- ')
 9170 FORMAT(/10X,12(1H-)/10X,12HEIGENVECTORS/10X,12(1H-))
 9180 FORMAT(/10X,14(1H-)/10X,14HDENSITY MATRIX/10X,14(1H-))
 9190 FORMAT(/10X,43(1H-)/10X,'UHF NATURAL ORBITALS AND OCCUPATION',
     *        ' NUMBERS'/10X,43(1H-))
 9200 FORMAT(10X,15(1H-),'START SECOND ORDER SCF',15(1H-))
 9210 FORMAT(1X,'ALPHA DFT EXCHANGE + CORRELATION ENERGY = ',F20.10)
 9220 FORMAT(1X,' BETA DFT EXCHANGE + CORRELATION ENERGY = ',F20.10)
 9235 FORMAT(1X,'NEXT ENERGY RISES: SWITCHING DIIS OFF FOR',I3,
     *          ' ITERS, NEW ETHRSH=',1P,E9.2)
 9236 FORMAT(1X,'NEXT ENERGY RISES: SWITCHING SOSCF OFF FOR',I3,
     *          ' ITERS, NEW SOGTOL=',1P,E9.2)
 9230 FORMAT(/1X,'THE CONVERGED ORBITALS WILL UNDERGO GUEST/SAUNDERS'/
     *        1X,'CANONICALIZATION FOR ZAPT PERTURBATION THEORY.')
 9310 FORMAT(1X,'TOTAL ELECTRON NUMBER             = ',F20.10)
 9311 FORMAT(/10X,'TOTAL KINETIC ENERGY DENSITY      = ',F20.10,1X/)
 9312 FORMAT(1X,'TOTAL KINETIC ENERGY DENSITY      = ',F20.10,1X)
 9320 FORMAT(1X,'DFT EXCHANGE + CORRELATION ENERGY = ',F20.10)
 9330 FORMAT(1X,'DFT CODE IS SWITCHING BACK TO THE FINER GRID')
 9340 FORMAT(/1X,'DFT CODE IS SWITCHING FROM',3I3,' TO THE COARSER GRID'
     *          ,3I3)
 9350 FORMAT(1X,'DFT IS SWITCHED OFF, PERFORMING PURE SCF UNTIL SWOFF',
     *          ' THRESHOLD IS REACHED.')
 9355 FORMAT(1X,'CONVERGED TO SWOFF, SO DFT CALCULATION IS NOW',
     *          ' SWITCHED ON.')
 9380 FORMAT(9X,'SWDIIS THRESHOLD HAS BEEN REACHED:',
     *          ' SWITCHING DIIS OFF.')
C
 1000 FORMAT(1X,'CALCULATED ',F10.5,' THEORETICAL ',
     * F10.5,' NOT RENORMALIZED',F10.5)
 1100 FORMAT(1X,'CALCULATED ',F10.5,' THEORETICAL ',
     * F10.5,' RENORMALIZED',F10.5)
 1110 FORMAT(1X,'CALCULATED',F10.5,' (THEOR= ',
     * F10.5,')  ESCAPED',F10.5,' FINAL', F10.5)
      END
