C 11 APR 08 - HPTI - GRID SWITCHING CHANGES FOR LEBEDEV GRIDS
C 11 APR 08 - SAN - G3MP2 GEOMETRY OPTIMIZATION SETTINGS
C  4 MAR 08 - SS  - TOTAL KINETIC ENERGY DENSITY
C  4 MAR 08 - SHY - UHFOP: WRITE UHF ORBITAL SYMMETRY INFORMATION TO DAF
C  7 DEC 07 - MWS - CHECK RUNS SHOULD FEEL OUT VVO COMPUTATIONS
C 28 AUG 07 - HL  - RHFCL,UHFOP: ADD PCM CAV+DIS+REP E FOR EFP-PCM
C 20 AUG 07 - SHY - REDUCE PRINT OUT FOR MD SIMULATIONS
C 20 AUG 07 - DGF - SYNCH FMOOPT,FMORUN; CLOSE SCF FILES FOR FMO
C 20 AUG 07 - DDK - ROHF EFP GENERATION USES ROOTHAAN CANONICALIZATION
C 21 MAY 07 - MWS - UHFOP: AFTER CONVERGING, CC GENERATES FINAL FA,FB
C 24 MAR 07 - MWS - PAD FRGINF COMMON BLOCK
C 22 DEC 06 - ST,NK,MC,DGF,TN - LC EXCHANGE, PIEDA, FMO/EFP
C 19 NOV 06 - MWS - RHFCL,UHFOP: DFT+PCM+DIRSCF CAN'T DO FDIFF CORRECTLY
C  6 NOV 06 - MWS - ADJUST WFNOPT+GDDI COMMON, CHECK SKIPS GRID SWITCH
C  7 SEP 06 - DMC - RHFCL,UHFOP: IMPLEMENT FULL SVPE SOLVATION
C  8 MAY 06 - MWS - RHFCL: CALL TO GENERATE VALENCE VIRTUAL ORBITALS
C 29 MAR 06 - FLG - HSTAR,HSTARU,ROFOCK: ELONGATION METHOD ADDED
C 13 MAR 06 - NM  - RHFCL,UHFOP: MEX RUNS PUNCH VEC1/VEC2 GROUPS
C 22 FEB 06 - TN  - RHFCL: ADD COMMON BLOCK EFPFMO
C 14 NOV 05 - DGF,HL - SOLVENT SCF MEMORY CHANGES
C 19 SEP 05 - SPW - RHFCL,UHFOP: ADD NEO HOOKS
C 19 SEP 05 - MWS - FIX RDFT (27-JUN-05) AND UDFT (5-FEB-05) FDIFF BUGS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 27 JUN 05 - KRG,EG - UHFOP: SONEWT RETURN VAL, RHFCL: SAVE F AFTER DFT
C  1 JUN 05 - DGF - RHFCL: BROADCAST MASTER CONVERGENCE DATA IF FMO
C  1 JUN 05 - CMA - SMALL CHANGE TO FIX NATURAL ORBITALS FOR ZAPT
C 30 APR 05 - DGF - ADD DIRTHR OPTION TO RECOMPUTE FOCK MATRIX IN DIRSCF
C  7 MAR 05 - IA  - FIX COMMON BLOCK FRGINF
C 22 FEB 05 - MWS - CHANGE SVP CONVERGENCE TEST, BETTER SOLVENT COMMENTS
C 13 FEB 05 - DMC - RHFCL,UHFOP: IMPLEMENT SVP MODEL
C  5 FEB 05 - DGF - RHFCL,UHFOP: IMPLEMENT OPTIONAL DIIS -> SOSCF SWITCH
C  5 FEB 05 - MWS - RHFCL,UHFOP: DON'T ALLOW PCM TO DO GRID SWITCHING
C  7 SEP 04 - CHC - RHFCL,UHFOP: IMPLEMENT NEW QFMM PROGRAM
C  3 JUN 04 - MWS - RHFCL: DEBUG DIRECT EFP+PCM, DEBUG PCM'S IDP OPTION
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C  7 APR 04 - HL  - IEF-PCM/EFP FOR ROHF AND UHF
C  7 APR 04 - MWS - CHANGE SCF-MI COMMON BLOCK
C 16 JAN 04 - DGF - RHFCL,UHFOP: USE SWOFF TO PERFORM EARLY HF ITERS
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  3 SEP 03 - MWS - RHFCL,UHFOP: EHF INCLUDES MOPAC PEPTIDE BOND ENERGY
C  3 JUL 03 - JMM - RHFCL,UHFOP: SUPPRESS PRINTING IN MONTE CARLO RUNS
C 16 JUN 03 - HL  - RHFCL: MOLECULAR MECHANICS CORRECTION FOR MOPAC
C                          PCM CHANGES FOR GRADIENTS
C 12 DEC 02 - MWS - UHFOP: TWEAK UHF DIIS STRATEGY (1D-08 TO 1D-06),
C                   RHFCL,UHFOP: LOWER AO INT CUTOFF IN DIRECT SCF JOBS
C           - YA  - HSTAR: OPTION TO PROCESS DUPLICATED INTEGRAL FILES
C  7 AUG 02 - CP,HL,JHJ - RHFCL: ITERATIVE ISTROPIC IEF-PCM/EFP,
C                   COMPUTE CORRECT FINAL SCF E FOR MATRIX INVERSION
C                   IEF-PCM/EFP, CORRECT EEFP TERM, FIX DFT WITH MFRZ,
C  7 AUG 02 - MWS - UHFOP: TWEAK UHF CONV A LITTLE BIT MORE
C  7 AUG 02 - CHC - RHFCL,UHFOP: ALLOW LINEAR SCALING FOCK CODE WITH DFT
C 20 JUN 02 - MWS - RHFCL,UHFOP: TWEAK UHF CONV, GRID SWITCH LIKE CONVHF
C 22 MAY 02 - MWS - UHFOP: TWEAKS TO UHF-DIIS STRATEGY, PARALLEL ACAVO
C 17 APR 02 - KRG - UHFOP: SWITCH DIIS/SOSCF OFF IF UHF ENERGY RISES
C 26 MAR 02 - MWS - RHFCL: FOR CC, COMPUTE EXACT FINAL FOCK MATRIX
C 24 JAN 02 - MWS - RHFCL,UHFOP: IMPLEMENT ACAVO OPTION
C 16 NOV 01 - MWS - RHFCL,UHFOP: IMPLEMENT MVOQ=-1 OPTION
C  8 OCT 01 - HL  - RHFCL: DECREASE MEMORY FOR PCM-IEF=3
C  6 SEP 01 - CHC - RHFCL,UHFOP: ADD QFMM OPTION
C 25 JUN 01 - MWS - PRINT DFT TYPE IN ENERGY OUTPUT LINE
C 13 JUN 01 - TT,SY,MK,DGF - RHFCL,UHFOP: IMPLEMENT GRID-BASED DFT
C  3 MAY 01 - HL  - RHFCL: EFP+PCM OPTION EXTENDED TO BUFFER REGION MOS
C 11 OCT 00 - PB,BM - EFP+PCM INTERFACE
C 25 AUG 00 - BM  - IEF FORMULATION OF THE PCM MODEL IS INTRODUCED
C 11 JUN 00 - MWS - RHFCL,UHFOP: ALWAYS ALLOCATE HONDO INTEGRAL BUFFER
C  2 MAY 00 - MWS - ALLOW DEM OPTION TO USE SPHERICAL HARMONICS
C 10 APR 00 - MWS - REMOVE STATIC MEMORY FROM COSMO COMMONS
C 25 MAR 00 - KKB/LNB - CORRECTION DUE TO SOLVENT SCREENING CHARGES-HF
C 16 FEB 00 - MWS - FIX DEM OPTION
C 15 JAN 00 - VK  - RHFCL,UHFOP,ROFOCK: ALLOW MO FREEZING IN RHF + ROHF,
C                   TAKE THE PRESENCE OF QM/MM BUFFER INTO ACCOUNT
C 29 AUG 99 - MWS - RHFCL,UHFOP: DON'T OVERLAP STORAGE IF SOLVENT RUN
C  9 APR 99 - MWS - RHFCL: CANONICALIZE FOR ZAPT/RMP AS NEEDED
C 13 MAR 99 - KRG - HSTAR,HSTARU,RHFCL,UHFOP: ADDED DFT CODE
C 13 FEB 99 - KRG - UHFNOS: BLOCK BY IRREPS BEFORE DIAGONALIZATION
C 31 DEC 98 - MAF - RHFCL: COMPUTE CORRECT SOSCF ROTATION COUNT
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C 27 OCT 98 - MAF - RHFCL,RMPFCK,UHFOP: ALLOW USE OF SPHERICAL HARMONICS
C 12 SEP 98 - MWS - RHFCL: DELETE A VARIABLE IN MIOPT COMMON
C 13 APR 98 - MWS - RHFCL,UHFOP: SAVE ORBITAL SYMMETRY LABELS
C 13 MAR 98 - JBL - RHFCL,UHFOP: INCLUDE C-SM5- INTERFACE CALLS
C  6 JAN 98 - MWS - UHFOP: REMOVE MANIPULATION OF MPUNCH VALUE
C 24 NOV 97 - DM  - RHFCL,UHFOP: DELETE FILE 15 ON EXIT IF USED
C  1 OCT 97 - AF  - RHFCL: CALL TO SEPARATE SCFMI DRIVER
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 14 AUG 97 - MWS - RHFCL: DISTINCT STORAGE FOR DIS2 IN PCM RUNS
C 18 MAR 97 - BM,MWS - RHFCL: INCLUDE PCM COMPUTATIONS, WITH DISPERSION
C 21 FEB 97 - VK  - UHFOP: ENSURE ALL NODES ENTER RMPFCK
C 18 DEC 96 - MWS - RHFCL,UHFOP: ADJUST CALLS TO TWOEI ROUTINE.
C  9 DEC 96 - JHJ - RHFCL: ADD CALL TO PAULIA
C 13 NOV 96 - DGF - RHFCL,UHFOP: USE THE SAME MPCG FOR RHF/ROHF/UHF/GVB
C 11 NOV 96 - MWS - RHFCL,UHFOP: ALLOW FOR DIRECT MODE MVO COMPUTATION
C 17 OCT 96 - MWS - RHFCL: ENSURE SOSCF REMAINS ENGAGED IF STARTED
C 29 SEP 96 - GDF - RHFCL,UHFOP: ALLOCATE GHONDO BASED ON MAX ANG MOM
C 11 JUL 96 - MWS - UHFNOS: MAKE MP2 NOS, RMPFCK: UPDATE MP2PAR
C 13 JUN 96 - VAG - ADD VARIABLE FOR CI TYPE TO SCFOPT COMMON
C 14 APR 96 - MWS - CHANGE CALLS TO SONEWT
C 14 MAR 96 - MWS - RHFCL: PRINT DENSITY MATRIX WHEN NPRINT=9
C 10 FEB 96 - MWS - RHFCL,UHFOP: DIAGONALIZE 1ST ITER FOR NUM. HESSIANS
C  9 JAN 96 - WC  - RHFCL: A FEW MOROKUMA ANALYSIS CHANGES
C 26 JUL 95 - GMC - IMPLEMENT SOSCF FOR UHF/ROHF WAVEFUNCTIONS
C 24 MAY 95 - MWS - RMPFCK: UPDATE MP2PAR COMMON
C 21 APR 95 - MWS - USE CORRECT NAME FOR EXCHANGE INTEGRAL SCREENING
C 10 APR 95 - GMC - RHFCL: FIX ONSET OF SOSCF ON SUBSEQUENT GEOMS.
C  6 APR 95 - MWS - DEMHF: DEC F90 COMPILER NEEDED SAVE STATEMENT
C 27 MAR 95 - MWS - RHFCL: SO INITIATION TOLERANCE IS INPUT PARAMETER
C  8 MAR 95 - GMC - RHFCL: IMPLEMENT SECOND ORDER SCF
C  5 MAR 95 - MWS - RHFCL,UHFOP: CONV IN OPT RUNS DEPENDS ON GRADIENT
C  1 FEB 95 - WC  - RHFCL: CHANGES TO IMPLEMENT MOROKUMA ANALYSIS
C 11 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  5 AUG 94 - MWS - RHFCL,UHFOP: CHANGE TWOEI ARGUMENTS,
C                   HSTAR,HSTARU: USE DOUBLE LABEL PACKING
C  1 AUG 94 - SPW - RHFCL,UHFOP: ADD ABFLD TO CALL TO EFPCMP
C 27 MAY 94 - SPW - RHFCL,UHFOP: CALC. IND. DIPOLE ON FRAGS EACH ITER
C  1 APR 94 - SPW - RHFCL,UHFOP: INDUCE SCRF ON EACH ITERATION
C 21 MAR 94 - MWS - RMPFCK: PASS NCORE FROM NEW MP2 CODE
C 28 FEB 94 - MWS - RMPFCK: PRESERVE ROHF CANONICAL ORBITALS
C  9 DEC 93 - MWS - RHFCL,UHFOP: CHANGE DAF RECORD OF MOPAC INTEGRALS
C 11 OCT 93 - MWS - UHFOP: FIX PROBLEM OF ZEROING 1E ROHF CASE
C 11 MAR 93 - FJ  - RHFCL,UHFOP: PRINT IF DOING EXTENDED VIRIAL ANAL
C 11 FEB 93 - JHJ - UHFOP: FIX CALL TO MPCGU
C  3 DEC 92 - MWS - RMPFCK: CORRECT CALCULATION OF SX TERM
C 20 NOV 92 - MWS - RHFCL,UHFOP: MINIMIZE MEMORY NEED
C  9 OCT 92 - NM  - RMPFCK AND RMPONE FOR ROHF-MP2 RUN ADDED
C 28 AUG 92 - MWS - RHFCL,UHFOP: FIX SO MOPAC WORKS IF DIRSCF IS ON
C 13 JUN 92 - MWS - RHFCL,UHFOP: CHANGES TO DIIS SECTIONS
C  5 JUN 92 - TLW - RHFCL,UHFOP: PARALLELIZE DISK BASED METHOD
C 21 MAR 92 - MWS - RHFCL,UHFOP: ALLOCATE ADDITIONAL MEMORY FOR INTS
C 17 MAR 92 - JHJ - RHFCL,UHFOP: ALLOCATE MEMORY FOR MPC 2E-INTEGRALS.
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C 12 MAR 92 - MWS - UHFOP: PARALLEL DIRECT MATRIX
C  9 MAR 92 - JHJ - RHFCL,UHFOP: ENERGY CONVERTED TO HARTREES FOR IRC.
C  5 MAR 92 - MWS - RHFCL,UHFOP: USE SYMMOS, SYMDIA, LEVELS, OVLSEL
C 21 FEB 92 - TLW - RHFCL: PARALLELIZE DIRECT METHOD
C 19 FEB 92 - JHJ - RHFCL,UHFOP: ALLOW FOR MOPAC SCF CALCULATIONS
C 10 JAN 92 - TLW - PARALLEL I/O CHANGES
C 17 DEC 91 - MWS - USE FUZZIER CONV. CRIT. FOR DIRECT SCF CASE.
C 29 OCT 91 - DRG - RHFCL,UHFOP: MOVE ENUC CALL TO SCF.
C 11 OCT 91 - MWS - RHFCL,UHFOP: CLEANUP AND CHANGES FOR DIRECT SCF
C 18 AUG 91 - MWS - TIDY UP RHFCL, USE JOHN MONTGOMERY'S DEM OPTION
C  7 JUL 91 - MWS - RHFCL,UHFOP: CHANGE USAGE OF ORTHO,QMATRX
C 29 APR 91 - MWS - HSTAR,HSTARU: CHANGE TO FULL 16 BIT PK UNPACKING
C 25 MAR 91 - MWS - RHFCL,UHFOP: CHANGE CVDENS CRITERIA
C 30 OCT 90 - MWS - USE CLENMO ONLY FOR ABELIAN GROUPS
C  3 JUN 90 - JAM - CHANGE VAX BYTE PACKING TO FULL 8 BITS
C  1 MAY 90 - MWS - FLUSH PRINT BUFFER ON EVERY ITERATION
C 21 DEC 89 - MWS - MORE DIGITS FOR ENERGY WHEN MO-S ARE PUNCHED.
C 27 NOV 89 - MWS - REMOVE PRINTING BUG INTRODUCED 25 SEP 89
C 25 SEP 89 - MWS - REMOVE PRINT/PUNCH FROM UHFNOS ROUTINE.
C 20 SEP 89 - XZ  - FIX TYPO OF IFMO FOR LFMO IN UHFOP
C 31 MAR 89 - MWS - RHFCL,UHFOP: CVDENS TESTS 10*ETOL, NOT 5*ETOL
C 13 MAR 89 - MWS - UHFOP: READABLE STORAGE ALLOCATION,
C                   ROFOCK: SIMPLIFY, NEW CALLING OPTION IMO=1 ADDED.
C 20 FEB 89 - STE - ROFOCK:DEFINE ZERO, DELETE RHFCL(9128) UHFOP(9168)
C  1 FEB 89 - MWS - USE SYMTRZ,PREVS IN RHFCL AND UHFOP
C 14 NOV 88 - MWS - GENERATE MVO-S AFTER RHF AND ROHF CONVERGENCE
C 23 OCT 88 - MWS - CVDENS TEST, CLENMO'S TOLE FROM 1.0D-05 TO 1.0D-06
C 22 JUN 88 - MWS - FIX EXETYP=CHECK IN UHFOP
C  8 MAY 88 - MWS - UP AO-S FROM 255 TO 2047
C 22 APR 88 - MWS - INCLUDE JOHN MONTGOMERY'S ROHF VIA UHF CODE.
C                   RSTRCT ENABLED FOR RHF,UHF,ROHF.  MCONV CHANGED.
C                   MORE CLEANUP, AND ---ROHF.SRC IS RETIRED---
C  9 APR 88 - MWS - USE ONLY ONE LOOP TO READ P OR PK FILES IN
C                   HSTAR AND HSTARU, UNDOING CHANGES OF 4 NOV 86.
C 31 MAR 88 - MWS - PRINT TOTAL SCF TIME, CLEAN UP CONVERGENCE LOGIC,
C                   INVOKE CLENMO FOR BOTH UHF AND RHF RUNS.
C 14 NOV 87 - STE - USE EXETYP
C 28 OCT 87 - STE - USE IN-LINE FORMATS FOR PUNCHING SIMPLE ITEMS
C 16 OCT 87 - MWS - GENERATE UHF NO-S, ADD VECTOR PUNCH LABELING
C 20 AUG 87 - MWS - CLOSE FILE DASORT WHEN DIIS IS DONE.
C  6 AUG 87 - MWS - INCLUDE ETA VERSION
C 21 APR 87 - MWS - UNIX BIT SHIFTING IS RSHIFT.
C 24 APR 87 - STE - RHFCL,UHFOP: REMOVE IA FROM DMTX,ORTHO,TFTRI CALLS
C                   PROTECT IA FROM GLDIAG/QMATRX
C 24 NOV 86 - MWS - CHANGE RSHIFT TO RRSHFT
C  4 NOV 86 - STE - HSTAR,HSTARO: IMPROVE VECTORIZATION; NO NAV REFS.
C 27 OCT 86 - STE - CONVERT DATA STATEMENTS TO PARAMETER STATEMENTS
C 11 JUL 86 - MWS - PACKING FOR CELERITY AND CRAY VERSION,
C                   RENAME ROUTINE SHIFTR TO LVLSHF,
C                   SANITIZE FLOATING POINT CONSTANTS
C 25 JUN 86 - LAM - PUNCH CORRECT ORBITALS IN RHFCL
C 23 APR 86 - LAM - USE DIIS METHOD IF REQUESTED IN RHFCL AND UHFOP
C 13 NOV 85 - LAM - PRINT DENSITY MATRIX ONLY IF NPRINT.GT.8
C                   IN RHFCL AND UHFOP
C 23 SEP 85 - STE - USE GENERIC FUNCT.; ALLOW SQUARE CANONICAL INTS
C                   ALLOW TO CONVERGE WITH DAMPING ON
C 27 JUL 85 - MWS - CHANGE IBM INDEX PACKING
C 16 APR 85 - MWS - CHANGE FINAL ENERGY PRINTOUT
C  5 JAN 83 - STE - DELETE REWIND IPK IN UHFOP
C 14 DEC 83 - STE - CHANGE COMMON NAMED DMPTST TO DMPING
C  1 DEC 83 - STE - FIX INDEXING FOR NWDVAR=1 IN RHFCL,UHFOP
C 17 NOV 83 - STE - FPS UNPACKING IN HSTAR,HSTARU
C  5 NOV 83 - STE - CHANGE CALL REWBF TO REWIND
C 18 APR 83 - MWS - EXTRAPOLATE ALPHA AND BETA DIFFERENTLY FOR UHF
C 22 MAR 83 - MWS - SPLIT OFF FROM SEGMENT SCFA
C
C*MODULE RHFUHF  *DECK DEMHF
      SUBROUTINE DEMHF(IW,DBG,EHF,EN,FAO,FMO,FSAVE,EIG,OCC,IA,SCR,
     *                 IWRK,VEC,V0,D,H1,S,SMO,BUF,IBUF,L0,L1,L2,L3,
     *                 NOCC,NINTMX,NUMDEM,NOPK)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MAXDEM=8)
C
      DIMENSION ETAU(MAXDEM),XTAU(MAXDEM),TAUTAB(MAXDEM)
      DIMENSION FAO(L2),FMO(L2),FSAVE(L2),EIG(L1),OCC(L1),IA(L1),
     *          SCR(L1,8),IWRK(L1),VEC(L3),V0(L3),D(L2),H1(L2),
     *          S(L2),SMO(L3),BUF(NINTMX),IBUF(NINTMX)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      SAVE ETAU,XTAU
C
      DATA TAUTAB/0.00D+00, 0.25D+00, 0.50D+00, 1.00D+00, 1.50D+00,
     *            2.50D+00, 4.00D+00, 6.00D+00/
C
C     ----- DIRECT ENERGY MINIMIZATION BY UNIVARIATE SEARCH -----
C     THE IMPLEMENTATION RESEMBLES OTHERS FOUND IN THE LITERATURE.
C     THIS ROUTINE WAS WRITTEN BY JOHN MONTGOMERY, AUGUST 1991
C
C         SEE PAPERS SUCH AS
C     R.SEEGER, J.A.POPLE  J.CHEM.PHYS.  65,265-271(1976)
C     R.N.CAMP, H.F.KING  J.CHEM.PHYS.  75,268-274(1981)
C     H.SELLERS  CHEM.PHYS.LETT.  180,461-465(1991)
C
      KT=1
      XTAU(KT)=ZERO
      ETAU(KT)=EHF+EN
      IF(DBG) WRITE(IW,9010) KT,XTAU(KT),ETAU(KT)
C
      SIGN = ONE
      KT0=2
  100 CONTINUE
C
C     COMPUTE E(TAU), QUIT ONCE THE ENERGY RISES
C
      DO 200 KT=KT0,MAXDEM
         TAU = SIGN * TAUTAB(KT)
         CALL DEMRHF(TAU,ESCF,FMO,V0,IA,OCC,H1,NOCC,L0,L1,L2,L3,
     *               FAO,FSAVE,EIG,SCR,IWRK,VEC,D,S,SMO,
     *               BUF,IBUF,NINTMX,NOPK)
         XTAU(KT)=TAU
         ETAU(KT)=ESCF+EN
         IF(DBG) WRITE(IW,9010) KT,XTAU(KT),ETAU(KT)
         IF(ETAU(KT).GT.ETAU(KT-1)) GO TO 300
  200 CONTINUE
C
C     NO BRACKETING, WE JUST TAKE THE LAST ENORMOUS SCALE FACTOR
C
      IF(MASWRK) WRITE(IW,9040) MAXDEM
      XOPT = XTAU(MAXDEM)
      NUMDEM=MAXDEM
      GO TO 400
C
C     IF THE ENERGY ROSE ON THE FIRST STEP, GO THE OTHER WAY
C
  300 CONTINUE
      IF(KT.EQ.2) THEN
         IF(MASWRK) WRITE(IW,9030)
         SIGN = -ONE
         KT0  = 3
         EDUM = ETAU(1)
         XDUM = XTAU(1)
         ETAU(1) = ETAU(2)
         XTAU(1) = XTAU(2)
         ETAU(2) = EDUM
         XTAU(2) = XDUM
         GO TO 100
      END IF
C
      NUMDEM=KT-1
C
C     QUADRATIC FIT TO THREE BRACKETING POINTS
C
      X1 = XTAU(KT-2)
      X2 = XTAU(KT-1)
      X3 = XTAU(KT  )
      E1 = ETAU(KT-2)
      E2 = ETAU(KT-1)
      E3 = ETAU(KT  )
      C2 = ((E1-E2)*(X2-X3) - (E2-E3)*(X1-X2))
      C2 = C2/((X1*X1-X2*X2)*(X2-X3) - (X2*X2-X3*X3)*(X1-X2))
      C1 = (E1 - E2 + C2 * (X2*X2-X1*X1))/(X1-X2)
      C0 = E1 - C2*X1*X1 - C1*X1
      XOPT = -C1/(C2+C2)
      EOPT = C2 * XOPT*XOPT + C1 * XOPT + C0
      IF(DBG) WRITE(IW,9020) XOPT,EOPT
C
C     SCALE MO FOCK MATRIX BY THE OPTIMAL VALUE
C
  400 CONTINUE
      IF(XOPT.NE.ZERO) CALL DEMSCL(FMO,XOPT,NOCC,L0,L2)
      RETURN
C
 9010 FORMAT(1X,'DEM SEARCH POINT',I3,' TAU=',F9.2,' E=',F20.10)
 9020 FORMAT(1X,'DEM MINIMUM AT TAU=',F9.4,'  PREDICTED E=',F20.10)
 9030 FORMAT(7X,'* * * CHANGING DEM UNIVARIATE SEARCH DIRECTION * * *')
 9040 FORMAT(7X,'* * * DEM UNIVARIATE SEARCH EXCEEDED',I3,
     *          ' STEPS * * *')
      END
C*MODULE RHFUHF  *DECK DEMRHF
      SUBROUTINE DEMRHF(TAU,ESCF,FMO,V0,IA,OCC,H1,NOCC,L0,L1,L2,L3,
     *                  FAO,FSAVE,EIG,SCR,IWRK,VEC,D,S,SMO,
     *                  BUF,IBUF,NINTMX,NOPK)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION FAO(L2),FMO(L2),FSAVE(L2),EIG(L1),OCC(L1),IA(L1),
     *          SCR(L1,8),IWRK(L1),VEC(L3),V0(L3),D(L2),H1(L2),
     *          BUF(NINTMX),IBUF(NINTMX),S(L2),SMO(L3)
C
      PARAMETER (TWO=2.0D+00)
C
C     ----- CALCULATE RHF ENERGY FOR DIRECT ENERGY MINIMIZATION -----
C     CALCULATE -ESCF- CORESPONDING TO THE GIVEN SCALE FACTOR -TAU-.
C
C     ON ENTRY, -FMO- IS AN UNSCALED FOCK OPERATOR IN THE MO BASIS.
C     -V0- MUST BE THE ORBITALS CORRESPONDING TO THIS FOCK MATRIX.
C     IN ADDITION, -IA- AND -OCC- AND -H1- MUST BE CORRECT.
C
C     SAVE ORIGINAL MO BASIS FOCK MATRIX
C
      CALL DCOPY(L2,FMO,1,FSAVE,1)
C
C     SCALE OCCUPIED-VIRTUAL BLOCK BY CURRENT TAU VALUE
C
      CALL DEMSCL(FMO,TAU,NOCC,L0,L2)
C
C     EXTRACT EIGENVECTORS FROM THE SCALED FOCK MATRIX,
C     BACK-TRANSFORM THE EIGENVECTORS (TO AO BASIS),
C     DO NOT PERMIT ANY ORBITAL FLIPS TO OCCUR DURING THE DEM,
C     FORM THE DENSITY MATRIX FOR THESE NEW EIGENVECTORS
C
      CALL GLDIAG(L1,L0,L0,FMO,SCR,EIG,VEC,IGERR,IWRK)
      IF(IGERR.NE.0) CALL ABRT
      CALL TFSQB(VEC,V0,SCR,L0,L1,L1)
      CALL OVLSEL(VEC,EIG,V0,S,SMO,SCR,IWRK,SCR,L0,L1,L2)
      CALL DMTX(D,VEC,OCC,NOCC,L1,L1)
C
C     MAKE THEIR FOCK MATRIX, ADD H1, CALCULATE HF ENERGY
C
      CALL HSTAR(D,FAO,BUF,IBUF,NINTMX,IA,NOPK,.FALSE.)
      CALL SYMH(FAO,FMO,IA)
      CALL VADD(FAO,1,H1,1,FAO,1,L2)
      ESCF = (TRACEP(D,H1,L1) + TRACEP(D,FAO,L1))/TWO
C
C     RESTORE THE ORIGINAL UNSCALED MO BASIS FOCK MATRIX
C
      CALL DCOPY(L2,FSAVE,1,FMO,1)
      RETURN
      END
C*MODULE RHFUHF  *DECK DEMSCL
      SUBROUTINE DEMSCL(FMO,TAU,NOCC,L0,L2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION FMO(L2)
C
C     SCALE OCCUPIED-VIRTUAL BLOCK OF THE MO BASIS FOCK OPERATOR
C
      DO 120 I=1,NOCC
         DO 110 K=NOCC+1,L0
            IK = (K*K-K)/2 + I
            FMO(IK) = TAU*FMO(IK)
  110    CONTINUE
  120 CONTINUE
      RETURN
      END
C*MODULE RHFUHF  *DECK HSTARLC
      SUBROUTINE HSTARLC(D,F,XX,IX,NINTMX,IA)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
      LOGICAL LCFLAG,LRINT
C
      DIMENSION D(*),F(*),IA(*),XX(NINTMX),IX(*)
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /ORDOPT/ NORDER(7)
      COMMON /PCKLAB/ LABSIZ
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
C
      PARAMETER (HALF=0.5D+00)
C
      CALL SEQREW(LRFILE)
C
      NUMTRI = (NUM*NUM+NUM)/2
      CALL VCLR(F,1,NUMTRI)
      I = 0
      J = 0
      K = 0
      L = 0
      NXX = 0
C
C     ----- LONG RANGE CORRECTION EXCHANGE FOR LC-DFT CASE -----
C
C     FIRST, PROCESS IN CORE INTEGRALS
      NPACKIC=0
  410 CONTINUE
C
      IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
        NXX=NXXIC
        NINT=NXX
      ELSE
C       IF ALL IN CORE BAIL OUT
        IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 490
        CALL PREAD(LRFILE,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
        IF(NXX .EQ. 0) GO TO 490
        NINT = IABS(NXX)
        IF(NINT .GT. NINTMX) CALL ABRT
      END IF
C
      DO 460 M = 1,NINT
         NPACK = NPACKIC+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
         END IF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
C
         VAL = XX(NPACK)
         NIJ = IA(I)+J
         NKL = IA(K)+L
C
C           USING SQUARE CANONICAL INTEGRAL FILE
C
         IF(NORDER(7).EQ.1) THEN
            IF(NKL .GT. NIJ) GO TO 460
            IF(I  .EQ.  J) VAL=VAL*HALF
            IF(K  .EQ.  L) VAL=VAL*HALF
            IF(NIJ.EQ.NKL) VAL=VAL*HALF
         END IF
C
         NIK = IA(I)+K
         NIL = IA(I)+L
         IF(J .LT. K) GO TO 420
         NJK = IA(J)+K
         NJL = IA(J)+L
         GO TO 440
C
  420    NJK = IA(K)+J
         IF(J .LT. L) GO TO 430
         NJL = IA(J)+L
         GO TO 440
C
  430    NJL = IA(L)+J
C
  440    CONTINUE
C
C        LONG RANGE CORRECTION EXCHANGE
C
         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)
  460 CONTINUE
C
      IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C     SWITCH TO INTEGRALS ON DISK
      IF(NXX .GT. 0) GO TO 410
C
  490 CONTINUE
C
      CALL SEQREW(LRFILE)
      RETURN
      END
C*MODULE RHFUHF  *DECK HSTAR
      SUBROUTINE HSTAR(D,F,XX,IX,NINTMX,IA,NOPK,DUPAO)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
*I32  CHARACTER*8 INAOFL
C
      LOGICAL GOPARR,DSKWRK,MASWRK,DUPAO,LCFLAG,LRINT
C
      DIMENSION D(*),F(*),IA(*),XX(NINTMX),IX(*)
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /ELGPMT/ NELONG,NATMM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      COMMON /ORDOPT/ NORDER(7)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (HALF=0.5D+00)
C
C         ----- FORM THE SKELETON CLOSED SHELL FOCK MATRIX -----
C     THIS MEANS ONLY SYMMETRY UNIQUE 2E- INTEGRALS ARE PROCESSED, SO
C     THE RESULTING MATRIX MUST BE SYMMETRIZED BY -SYMH- AND THEN WILL
C     NEED THE 1 ELECTRON TERMS ADDED IN ORDER TO FINISH A FOCK MATRIX.
C
C     INDICES IN AO INTEGRAL LABELS ARE IN STANDARD ORDER,
C               I.GE.J , K.GE.L , (IJ).GE.(KL)
C     THIS ROUTINE ALSO HAS AN OPTION TO PROCESS A -P- INTEGRAL LIST,
C     AND THERE IS SPECIAL CODE FOR FORMING A MATRIX WITH A DESIRED
C     ADMIXTURE OF THE EXCHANGE TERM (FOR PURPOSES OF DFT MATRICES).
C
C     IN CASE A DUPLICATED AO INTEGRAL LIST, AS OPPOSED TO A DISTRIBUTED
C     LIST, IS TO BE PRCESSED, WE MUST SKIP RECORDS IN ORDER TO MAKE THE
C     CPU WORK OF A FOCK BUILD BE PARALLELIZED.  DUPAO=.TRUE. IN CALL.
C
      CALL SEQREW(IS)
C
      IF(NELONG.GT.1) THEN
         NRECRD = 1
*I32     NFILE  = 1
*I32     INAOFL = 'AOINTS  '
      END IF
C
      NUMTRI = (NUM*NUM+NUM)/2
      IF(.NOT.LCFLAG) CALL VCLR(F,1,NUMTRI)
      I = 0
      J = 0
      K = 0
      L = 0
      NXX = 0
C
      IF(DUPAO) IPCOUNT = ME
C
      IF( (DFTTYP(3) .NE. 1.0D+00) .OR. LCFLAG ) GO TO 400
      IF(NOPK .NE. 1) GO TO 300
C
C     ----- INTEGRALS ARE IN STANDARD -J- LIST (NOPK=.TRUE.) -----
C
C     FIRST, PROCESS IN CORE INTEGRALS
      NPACKIC=0
  210 CONTINUE
C
C     DUPLICATED FILES MUST PREAD ONLY IF ITS OUR TURN TO DO A RECORD.
C     DISTRIBUTED FILES PROCESS EVERY RECORD IN THE LOCAL AO SUBFILE.
C
      IF(DUPAO) THEN
         IPCOUNT = IPCOUNT + 1
         IF (MOD(IPCOUNT,NPROC).NE.0) THEN
            READ (IS) NXX
            GO TO 280
         END IF
      END IF
C
      IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
        NXX=NXXIC
        NINT=NXX
      ELSE
C       IF ALL IN CORE BAIL OUT
        IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 290
        CALL PREAD(IS,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
        IF(NXX .EQ. 0) GO TO 290
        NINT = IABS(NXX)
        IF(NINT .GT. NINTMX) CALL ABRT
      END IF
C
      DO 260 M = 1,NINT
         NPACK = NPACKIC+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
         END IF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
C
         VAL = XX(NPACK)
         NIJ = IA(I)+J
         NKL = IA(K)+L
C
C           USING SQUARE CANONICAL INTEGRAL FILE
C
         IF(NORDER(7).EQ.1) THEN
            IF(NKL .GT. NIJ) GO TO 260
            IF(I  .EQ.  J) VAL=VAL*HALF
            IF(K  .EQ.  L) VAL=VAL*HALF
            IF(NIJ.EQ.NKL) VAL=VAL*HALF
         END IF
C
         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     DONE PROCESSING THIS ENTIRE INTEGRAL RECORD, GO BACK FOR MORE
C
  280 CONTINUE
C
      IF(NELONG.GT.1) THEN
      NRECRD = NRECRD + 1
*I32  IF(NRECRD.GT.8650) 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
      ENDIF
C
C     POSSIBLE SWITCH TO INTEGRALS ON DISK
C
      IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C
      IF(NXX.GT.0) GO TO 210
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)
C
C           ELONGATION METHOD GOES BACK TO MAIN INTEGRAL FILE
      IF(NELONG.GT.1) THEN
*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
      ENDIF
C
      RETURN
C     ******
C
C             ----- INTEGRALS ARE IN SUPERMATRIX FORM -----
C     E.G. THIS IS PROCESSING OF A -P- INTEGRAL FILE (NOPK=.FALSE.)
C
  300 CONTINUE
      NIJ=0
      DO M = 1,NUM
         NIJ = NIJ+M
         D(NIJ) = D(NIJ)*HALF
      ENDDO
C
*I64  MASK32 = 2**32 - 1
C
C
  310 CONTINUE
C
      IF(DUPAO) THEN
         IPCOUNT = IPCOUNT + 1
         IF (MOD(IPCOUNT,NPROC).NE.0) THEN
            READ (IS) NXX
            GO TO 380
         END IF
      END IF
C
      CALL PREAD(IS,XX,IX,NXX,NINTMX)
C
      IF(NXX .EQ. 0) GO TO 390
      NINT = IABS(NXX)
      IF(NINT .GT. NINTMX) CALL ABRT
C
      DO 360 M = 1,NINT
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        IPACK = IX( 2*NPACK - 1 )
*I32        JPACK = IX( 2*NPACK     )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -32 )
*I64        JPACK = IAND( LABEL, MASK32 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32        LABEL = IX(NPACK)
*I32        IPACK = ISHFT( LABEL, -16 )
*I32        JPACK = IAND( LABEL, 65535 )
*I64        IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64           LABEL = IX( NPACK/2 )
*I64           IPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64           JPACK = IAND( LABEL, 65535 )
*I64        ELSE
*I64           LABEL = IX( (NPACK/2)+1 )
*I64           IPACK = ISHFT( LABEL, -48 )
*I64           JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64        END IF
         END IF
         NIJ = IPACK
         NKL = JPACK
C
         VAL = XX(M)
         F(NIJ) = F(NIJ) + VAL*D(NKL)
         F(NKL) = F(NKL) + VAL*D(NIJ)
  360 CONTINUE
C
  380 CONTINUE
      IF(NXX .GT. 0) GO TO 310
C
C     RESTORE DENSITY MATRIX, HALVE FOCK MATRIX
C
  390 CONTINUE
      NIJ = 0
      DO M = 1,NUM
         NIJ = NIJ+M
         D(NIJ) = D(NIJ)+D(NIJ)
      ENDDO
C
      CALL DSCAL(NUMTRI,HALF,F,1)
      CALL SEQREW(IS)
      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
      HFSCAL=DFTTYP(3)
      IF(LCFLAG) HFSCAL=0.0D+00
C     FIRST, PROCESS IN CORE INTEGRALS
      NPACKIC=0
  410 CONTINUE
C
      IF(DUPAO) THEN
         IPCOUNT = IPCOUNT + 1
         IF (MOD(IPCOUNT,NPROC).NE.0) THEN
            READ (IS) NXX
            GO TO 480
         END IF
      END IF
      IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
        NXX=NXXIC
        NINT=NXX
      ELSE
C       IF ALL IN CORE BAIL OUT
        IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 490
        CALL PREAD(IS,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
        IF(NXX .EQ. 0) GO TO 490
        NINT = IABS(NXX)
        IF(NINT .GT. NINTMX) CALL ABRT
      END IF
C
      DO 460 M = 1,NINT
         NPACK = NPACKIC+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
         END IF
C
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
C
         VAL = XX(NPACK)
         NIJ = IA(I)+J
         NKL = IA(K)+L
C
C           USING SQUARE CANONICAL INTEGRAL FILE
C
         IF(NORDER(7).EQ.1) THEN
            IF(NKL .GT. NIJ) GO TO 460
            IF(I  .EQ.  J) VAL=VAL*HALF
            IF(K  .EQ.  L) VAL=VAL*HALF
            IF(NIJ.EQ.NKL) VAL=VAL*HALF
         END IF
C
         NIK = IA(I)+K
         NIL = IA(I)+L
         IF(J .LT. K) GO TO 420
         NJK = IA(J)+K
         NJL = IA(J)+L
         GO TO 440
C
  420    NJK = IA(K)+J
         IF(J .LT. L) GO TO 430
         NJL = IA(J)+L
         GO TO 440
C
  430    NJL = IA(L)+J
C
  440    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)*HFSCAL
         F(NIL) = F(NIL)-VAL*D(NJK)*HFSCAL
         F(NJK) = F(NJK)-VAL*D(NIL)*HFSCAL
         F(NJL) = F(NJL)-VAL*D(NIK)*HFSCAL
  460 CONTINUE
C
  480 CONTINUE
      IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C     SWITCH TO INTEGRALS ON DISK
      IF(NXX .GT. 0) GO TO 410
C
C     DONE CONSTRUCTING MATRIX, OFF DIAGONAL ELEMENTS NEED HALVING
C
  490 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
      END
C*MODULE RHFUHF  *DECK HSTARLCU
      SUBROUTINE HSTARLCU(DA,FA,DB,FB,XX,IX,NINTMX,IA)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL   LCFLAG,LRINT
C
      PARAMETER (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 /ORDOPT/ NORDER(7)
      COMMON /PCKLAB/ LABSIZ
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
C
      DIMENSION DA(*),FA(*),DB(*),FB(*),IA(*)
      DIMENSION XX(NINTMX),IX(NINTMX)
C
      PARAMETER (HALF=0.5D+00)
C
C     ----- FORM A SKELETON FOCK MATRIX FOR UHF -----
C
      CALL SEQREW(LRFILE)
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
C
C     ----- LONG RANGE CORRECTION EXCHANGE FOR LC-DFT CASE -----
C
C     FIRST, PROCESS IN CORE INTEGRALS
      NPACKIC=0
  620 CONTINUE
      IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
        NXX=NXXIC
        NINT=NXX
      ELSE
C       IF ALL IN CORE BAIL OUT
        IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 720
        CALL PREAD(IS,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
        IF(NXX.EQ.0) GO TO 720
        NINT = IABS(NXX)
        IF(NINT.GT.NINTMX) CALL ABRT
      END IF
      DO 700 M = 1,NINT
                       NPACK = NPACKIC+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
                       END IF
                       I = IPACK
                       J = JPACK
                       K = KPACK
                       L = LPACK
C
      VAL = XX(NPACK)
      NIJ = IA(I)+J
      NKL = IA(K)+L
C
C           USING SQUARE CANONICAL INTEGRAL FILE
C
      IF(NORDER(7).EQ.1) THEN
         IF(NKL.GT.NIJ) GO TO 700
            IF  (I.EQ.J)   VAL=VAL*HALF
            IF  (K.EQ.L)   VAL=VAL*HALF
            IF(NIJ.EQ.NKL) VAL=VAL*HALF
      END IF
C
      NIK = IA(I)+K
      NIL = IA(I)+L
      IF(J.LT.K) GO TO 640
      NJK = IA(J)+K
      NJL = IA(J)+L
      GO TO 680
C
  640 NJK = IA(K)+J
      IF(J.LT.L) GO TO 660
      NJL = IA(J)+L
      GO TO 680
C
  660 NJL = IA(L)+J
  680 CONTINUE
      VAL2 = VAL+VAL
      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)
  700 CONTINUE
      IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C     SWITCH TO INTEGRALS ON DISK
      IF(NXX .GT. 0) GO TO 620
C
  720 CONTINUE
      CALL SEQREW(LRFILE)
      RETURN
C     ******
      END
C*MODULE RHFUHF  *DECK HSTARU
      SUBROUTINE HSTARU(DA,FA,DB,FB,XX,IX,XP,XK,NINTMX,IA,NOPK)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL LCFLAG,LRINT
C
*I32  CHARACTER*8 INAOFL
C
      PARAMETER (MXATM=2000)
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /ELGPMT/ NELONG,NATMM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      COMMON /ORDOPT/ NORDER(7)
      COMMON /PCKLAB/ LABSIZ
C
      DIMENSION DA(*),FA(*),DB(*),FB(*),IA(*)
      DIMENSION XX(NINTMX),IX(NINTMX)
      DIMENSION XP(NINTMX),XK(NINTMX)
C
      PARAMETER (HALF=0.5D+00)
C
C     ----- FORM A SKELETON FOCK MATRIX FOR UHF -----
C
      CALL SEQREW(IS)
C
      IF(NELONG.GT.1) THEN
         NRECRD = 1
*I32     NFILE = 1
*I32     INAOFL = 'AOINTS  '
      END IF
C
      NUMSCF = NUM
      NUMTRI = (NUMSCF*NUMSCF+NUMSCF)/2
      IF (.NOT.LCFLAG) THEN
      CALL VCLR(FA,1,NUMTRI)
      CALL VCLR(FB,1,NUMTRI)
      ENDIF
      I = 0
      J = 0
      K = 0
      L = 0
      NXX = 0
      IF((DFTTYP(3) .NE. 1.0D+00).OR.LCFLAG) GO TO 610
      IF(NOPK.NE.1) GO TO 300
C
C     ----- INTEGRALS ARE NOT IN SUPERMATRIX FORM (NOPK=.TRUE.)
C
C     FIRST, PROCESS IN CORE INTEGRALS
      NPACKIC=0
  120 CONTINUE
      IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
        NXX=NXXIC
        NINT=NXX
      ELSE
C       IF ALL IN CORE BAIL OUT
        IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 220
C
C       IF NXXIC.EQ.NINTIC IT MAY BE THAT ALL INTEGRALS ARE IN CORE,
C       IF NXXIC.GE.NINTIC, THEN THERE SHOULD HAVE BEEN AT LEAST ONE
C       RECORD WRITTEN TO AVOID CONFUSION (POSSIBLY WITH ZERO LENGTH).
C
        CALL PREAD(IS,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
        IF(NXX.EQ.0) GO TO 220
        NINT = IABS(NXX)
        IF(NINT.GT.NINTMX) CALL ABRT
      END IF
      DO 200 M = 1,NINT
         NPACK = NPACKIC+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
         END IF
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
C
         VAL = XX(NPACK)
         NIJ = IA(I)+J
         NKL = IA(K)+L
C
C           USING SQUARE CANONICAL INTEGRAL FILE
C
         IF(NORDER(7).EQ.1) THEN
            IF(NKL.GT.NIJ) GO TO 200
            IF  (I.EQ.J)   VAL=VAL*HALF
            IF  (K.EQ.L)   VAL=VAL*HALF
            IF(NIJ.EQ.NKL) VAL=VAL*HALF
         END IF
C
         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
         VAL2 = VAL+VAL
         VAL4 = VAL2+VAL2
         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)
  200 CONTINUE
C
C     DONE PROCESSING THIS ENTIRE INTEGRAL RECORD, GO BACK FOR MORE
C
      IF(NELONG.GT.1) THEN
      NRECRD = NRECRD + 1
*I32  IF(NELONG.GT.1.AND.NRECRD.GT.8650) 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  END IF
      ENDIF
C
C        POSSIBLE SWITCH TO INTEGRALS ON DISK
      IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C
      IF(NXX.GT.0) GO TO 120
C
C     DONE FORMING FOCK MATRIX, HALVE THE OFF DIAGONAL ELEMENTS
C
  220 CONTINUE
      L2 = (NUM*NUM+NUM)/2
      CALL DSCAL(L2,HALF,FA,1)
      CALL DSCAL(L2,HALF,FB,1)
      II = 0
      DO 250 I=1,NUM
         II = II + I
         FA(II) = FA(II)+FA(II)
         FB(II) = FB(II)+FB(II)
  250 CONTINUE
C
C         REWIND AO INTEGRAL FILE
C
      IF(NELONG.GT.1) THEN
*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
      ENDIF
      CALL SEQREW(IS)
      RETURN
C     ******
C
C     ----- INTEGRALS ARE IN A SUPERMATRIX FORM (NOPK=.FALSE.)
C
  300 CONTINUE
      DO 310 N = 1,NUMTRI
         DUMA = DA(N)
         DUMB = DB(N)
         DA(N) = DUMA + DUMB
         DB(N) = DUMA - DUMB
  310 CONTINUE
      NIJ = 0
      DO 320 M = 1,NUMSCF
         NIJ = NIJ + M
         DA(NIJ) = DA(NIJ)*HALF
         DB(NIJ) = DB(NIJ)*HALF
  320 CONTINUE
C
*I64  MASK32 = 2**32 - 1
C
C     ----- SCALAR PROCESSING OF THE PK FILE -----
C
  340 CONTINUE
      CALL PKREAD(IS,XP,XK,IX,NXX,NINTMX)
      IF(NXX .EQ. 0) GO TO 500
      NINT = IABS(NXX)
      IF(NINT.GT.NINTMX) CALL ABRT
C
      DO 360 M = 1,NINT
C
                     NPACK = M
                     IF (LABSIZ .EQ. 2) THEN
*I32                   IPACK = IX( 2*NPACK - 1 )
*I32                   JPACK = IX( 2*NPACK     )
*I64                   LABEL = IX(NPACK)
*I64                   IPACK = ISHFT( LABEL, -32 )
*I64                   JPACK = IAND( LABEL, MASK32 )
                     ELSE IF (LABSIZ .EQ. 1) THEN
*I32                   LABEL = IX(NPACK)
*I32                   IPACK = ISHFT( LABEL, -16 )
*I32                   JPACK = IAND( LABEL, 65535 )
*I64                   IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                     LABEL = IX( NPACK/2 )
*I64                     IPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64                     JPACK = IAND( LABEL, 65535 )
*I64                   ELSE
*I64                     LABEL = IX( (NPACK/2)+1 )
*I64                     IPACK = ISHFT( LABEL, -48 )
*I64                     JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64                   END IF
                     END IF
                     NIJ = IPACK
                     NKL = JPACK
C
         DUMP = XP(M)*DA(NKL)
         DUMK = XK(M)*DB(NKL)
         FA(NIJ) = FA(NIJ)+DUMP-DUMK
         FB(NIJ) = FB(NIJ)+DUMP+DUMK
         DUMP = XP(M)*DA(NIJ)
         DUMK = XK(M)*DB(NIJ)
         FA(NKL) = FA(NKL)+DUMP-DUMK
         FB(NKL) = FB(NKL)+DUMP+DUMK
  360 CONTINUE
      IF(NXX .GT. 0) GO TO 340
C
C                              DONE PROCESSING PK FILE
C
  500 CONTINUE
      NIJ = 0
      DO 510 M = 1,NUMSCF
         NIJ = NIJ + M
         DA(NIJ) = DA(NIJ) + DA(NIJ)
         DB(NIJ) = DB(NIJ) + DB(NIJ)
  510 CONTINUE
      DO 520 I = 1,NUMTRI
         DUMA = DA(I)
         DUMB = DB(I)
         DA(I) = (DUMA + DUMB)
         DB(I) = (DUMA - DUMB)
  520 CONTINUE
      CALL DSCAL(NUMTRI,HALF,DA,1)
      CALL DSCAL(NUMTRI,HALF,DB,1)
      CALL DSCAL(NUMTRI,HALF,FA,1)
      CALL DSCAL(NUMTRI,HALF,FB,1)
      CALL SEQREW(IS)
      RETURN
C     ******
  610 CONTINUE
C     ----- INTEGRALS ARE NOT IN SUPERMATRIX FORM (NOPK=.TRUE.) -----
C     ----- DOING SPECIAL DFT CASE WHERE EXCHANGE CONTRIBUTION  -----
C     ----- IS MULTIPLIED BY SOME NUMBER BETWEEN ZERO AND ONE   -----
C
C     FIRST, PROCESS IN CORE INTEGRALS
      NPACKIC=0
  620 CONTINUE
      HFSCAL=DFTTYP(3)
      IF(LCFLAG) HFSCAL=0.0D+00
      IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
        NXX=NXXIC
        NINT=NXX
      ELSE
C       IF ALL IN CORE BAIL OUT
        IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 720
        CALL PREAD(IS,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
        IF(NXX.EQ.0) GO TO 720
        NINT = IABS(NXX)
        IF(NINT.GT.NINTMX) CALL ABRT
      END IF
      DO 700 M = 1,NINT
                       NPACK = NPACKIC+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
                       END IF
                       I = IPACK
                       J = JPACK
                       K = KPACK
                       L = LPACK
C
      VAL = XX(NPACK)
      NIJ = IA(I)+J
      NKL = IA(K)+L
C
C           USING SQUARE CANONICAL INTEGRAL FILE
C
      IF(NORDER(7).EQ.1) THEN
         IF(NKL.GT.NIJ) GO TO 700
            IF  (I.EQ.J)   VAL=VAL*HALF
            IF  (K.EQ.L)   VAL=VAL*HALF
            IF(NIJ.EQ.NKL) VAL=VAL*HALF
      END IF
C
      NIK = IA(I)+K
      NIL = IA(I)+L
      IF(J.LT.K) GO TO 640
      NJK = IA(J)+K
      NJL = IA(J)+L
      GO TO 680
C
  640 NJK = IA(K)+J
      IF(J.LT.L) GO TO 660
      NJL = IA(J)+L
      GO TO 680
C
  660 NJL = IA(L)+J
  680 CONTINUE
      VAL2 = VAL+VAL
      VAL4 = VAL2+VAL2
      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)*HFSCAL
      FB(NIK) = FB(NIK)-VAL2*DB(NJL)*HFSCAL
      FA(NIL) = FA(NIL)-VAL2*DA(NJK)*HFSCAL
      FB(NIL) = FB(NIL)-VAL2*DB(NJK)*HFSCAL
      FA(NJK) = FA(NJK)-VAL2*DA(NIL)*HFSCAL
      FB(NJK) = FB(NJK)-VAL2*DB(NIL)*HFSCAL
      FA(NJL) = FA(NJL)-VAL2*DA(NIK)*HFSCAL
      FB(NJL) = FB(NJL)-VAL2*DB(NIK)*HFSCAL
  700 CONTINUE
      IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C     SWITCH TO INTEGRALS ON DISK
      IF(NXX .GT. 0) GO TO 620
C
C     DONE FORMING FOCK MATRIX, HALVE THE OFF DIAGONAL ELEMENTS
C
  720 CONTINUE
      L2 = (NUM*NUM+NUM)/2
      CALL DSCAL(L2,HALF,FA,1)
      CALL DSCAL(L2,HALF,FB,1)
      II = 0
      DO 750 I=1,NUM
         II = II + I
         FA(II) = FA(II)+FA(II)
         FB(II) = FB(II)+FB(II)
  750 CONTINUE
      CALL SEQREW(IS)
      RETURN
C     ******
      END
C*MODULE RHFUHF  *DECK HSTARJK
      SUBROUTINE HSTARJK(DCORE,DVAL,JCORE,JVAL,KCORE,KVAL,
     *                   XX,IXX,NINTMX,IA,NOPK,L1,L2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION JCORE(L2),JVAL(L2),KCORE(L2),KVAL(L2)
      DIMENSION DCORE(L2),DVAL(L2),IA(L1),XX(NINTMX),IXX(*)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /ORDOPT/ NORDER(7)
      COMMON /PCKLAB/ LABSIZ
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
C
      PARAMETER (HALF=0.5D+00)
C
C     ----- FORM CORE AND VALENCE COULOMB AND EXCHANGE OPERATORS ----
C     N.B. DENSITY -DCORE- IS DESTROYED ON EXIT BY THE SYMMETRIZATION
C
      IF(NOPK .NE. 1) GO TO 300
C
      CALL VCLR(JCORE,1,L2)
      CALL VCLR(JVAL ,1,L2)
      CALL VCLR(KCORE,1,L2)
      CALL VCLR(KVAL ,1,L2)
C
C     ----- INTEGRALS ARE NOT IN SUPERMATRIX FORM (NOPK=.TRUE.) -----
C
C     FIRST, PROCESS IN CORE INTEGRALS
      NPACKIC=0
  120 CONTINUE
      IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
        NXX=NXXIC
        NINT=NXX
      ELSE
C       IF ALL IN CORE BAIL OUT
        IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 220
        CALL PREAD(IS,XX(NINTIC+1),IXX(ININTIC+1),NXX,NINTMX)
        IF(NXX .EQ. 0) GO TO 220
        NINT = IABS(NXX)
        IF(NINT .GT. NINTMX) CALL ABRT
      END IF
      DO 200 M = 1,NINT
C
         NPACK = NPACKIC+M
         IF (LABSIZ .EQ. 2) THEN
*I32       LABEL = IXX( 2*NPACK - 1 )
*I32       IPACK = ISHFT( LABEL, -16 )
*I32       JPACK = IAND(  LABEL, 65535 )
*I32       LABEL = IXX( 2*NPACK     )
*I32       KPACK = ISHFT( LABEL, -16 )
*I32       LPACK = IAND(  LABEL, 65535 )
*I64       LABEL = IXX(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 = IXX(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 = IXX( 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 = IXX( (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
         END IF
         I = IPACK
         J = JPACK
         K = KPACK
         L = LPACK
C
         VAL = XX(NPACK)
         NIJ = IA(I)+J
         NKL = IA(K)+L
         IF(NORDER(7) .NE. 1) GO TO 130
C
C           USING SQUARE CANONICAL INTEGRAL FILE
C
         IF(NKL .GT. NIJ) GO TO 200
            IF(I .EQ. J) VAL=VAL*HALF
            IF(K .EQ. L) VAL=VAL*HALF
            IF(NIJ .EQ. NKL) VAL=VAL*HALF
C
  130 CONTINUE
      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
      VAL2 = VAL+VAL
      JCORE(NIJ) = JCORE(NIJ)+VAL2*DCORE(NKL)
      JCORE(NKL) = JCORE(NKL)+VAL2*DCORE(NIJ)
      JVAL (NIJ) = JVAL (NIJ)+VAL2*DVAL (NKL)
      JVAL (NKL) = JVAL (NKL)+VAL2*DVAL (NIJ)
      KCORE(NIK) = KCORE(NIK)+ VAL*DCORE(NJL)
      KCORE(NIL) = KCORE(NIL)+ VAL*DCORE(NJK)
      KCORE(NJK) = KCORE(NJK)+ VAL*DCORE(NIL)
      KCORE(NJL) = KCORE(NJL)+ VAL*DCORE(NIK)
      KVAL (NIK) = KVAL (NIK)+ VAL*DVAL (NJL)
      KVAL (NIL) = KVAL (NIL)+ VAL*DVAL (NJK)
      KVAL (NJK) = KVAL (NJK)+ VAL*DVAL (NIL)
      KVAL (NJL) = KVAL (NJL)+ VAL*DVAL (NIK)
  200 CONTINUE
C
      IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C     SWITCH TO INTEGRALS ON DISK
      IF(NXX .GT. 0) GO TO 120
C
C       READY FOR FINAL MATRIX CONSTRUCTION, NAMELY ITS TIME TO
C       GLOBAL SUM OVER PROCESSORS, HALVE OFF-DIAGONAL, AND FINALLY
C       SYMMETRIZE THE SKELETON MATRICES.  (-DCORE- USED AS SCRATCH)
C
  220 CONTINUE
      CALL SEQREW(IS)
C
      CALL DDI_GSUMF(1000,JCORE,L2)
      CALL DDI_GSUMF(1001,JVAL ,L2)
      CALL DDI_GSUMF(1002,KCORE,L2)
      CALL DDI_GSUMF(1003,KVAL ,L2)
C
      CALL DSCAL(L2,HALF,JCORE,1)
      CALL DSCAL(L2,HALF,JVAL ,1)
      CALL DSCAL(L2,HALF,KCORE,1)
      CALL DSCAL(L2,HALF,KVAL ,1)
      II = 0
      DO 250 I=1,L1
         II = II + I
         JCORE(II) = JCORE(II)+JCORE(II)
         JVAL (II) = JVAL (II)+JVAL (II)
         KCORE(II) = KCORE(II)+KCORE(II)
         KVAL (II) = KVAL (II)+KVAL (II)
  250 CONTINUE
C
      CALL SYMH(JCORE,DCORE,IA)
      CALL SYMH(JVAL ,DCORE,IA)
      CALL SYMH(KCORE,DCORE,IA)
      CALL SYMH(KVAL ,DCORE,IA)
      RETURN
C     ******
C
C     ----- SUPERMATRIX INTEGRALS -----
C
  300 CONTINUE
      CALL ABRT
      STOP
      END
C*MODULE RHFUHF  *DECK RHFCL
      SUBROUTINE RHFCL
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,
     *        FMOEX,FMOPL,LCFLAG,LRINT,LCFLAGS,LRINTS,NEEDTAU,PRTTAU,SG1
C
      DOUBLE PRECISION MOROKM, MD
      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,
     *           MXRT=100, MXGRID=10)
      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 /DFLEB/  NLEB(MXGRID),NLEB0(MXGRID)
      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 /EFPFMO/ IEFPFMO,ISWENUC,REPNUCEFP,EFPEFP,RUNEFP
      COMMON /ELGPMT/ NELONG,NATMM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      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 /FMMDER/ MAXWS, NTBOX,NCXYZ, NTMPL,MAXNYP
      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 /MEXOPT/ MEXSKPGES,MEXSTATE
      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 /NEOJOB/ NEORUN,NELERM
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      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 /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 /VVOPAR/ IVVOS,NVVOS,BNDDEN
      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 RHF/8HRHF     /
      DATA  CHECK/8HCHECK   /, DEBUG/8HDEBUG   /, DBUGME/8HRHFCL   /
      DATA MOROKM/8HMOROKUMA/,  HESS/8HHESSIAN /, OPTMZE/8HOPTIMIZE/
      DATA   AMEX/8HMEX     /,    MD/8HMD      /, BNDANA/8HBONDANAL/
      DATA  G3MP2/8HG3MP2   /
      DATA NONE,ANONE/4HNONE,8HNONE    /
      DATA COARSE,FINE/8HCOARSE  ,8HFINE    /
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           ELONGATION SCF, WHICH MIGHT BE DONE ELSEWHERE, OR HERE
C
      IF(NELONG.GE.3) THEN
         CALL RHFELG
         RETURN
      END IF
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
      FMOEX=NFG.NE.0.AND.IFMOSTP.EQ.4.AND.IPIEDA.NE.0
C     FMOEX=NFG.NE.0.AND.(IFMOSTP.EQ.4.AND.IPIEDA.NE.0.OR.IFMOSTP.EQ.9)
      FMOPL=NFG.NE.0.AND.IFMOSTP.EQ.2.AND.IPIEDA.NE.0.AND.IRSTSTP.EQ.2
     *      .AND.MXITFG.EQ.1
C
C     --- COUNTER FOR NEO ---
      ICNT = 0
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).AND. (RUNTYP.NE.MD)
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
C         THERE IS A BUG WITH DFT+PCM+DIRSCF+FDIFF, AND A
C         WORKAROUND (AS OPPOSED TO A FIX) IS TO TURN FDIFF OFF.
      IF((IPCFP  .OR.  IPCM.EQ.1)   .AND.  NDFTFG.EQ.1
     *                              .AND.  DIRSCF) FDIFF=.FALSE.
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.
      LCFLAGS=LCFLAG
      LRINTS=LRINT
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
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
      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
C
C        AT EARLY POINTS IN GEOMETRY OPTS, WE CAN BE A BIT COARSER,
C        WHENEVER THE LAST GEOMETRY'S GRADIENT WAS STILL BIG.
C
      IF((RUNTYP.EQ.OPTMZE  .OR. RUNTYP.EQ.G3MP2)  .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
C
      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 STAGE 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 STAGE 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 STAGE 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
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
         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 JUST DON'T LET IT
         IF(IPCM.EQ.1) THEN
            NRAD0 = NRAD
            NPHI0 = NPHI
            NTHE0 = NTHE
            NLEB0(1) = NLEB(1)
         END IF
         IF(SG1) THEN
            GRIDTYP=FINE
         ELSE
            IF (NLEB(1).NE.0) THEN
               IF(NLEB(1)*NRAD.GT.NRAD0*NLEB0(1)) THEN
                  IF(MASPRT) WRITE(IW,9335) NRAD,NLEB(1),NRAD0,NLEB0(1)
                  IF(EXETYP.NE.CHECK) THEN
                     CALL SWGRID
                     GRIDTYP=COARSE
                  ELSE
                     GRIDTYP=FINE
                  END IF
               ELSE
                  GRIDTYP=FINE
               END IF
            ELSE
               IF(NRAD*NPHI*NTHE.GT.NRAD0*NPHI0*NTHE0) THEN
                  IF(MASPRT) WRITE(IW,9340) NRAD,NTHE,NPHI,NRAD0,NTHE0,
     *                                      NPHI0
C     POSSIBLE TDDFT CHECK RUN WILL NEED TO SEE TRUE GRID SIZE
                  IF(EXETYP.NE.CHECK) THEN
                     CALL SWGRID
                     GRIDTYP=COARSE
                  ELSE
                     GRIDTYP=FINE
                  END IF
               ELSE
                  GRIDTYP=FINE
               END IF
            ENDIF
         ENDIF   ! END SG1 IF/THEN/ELSE
         CALL DFTSET(X(IGRDDFT),1,.FALSE.)
C
C         SWITCH OFF DFT AT THIS POINT IF WE INITIATE BY HF ITERS
C
         IF(ISWOFF.GT.0) THEN
            IF(MASWRK  .AND.  NDFTFG.NE.0) WRITE(IW,9350)
            DFTTYP(3)=1.0D+00
            NDFTFG=0
            LCFLAG=.FALSE.
            LRINT=.FALSE.
         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) THEN
         IF(RUNTYP.EQ.BNDANA) THEN
            GO TO 510
         ELSE
            GO TO 520
         END IF
      END IF
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
      IF(ABINIT) THEN
         IF(DIRSCF) THEN
            IF(FDIFF) THEN
               CALL VSUB(X(LWRK1),1,X(LD),1,X(LWRK1),1,L2)
            ELSE
               CALL DCOPY(L2,X(LD),1,X(LWRK1),1)
            END IF
            IF(SCHWRZ) THEN
               DUMMY = 0.0D+00
               CALL SHLDEN(RHF,X(LWRK1),DUMMY,DUMMY,X(LDSH),
     *                     IA,L1,L2,NSH2,1)
            END IF
            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
               IF(LCFLAG) THEN
                  LRINT=.TRUE.
                  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)
                  LRINT=.FALSE.
               END IF
               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)
               CUTOFF = CUTSV
            END IF
            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.
            IF(LCFLAG) THEN
            CALL SEQREW(LRFILE)
            CALL HSTARLC(X(LD),X(LFAO),X(LBUF),X(LIBUF),
     *                NINTMX,IA)
            END IF
            CALL SEQREW(IS)
            CALL HSTAR(X(LD),X(LFAO),X(LBUF),X(LIBUF),
     *                 NINTMX,IA,NOPK,.FALSE.)
            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)
           EDFT(1)=EEXC
           EDFT(2)=TOTELE
C
           IF (PRTTAU) THEN
             CALL DDI_GSUMF(2317,TOTKIN,1)
             WRITE(IW,9326) TOTKIN
           END IF
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     ----- POSSIBLE NUCLEAR SCF LOOP(S) FOR NEO -----
C
      ADDNEO = 0.0D+00
      IF(NEORUN.EQ.1) THEN
         CALL NEOHF(X(LH1),X(LFAO),X(LD),DUMMY,DUMMY,X(LWRK1),DUMMY,
     *              X(LWRK2),X(LWRK3),ADDNEO,L1,L2,ICNT,EHFCL,
     *              ITER,EN)
      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
           IF (IEFPFMO.EQ.1) THEN
             CALL EFPCMPFMO(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),X(LFAO),DUMMY,X(LD),X(NDIPER),
     *                   X(LDIPER),X(LXDINT),X(LYDINT),X(LZDINT),
     *                   X(LEFLD),X(MADD),X(LABFLD),L2,L1,0)
           END IF
         ELSE
           IF (IEFPFMO.EQ.1) THEN
             CALL EFPCMPFMO(X(LH1),DUMMY,DUMMY,X(LD),DUMMY,DUMMY,
     *                      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
         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 710
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     --- POSSIBLE ADDITION OF NEO ENERGY ---
C
      ETOT = ETOT + ADDNEO
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 .OR. IPCFP) 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(FMOEX.AND.ITER.EQ.1) THEN
         E0SCF(1)=ETOT-ENVENE(L1,X(LD))
C        WRITE(6,*) 'WWWEX',E0SCF(1)
         IF(NORBPROJ.NE.0) THEN
            CALL DAREAD(IDAF,IODA,X(LWRK1),L2,312,0)
            EPROJ=TRACEP(X(LD),X(LWRK1),L1)
            E0SCF(1)=E0SCF(1)-EPROJ
C           WRITE(6,*) 'WWWEPROJ',EPROJ,E0SCF(1)
         ENDIF
      ENDIF
      IF(FMOPL.AND.ITER.EQ.1) THEN
        E0SCF(2)=ENVENE(L1,X(LD))
        E0SCF(1)=ETOT-E0SCF(2)
C       WRITE(6,*) 'WWWRHF',E0SCF(1),E0SCF(2)
      ENDIF
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        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
      IF(ABINIT) THEN
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LQ),LL3,45,0)
         CALL TFTRI(X(LWRK1),X(LFAO),X(LQ),X(LWRK),L0,L1,L1)
         CALL SYMDIA(X(LWRK1),X(LVEC),X(LEIG),X(LSCR),X(LIWRK),L0,L2,L1)
         CALL TFSQB(X(LVEC),X(LQ),X(LWRK),L0,L1,L1)
      ELSE
         CALL GLDIAG(L1,L1,L1,X(LFAO),X(LSCR),X(LEIG),X(LVEC),
     *               IGERR,X(LIWRK))
         IF(IGERR.NE.0) CALL ABRT
      END IF
C
  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
      CALL DCOPY(L2,X(LD),1,X(LWRK1),1)
      CALL DMTX(X(LD),X(LVEC),X(LOCC),NA,L1,L1)
      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(NEORUN.EQ.1)
     *   CVGED  = (CVGING  .AND.  (CVDENS.AND.CVENGY.OR.CVDIIS))
      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
        LCFLAG=LCFLAGS
        LRINT=LRINTS
        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*NANGPT(1).LT.NRAD0*NANGPT0(1)  .AND.  .NOT.SG1) 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
      IF(CVGED  .AND.  SOSCF) THEN
         IF(ABINIT) THEN
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LQ),LL3,45,0)
            CALL TFTRI(X(LWRK1),X(LFAO),X(LQ),X(LWRK),L0,L1,L1)
            CALL SYMDIA(X(LWRK1),X(LVEC),X(LEIG),X(LSCR),X(LIWRK),
     *                  L0,L2,L1)
            CALL TFSQB(X(LVEC),X(LQ),X(LWRK),L0,L1,L1)
         ELSE
            CALL GLDIAG(L1,L1,L1,X(LFAO),X(LSCR),X(LEIG),X(LVEC),
     *                  IGERR,X(LIWRK))
            IF(IGERR.NE.0) CALL ABRT
         END IF
         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
         CALL DMTX(X(LD),X(LVEC),X(LOCC),NA,L1,L1)
         CALL SCFSAV(X(LVEC),X(LD),X(LEIG),NDAF,LL1,LL2,LL3)
      END IF
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
  710 CONTINUE
C
      IF(CVGED) THEN
C
C     --- PCM DISPERSION INTERACTION PROCEDURE ---
C     PCM STAGE 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
C     BRANCH TO HERE ON SUCCESFUL CONVERGENCE
C
  400 CONTINUE
C
      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*NANGPT(1).LT.NRAD0*NANGPT0(1)  .AND.  .NOT.SG1)) THEN
        CALL SWGRID
        GRIDTYP = FINE
      END IF
C
C     ----- POSSIBLE AB INITIO - FRAGMENT EXCHANGE REPULSION
C
      CALL PAULIA(EEXCH)
      ETOT = ETOT + EEXCH
      IF (IEFPFMO.EQ.1) ETOT = ETOT - EFPEFP
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     MODIFICATION OF THE VIRTUAL SPACE ORBITALS, WHICH MAKE NO
C     MAKES NO SENSE AT ALL FOR MOROKUMA RUNS, AND ARE INCOMPATIBLE
C     WITH GRADIENTS OR HESSIANS DUE TO NOT HAVING CANONICAL VIRTUALS.
C
C     ----- MODIFIED VIRTUAL ORBITALS -----
C     FMO,DENSITY AT LWRK1,LWRK2 ARE SYMMETRIC MATRICES
C     -LWRK3- IS USED AS A SCRATCH SQUARE MATRIX
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     ----- VALENCE VIRTUAL ORBITALS -----
C
  510 CONTINUE
      IF(IVVOS.NE.0  .AND.  RUNTYP.NE.MOROKM) THEN
         NOCC = NA
         CALL VVOS(X(LVEC),X(LFAO),X(LEIG),
     *             X(LWRK1),X(LWRK2),X(LWRK3),X(LSCR),X(LIWRK),
     *             L0,L1,L2,L3,NOCC)
      END IF
      IF(EXETYP.EQ.CHECK) GO TO 520
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
         IF(RUNTYP.NE.AMEX) THEN
                              WRITE(IP,8010) ' $VEC   '
         ELSE
            IF(MEXSTATE.EQ.1) WRITE(IP,8010) ' $VEC1  '
            IF(MEXSTATE.EQ.2) WRITE(IP,8010) ' $VEC2  '
         END IF
         CALL PUSQL(X(LVEC),LPUN,L1,L1)
                           WRITE(IP,8010) ' $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     --- IF NEO RUN OUPUT NUCLEAR MOS ---
C
      IF(SOME .AND. NEORUN.EQ.1) THEN
         CALL NMOOUT(MPUNCH)
      END IF
C
C     ----- TIDY UP AND EXIT -----
C
  520 CONTINUE
      IF(CVGED) IREST = 0
C
      IF(FT15OP) THEN
C          MORBID PROBLEM:
C       SEQOPN OPENS NFT15 ON SLAVES, BUT SEQCLO DOES NOT
C       CLOSE IT ON THEM!
        TDSKWRK = DSKWRK
        DSKWRK = .TRUE.
        CALL SEQCLO(NFT15,'DELETE')
        DSKWRK = TDSKWRK
      ENDIF
      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')
 8010 FORMAT(A8)
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 CONVERGENCE THRESHOLD=',1P,E10.2/
     *       5X,'COARSE -> FINE DFT GRID SWITCH THRESHOLD=',1P,E10.2,
     *          ' (SWITCH IN $DFT)'/
     *       5X,'              HF -> DFT SWITCH THRESHOLD=',1P,E10.2,
     *          ' (SWOFF IN $DFT)')
 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 ITERS=',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 EXACT TOTAL FOCK',
     *           ' MATRIX'/
     *        1X,'FOR USE 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 FINE GRID')
 9335 FORMAT(/1X,'DFT CODE IS SWITCHING FROM THE FINE GRID NRAD=',I3,
     *           ',  NLEB=',I5/
     *       22X,'TO THE COARSE GRID NRAD0=',I3,', NLEB0=',I5)
 9340 FORMAT(/1X,'DFT CODE IS SWITCHING FROM THE FINE GRID NRAD=',I4,
     *          ',  NTHE, NPHI=',2I3/
     *       22X,'TO THE COARSE GRID NRAD0=',I3,
     *          ', NTHE0,NPHI0=',2I3)
 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,' )')
C
      END
C*MODULE RHFUHF  *DECK RMPFCK
      SUBROUTINE RMPFCK(FA,FB,V,NA,NB,L0,L1,L2,L3,VNEW,ENEW,FMO,SCR,
     *                  IWRK,MASWRK)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL MASWRK
C
      DIMENSION FA(L2),FB(L2),V(L1,L1),VNEW(L1,L1),ENEW(L1),FMO(L2),
     *          SCR(L1,8),IWRK(L1)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /ONEELC/ EONE,E1A,E1B
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA DEBUG/8HDEBUG   /
C
C       THIS ROUTINE CALCULATES THE EIGEN VALUES AND THE EIGEN
C       VECTORS OF ALPHA- AND BETA-FOCK MATRICES IN OCCUPIED AND
C       VIRTUAL SPACES TO OBTAIN SEMI-CANONICAL SPIN ORBITALS OF ROHF
C       WAVEFUNCTION.  THIS DEFINES THE UNIQUE ORBITAL ENERGIES FOR
C       STARTING ORBITALS OF ROHF-MP2 CALCULATIONS.
C
C       ON ENTRY -V- MUST BE THE ROHF ORBITALS, AND -FA- AND -FB-
C       MUST BE THE USUAL UHF-LIKE FOCK OPERATORS. -NACORE- AND -NBCORE'
C       ARE THE NUMBER OF CORE ORBITALS TO BE EXCLUDED FROM THE MP2,
C       TYPICALLY THESE ARE THE SAME!
C
C       WRITTEN BY NIKITA MATSUNAGA IN 1992, BASED ON THE PAPER
C           KNOWLES, ANDREWS, AMOS, HANDY, AND POPLE,
C           CHEM. PHYS. LETT.  186 (1991) 130.
C
      NAVIR = L0 - NA
      LAVIR = NA + 1
      NBVIR = L0 - NB
      LBVIR = NB + 1
C
C      SAVE THE ORIGINAL CANONICAL MO-S
C
      CALL DAWRIT(IDAF,IODA,V,L3,61,0)
C
C     ----- FIRST THE OCCUPIED ALPHA SPACE IS DIAGONALIZED -----
C
      CALL TFTRI(FMO,FA,V,SCR,NA,L1,L1)
      CALL GLDIAG(L1,NA,NA,FMO,SCR,ENEW,VNEW,IGERR,IWRK)
      IF(IGERR.GT.0) CALL ABRT
      CALL TFSQB(VNEW,V,SCR,NA,L1,L1)
C
C     ----- VIRTUAL SPACE OF ALPHA IS DIAGONALIZED -----
C
      CALL TFTRI(FMO,FA,V(1,LAVIR),SCR,NAVIR,L1,L1)
      CALL GLDIAG(L1,NAVIR,NAVIR,FMO,SCR,ENEW(LAVIR),VNEW(1,LAVIR),
     *            IGERR,IWRK)
      IF(IGERR.GT.0) CALL ABRT
      CALL TFSQB(VNEW(1,LAVIR),V(1,LAVIR),SCR,NAVIR,L1,L1)
C
      CALL DAWRIT(IDAF,IODA,VNEW,L3,15,0)
      CALL DAWRIT(IDAF,IODA,ENEW,L1,17,0)
C
      IF(EXETYP.EQ.DEBUG .AND. MASWRK) THEN
         WRITE(IW,*) 'RMPFCK--ALPHA ORBITALS AND ENERGIES'
         CALL PREV(VNEW,ENEW,L1,L1,L1)
      END IF
C
C     ----- EVALUATE ALPHA SINGLE EXCITATION TERM -----
C
      CALL TFTRI(FMO,FA,VNEW,SCR,L0,L1,L1)
      CALL RMPONE(FMO,ENEW,L0,NA,NACORE,LAVIR,E1A)
C
C     ----- OCCUPIED SPACE OF BETA -----
C
      CALL TFTRI(FMO,FB,V,SCR,NB,L1,L1)
      CALL GLDIAG(L1,NB,NB,FMO,SCR,ENEW,VNEW,IGERR,IWRK)
      IF(IGERR.GT.0) CALL ABRT
      CALL TFSQB(VNEW,V,SCR,NB,L1,L1)
C
C     ----- VIRTUAL SPACE OF BETA -----
C
      CALL TFTRI(FMO,FB,V(1,LBVIR),SCR,NBVIR,L1,L1)
      CALL GLDIAG(L1,NBVIR,NBVIR,FMO,SCR,ENEW(LBVIR),VNEW(1,LBVIR),
     *            IGERR,IWRK)
      IF(IGERR.GT.0) CALL ABRT
      CALL TFSQB(VNEW(1,LBVIR),V(1,LBVIR),SCR,NBVIR,L1,L1)
C
      CALL DAWRIT(IDAF,IODA,VNEW,L3,19,0)
      CALL DAWRIT(IDAF,IODA,ENEW,L1,21,0)
C
      IF(EXETYP.EQ.DEBUG .AND. MASWRK) THEN
         WRITE(IW,*) 'RMPFCK--BETA ORBITALS AND ENERGIES'
         CALL PREV(VNEW,ENEW,L1,L1,L1)
      END IF
C
C     ----- EVALUATE BETA SINGLE EXCITATION TERM -----
C
      CALL TFTRI(FMO,FB,VNEW,SCR,L0,L1,L1)
      CALL RMPONE(FMO,ENEW,L0,NB,NBCORE,LBVIR,E1B)
C
      EONE = E1A + E1B
C
      IF(EXETYP.EQ.DEBUG .AND. MASWRK) THEN
         WRITE(IW,*) '  SINGLE EXCITATION CORRECTIONS ARE'
         WRITE(IW,*) '        ALPHA =',E1A
         WRITE(IW,*) '        BETA  =',E1B
      END IF
      RETURN
      END
C*MODULE RHFUHF  *DECK RMPONE
      SUBROUTINE RMPONE(FMO,EIG,NUM,NOCC,NCORE,LVIR,E1)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION FMO(*),EIG(*)
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- CALCULATE THE SINGLE EXCITATION TERMS FOR ROHF-MP2 -----
C
      E1 = ZERO
      K = (NOCC*NOCC + NOCC)/2
      DO 150 I=LVIR,NUM
         L = K + I
         DO 100 J=NCORE+1,NOCC
            M = K + J
            E1 = E1 + FMO(M)*FMO(M)/(EIG(I) - EIG(J))
 100     CONTINUE
         K = L
 150  CONTINUE
      RETURN
      END
C*MODULE RHFUHF  *DECK ROFOCK
      SUBROUTINE ROFOCK(FA,FB,FMO,V,SCR,S,T,NA,NB,IMO,L0,L1,L2,L3,OUT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL OUT,JA,JB,JC,JO,JV,IA,IB,IC,IO,IV,MFRZ,LCUT
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
      COMMON /ELGIDX/ LCUT   ! RELATED TO ELONGATION METHOD
      COMMON /SCFWFN/ AROHF(3),BROHF(3),PACAVO(6),IACAVO,IUHFNO,
     *                MVOQ
C
      DIMENSION FA(L2),FB(L2),FMO(L2),V(L3),SCR(L1),S(L2),T(L3)
C
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00)
C
C     FORM THE ROHF FOCK MATRIX IN MO BASIS. SEE:
C           M. F. GUEST AND V. SAUNDERS
C            MOL. PHYS. 28, 819 (1974)
C
C     ON ENTRY, FA AND FB ARE ALPHA AND BETA FOCK MATRICES IN AO BASIS.
C               V IS THE CURRENT MO VECTORS.
C               IMO CONTROLS OUTPUT RESULT.
C               T IS WORK STORAGE, NEEDED IF IMO=0 ONLY.
C               S IS OVERLAP MATRIX, NEEDED IF IMO=0 ONLY.
C     ON EXIT,  FMO IS THE COMBINED FOCK OPERATOR, THIS IS ALWAYS
C               IN THE MO BASIS.  IF IMO=1, BOTH FA AND FB ARE ALSO
C               RETURNED IN THE MO BASIS.  IF IMO=0, THEN ON EXIT
C               FA CONTAINS THE COMBINED FOCK MATRIX, IN THE AO BASIS.
C
C     FOLLOWING GUEST AND SAUNDERS, THE MO FOCK MATRIX HAS THE FORM:
C
C                 CLOSED         OPEN         VIRTUAL
C
C     CLOSED        F2      |     FB      | (FA + FB)/2
C               ---------------------------------------
C     OPEN          FB      |     F1      |     FA
C               ---------------------------------------
C     VIRTUAL   (FA + FB)/2 |     FA      |     F0
C
C     WHERE FA AND FB ARE THE USUAL ALPHA AND BETA FOCK MATRICES,
C     AND F2, F1, AND F0 ARE ARBITRARY.  THEIR CHOICE, HOWEVER,
C     DOES DETERMINE THE CONVERGENCE PROPERTIES OF THE SCHEME,
C     AND THE NUMERICAL VALUES OF THE ORBITALS AND THEIR EIGEN-
C     VALUES (BUT NOT THE TOTAL ENERGY OR DENSITY).  F2, F1, AND F0
C     MAY BE WRITTEN AS:
C
C     F2 = ACC*FA + BCC*FB, F1 = AOO*FA + BOO*FB, F0 = AVV*FA + BVV*FB
C
C     CHOICES FOR THESE COEFFICIENTS FOUND IN THE LITERATURE ARE:
C
C                              ACC  BCC  AOO  BOO  AVV  BVV
C     GUEST AND SAUNDERS       1/2  1/2  1/2  1/2  1/2  1/2
C     ROOTHAAN SINGLE MATRIX  -1/2  3/2  1/2  1/2  3/2 -1/2
C     DAVIDSON                 1/2  1/2   1    0    1    0
C     BINKLEY, POPLE, DOBOSH    0    1    0    1    0    1
C     MCWEENY AND DIERCKSEN    A/2 A/2+C  B    C  A/2+B A/2
C
C    FOR MCWEENY AND DIERCKSEN, THE OFF DIAGONAL BLOCKS ARE
C    C-O=C*FB, C-V=A*(FA+FB)/, O-V=B*FA.  THE VALUES THEY
C    USE ARE A=2/3, B=C=1/3.  THIS MAKES THE FINAL ROW OF
C    THE TABLE READ            1/3  2/3  1/3  1/3  2/3  1/3
C    THE MULTIPLICATION OF THE OFFDIAGONAL BLOCKS BY MCW.-D.
C    CORRESPONDS TO A DAMPING OF THESE BLOCKS (SEE THE
C    PAPER BY GUEST AND SAUNDERS) AND SLOWS DOWN THE RATE
C    OF CONVERGENCE.  THIS OFF-DIAGONAL DAMPING IS NOT DONE
C    IN GAMESS.
C    THE OLD GAMESS ROHF CODE PRODUCES 'DAVIDSON' ORBITALS,
C    GAUSSIAN 86 PRODUCES 'MCWEENY-DIERCKSEN' ORBITALS.  THE
C    CONVERGENCE OBTAINED MAY VARY WITH THE CHOICE OF FOCK MATRIX.
C
C    THE OFF-DIAGONAL BLOCKS MAY ALSO INCLUDE A SCALE FACTOR
C    (THE DAMP FACTOR OF GUEST AND SAUNDERS), BUT THAT HAS NOT
C    BEEN IMPLEMENTED HERE.
C
C        THIS ROUTINE WRITTEN BY JOHN MONTGOMERY, SPRING 1988
C
      ACC = AROHF(1)
      AOO = AROHF(2)
      AVV = AROHF(3)
      BCC = BROHF(1)
      BOO = BROHF(2)
      BVV = BROHF(3)
C
C        TRANSFORM ALPHA AND BETA FOCK MATRICES TO MO BASIS.
C
      CALL TFTRI(FMO,FA,V,SCR,L0,L1,L1)
      CALL DCOPY(L2,FMO,1,FA,1)
C
      IF(NB.EQ.0) GO TO 700
      CALL TFTRI(FMO,FB,V,SCR,L0,L1,L1)
      CALL DCOPY(L2,FMO,1,FB,1)
C
C        MAKE ROHF FOCK MATRIX IN MO BASIS.
C
      IJ = 0
      DO 100 J = 1,L0
         JA = J.LE.NA
         JB = J.LE.NB
         JC = JA.AND.JB
         JV = .NOT.JA.AND..NOT.JB
         JO = .NOT.JC.AND..NOT.JV
         DO 100 I = 1,J
            IJ = IJ + 1
            IA = I.LE.NA
            IB = I.LE.NB
            IC = IA.AND.IB
            IV = .NOT.IA.AND..NOT.IB
            IO = .NOT.IC.AND..NOT.IV
            SUM = ZERO
            IF(IC.AND.JC) SUM = ACC*FA(IJ) + BCC*FB(IJ)
            IF(IC.AND.JO) SUM = FB(IJ)
            IF(IC.AND.JV) SUM = HALF*(FA(IJ) + FB(IJ))
            IF(IO.AND.JO) SUM = AOO*FA(IJ) + BOO*FB(IJ)
            IF(IO.AND.JV) SUM = FA(IJ)
            IF(IV.AND.JV) SUM = AVV*FA(IJ) + BVV*FB(IJ)
            FMO(IJ) = SUM
  100 CONTINUE
C
  700 CONTINUE
      IF(OUT) THEN
         WRITE (IW,9078)
         CALL PRTRIL(FMO,L0)
      END IF
      IF(IMO.EQ.1) RETURN
C                  ******
      IF(MFRZ) CALL FRFOCK(FMO,L1)
      IF(LCUT) CALL FRFELG(FMO,L1)
C
C        BACK-TRANSFORM ROHF FOCK MATRIX TO AO BASIS.
C
      CALL TFTRIB(FA,FMO,S,V,T,SCR,L0,L1,L2,L3)
C
      IF(OUT) THEN
         WRITE(IW,9058)
         CALL PRTRIL(FA,L1)
      END IF
      RETURN
C
 9058 FORMAT(10X,27(1H-)/10X,27HROHF FOCK MATRIX (AO BASIS)/10X,27(1H-))
 9078 FORMAT(10X,27(1H-)/10X,27HROHF FOCK MATRIX (MO BASIS)/10X,27(1H-))
      END
C*MODULE RHFUHF  *DECK ROLAG
      SUBROUTINE ROLAG(A,B,C,SCR,L1,L2,L3,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      DIMENSION A(L2),B(L2),C(L3),SCR(L1)
C
      PARAMETER (ONE=1.0D+00)
C
C     ----- COMPUTE UHF AND ROHF LAGRANGIAN -----
C     ROUTINE WRITTEN BY JOHN MONTGOMERY, SPRING 1988.
C
C        ALPHA PART
C
      CALL DAREAD(IDAF,IODA,A,L2,14,0)
      CALL DAREAD(IDAF,IODA,B,L2,16,0)
      CALL CPYTSQ(B,C,L1,1)
      CALL TFTRI(B,A,C,SCR,L1,L1,L1)
      CALL DAWRIT(IDAF,IODA,B,L2,36,0)
C
C        BETA PART
C
      CALL DAREAD(IDAF,IODA,A,L2,18,0)
      CALL DAREAD(IDAF,IODA,B,L2,20,0)
      CALL CPYTSQ(B,C,L1,1)
      CALL TFTRI(B,A,C,SCR,L1,L1,L1)
C
      CALL DAREAD(IDAF,IODA,A,L2,36,0)
      CALL VADD(A,1,B,1,C,1,L2)
      CALL DSCAL(L2,-ONE,C,1)
      CALL DAWRIT(IDAF,IODA,C,L2,36,0)
C
      IF(OUT) THEN
         WRITE (IW,9000)
         CALL PRTRI(C,L1)
      END IF
      RETURN
C
 9000 FORMAT(//20X, 'UHF/ROHF LAGRANGIAN')
      END
C*MODULE RHFUHF  *DECK SPIN
      SUBROUTINE SPIN(SZ,S2,DA,DB,S,D,T,IA,NA,NB,L1,L2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION DA(L2),DB(L2),S(L2),D(L2),T(L1),IA(L1)
C
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00)
C
C     ----- CALCULATE SPIN EXPECTATION VALUES -----
C
C     FIRST, SYMMETRIC MATRIX D = S*DA*S
C
      IJ=0
      DO 280 J=1,L1
         DO 200 I=1,L1
            DUM = ZERO
            DO 180 K = 1,L1
               IK = IA(I)+K
               IF(K.GT.I) IK=IA(K)+I
               JK = IA(J)+K
               IF(K.GT.J) JK = IA(K)+J
               DUM = DUM+DA(IK)*S(JK)
  180       CONTINUE
            T(I) = DUM
  200    CONTINUE
         DO 270 I = 1,J
            DUM = ZERO
            DO 260 K = 1,L1
               IK = IA(I)+K
               IF(K.GT.I) IK=IA(K) + I
               DUM = DUM+S(IK)*T(K)
  260       CONTINUE
            IJ = IJ+1
            D(IJ) = DUM
  270    CONTINUE
  280 CONTINUE
C
C     ----- CALCULATE SPIN QUANTUM NUMBERS -----
C
      SZ = HALF * (NA-NB)
      S2 = SZ*SZ + HALF*(NA+NB)  -  TRACEP(DB,D,L1)
      RETURN
      END
C*MODULE RHFUHF  *DECK UHFNOS
      SUBROUTINE UHFNOS(OCCNO,IWORK,SCR,DENS,S,VEC,WORK,Q,
     *                  L0,L1,L2,IREAD)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION OCCNO(L1),IWORK(L1),SCR(L1*8),DENS(L2),S(L2),
     *          VEC(L1*L1),WORK(L1*L1),Q(L1*L1)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA UHF,ROHF/8HUHF     ,8HROHF    /
C
C     THIS ROUTINE WILL GENERATE NATURAL ORBITALS FOR A GIVEN AO DENSITY
C       SPECIFICALLY THE NATURAL ORBITALS OF THE -UHF- WAVEFUNCTION
C       AND THE NATURAL ORBITALS FOR RHF/UHF+MP2 WAVEFUNCTIONS
C       AND THE NATURAL ORBITALS FOR ROHF+MP2 WAVEFUNCTIONS
C
C   TWO RELATIVELY RECENT PAPERS ADVOCATING EXTRACTION OF UHF NO'S
C   AS A WAY TO AUTOMATE ACTIVE SPACE SELECTION FOR MCSCF ARE
C      P.PULAY, T.P.HAMILTON  J.CHEM.PHYS. 88, 4926-4933(1988)
C      J.M.BOFILL, P.PULAY  J.CHEM.PHYS. 90, 3637-3646(1989)
C   BUT PLEASE NOTE THAT THE IDEA OF FORMING UHF NO'S FOR VARIOUS
C   PURPOSES HAS A VERY LONG HISTORY.  AN EARLY REFERENCE TO THIS,
C   ALTHOUGH NOT NECESSARILY THE OLDEST, IS
C      J.E.HARRIMAN J.CHEM.PHYS. 40, 2827-2839(1964)
C
C     ----- OBTAIN TOTAL DENSITY MATRIX (DENS) -----
C
      IF(IREAD.EQ.1) THEN
         CALL DAREAD(IDAF,IODA,DENS,L2,16,0)
         IF(SCFTYP.EQ.UHF) THEN
            CALL DAREAD(IDAF,IODA,S,L2,20,0)
            CALL VADD(DENS,1,S,1,DENS,1,L2)
         END IF
         IF(SCFTYP.EQ.ROHF .AND. MPLEVL.EQ.2) THEN
            CALL DAREAD(IDAF,IODA,S,L2,20,0)
            CALL VADD(DENS,1,S,1,DENS,1,L2)
         END IF
      END IF
C
C     ----- READ IN THE Q MATRIX AND THE OVERLAP S -----
C
      CALL DAREAD(IDAF,IODA,S,L2   ,12,0)
      CALL DAREAD(IDAF,IODA,Q,L1*L0,45,0)
C
C     ----- SET WORK = S * Q -----
C
      CALL MTARBR(S,L1,Q,L0,WORK,L1,1)
C
C     ----- SET VEC = (SQ)-DAGGER * DENS * (SQ) -----
C     THIS IS THE DENSITY MATRIX IN THE Q MO BASIS
C
      CALL TFTRI(VEC,DENS,WORK,SCR,L0,L1,L1)
C
C     ----- DIAGONALIZE TO FORM NATURAL ORBITALS IN Q BASIS -----
C
      IDUM=(L0*L0+L0)/2
      CALL SYMDIA(VEC,WORK,OCCNO,SCR,IWORK,L0,IDUM,L0)
C
C     ----- OCCNO IS NOW THE NATURAL ORBITAL OCCUPATION NUMBERS
C     ----- WORK IS NOW THE ROTATION THAT CONVERTS Q ORBS TO NAT. ORBS
C     ----- BACKTRANSFORM TO OBTAIN NATURAL ORBITALS, VEC= Q * WORK
C
      CALL MRARBR(Q,L1,L1,L0,WORK,L0,L0,VEC,L1)
C
C     ----- REORDER FROM HIGHEST TO LOWEST OCCUPANCY -----
C
      DO 310 I=1,L0
         IWORK(I) = L0 - I + 1
  310 CONTINUE
      CALL REORDR(VEC,IWORK,L0,L1)
      DO 320 I=1,L0
         IWORK(I) = L0 - I + 1
  320 CONTINUE
      CALL REORDR(OCCNO,IWORK,L0,1)
      RETURN
      END
C*MODULE RHFUHF  *DECK UHFOP
      SUBROUTINE UHFOP(SZ,S2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION MAKEFP, MD
      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,LCFLAG,LRINT,LCFLAGS,LRINTS,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 /DFLEB/  NLEB(MXGRID),NLEB0(MXGRID)
      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 /ELGPMT/ NELONG,NATMM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      COMMON /FMCOM / X(1)
      COMMON /FMMDER/ MAXWS, NTBOX,NCXYZ, NTMPL,MAXNYP
      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 /MEXOPT/ MEXSKPGES,MEXSTATE
      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 /NEOJOB/ NEORUN,NELERM
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      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 /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 /SOSYM/  EULANG(4,48),GAM(48,48),IRMON(MXAO)
      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
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00,
     *           ONEPT5=1.5D+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 /,  AMEX/8HMEX     /
      DATA MAKEFP/8HMAKEFP  /,   MD/8HMD      /, G3MP2/8HG3MP2   /
      DATA NONE,ANONE/4HNONE,8HNONE    /
      DATA COARSE,FINE/8HCOARSE  ,8HFINE    /
C
C     ----- UNRESTRICTED HF-SCF CALCULATION -----
C     J.A.POPLE AND R.K.NESBET   J.CHEM.PHYS. 22, 571 (1954)
C
C     ----- HIGH SPIN RESTRICTED OPEN SHELL HF-SCF CALCULATION -----
C     M.F.GUEST AND V.SAUNDERS   MOL.PHYS. 28, 819 (1974)
C     AND SEE ALSO THE GAMESS MANUAL CHAPTER -REFS.DOC- ON THE
C     SUBJECT OF FOLDING F-ALPHA, F-BETA INTO A ROHF FOCK MATRIX.
C     FOR ROHF, WE EXIT WITH F-ALPHA AND F-BETA ON DIRECT ACCESS
C     RECORDS 14 AND 18, AND THE COMBINED FOCK MATRIX ON RECORD 51.
C
      ABINIT = MPCTYP.EQ.NONE
C
C           ELONGATION SCF, WHICH MIGHT BE DONE ELSEWHERE, OR HERE
C
      IF(NELONG.GE.3) THEN
         CALL UHFELG(SZ,S2)
         RETURN
      END IF
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).AND. (RUNTYP.NE.MD)
      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     --- COUNTER FOR NEO ---
      ICNT = 0
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
C         THERE IS A BUG WITH DFT+PCM+DIRSCF+FDIFF, AND A
C         WORKAROUND (AS OPPOSED TO A FIX) IS TO TURN FDIFF OFF.
      IF((IPCFP  .OR.  IPCM.EQ.1)   .AND.  NDFTFG.EQ.1
     *                              .AND.  DIRSCF) FDIFF=.FALSE.
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
      LCFLAGS=LCFLAG
      LRINTS=LRINT
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
C     ----- GET MEMORY -----
C
      CALL GETFM(NEED)
C
      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
      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
C
C        AT EARLY POINTS IN GEOMETRY OPTS, WE CAN BE A BIT COARSER,
C        WHENEVER THE LAST GEOMETRY'S GRADIENT WAS STILL BIG.
C
      IF((RUNTYP.EQ.OPTMZE  .OR. RUNTYP.EQ.G3MP2)  .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
C
      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
      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
      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 JUST DON'T LET IT
         IF(IPCM.EQ.1) THEN
            NRAD0 = NRAD
            NPHI0 = NPHI
            NTHE0 = NTHE
            NLEB0(1) = NLEB(1)
         END IF
         IF(SG1) THEN
            GRIDTYP=FINE
         ELSE
            IF (NLEB(1).NE.0) THEN
               IF(NLEB(1)*NRAD.GT.NRAD0*NLEB0(1)) THEN
                  IF(MASPRT) WRITE(IW,9335) NRAD,NLEB(1),NRAD0,NLEB0(1)
                  IF(EXETYP.NE.CHECK) THEN
                     CALL SWGRID
                     GRIDTYP=COARSE
                  ELSE
                     GRIDTYP=FINE
                  END IF
               ELSE
                  GRIDTYP=FINE
               END IF
            ELSE
               IF(NRAD*NPHI*NTHE.GT.NRAD0*NPHI0*NTHE0) THEN
                  IF(MASPRT) WRITE(IW,9340) NRAD,NTHE,NPHI,NRAD0,NTHE0,
     *                 NPHI0
C     POSSIBLE TDDFT CHECK RUN WILL NEED TO SEE TRUE GRID SIZE
                  IF(EXETYP.NE.CHECK) THEN
                     CALL SWGRID
                     GRIDTYP=COARSE
                  ELSE
                     GRIDTYP=FINE
                  END IF
               ELSE
                  GRIDTYP=FINE
               END IF
            ENDIF
         ENDIF
         CALL DFTSET(X(IGRDDFT),1,.FALSE.)
C
C         SWITCH OFF DFT AT THIS POINT IF WE INITIATE BY HF ITERS
C
         IF(ISWOFF.GT.0) THEN
            IF(MASWRK  .AND.  NDFTFG.NE.0) WRITE(IW,9350)
            DFTTYP(3)=1.0D+00
            NDFTFG=0
            LCFLAG=.FALSE.
            LRINT=.FALSE.
         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
  310 CONTINUE
      IF(ABINIT) THEN
         IF(DIRSCF) THEN
            IF(FDIFF) THEN
               CALL VSUB(X(LWRK1),1,X(LDA),1,X(LWRK1),1,L2)
               CALL VSUB(X(LWRK2),1,X(LDB),1,X(LWRK2),1,L2)
            ELSE
               CALL DCOPY(L2,X(LDA),1,X(LWRK1),1)
               CALL DCOPY(L2,X(LDB),1,X(LWRK2),1)
            END IF
            IF(SCHWRZ) THEN
               DUMMY = 0.0D+00
               CALL SHLDEN(SCFTYP,X(LWRK1),X(LWRK2),DUMMY,X(LDSH),
     *                     IA,L1,L2,NSH2,1)
            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(LCFLAG) THEN
                  LRINT=.TRUE.
                  CALL TWOEI(SCFTYP,DIRSCF,.FALSE.,.FALSE.,.FALSE.,
     *                    INTTYP,.FALSE.,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)
                  LRINT=.FALSE.
               END IF
               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)
               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.
            IF(LCFLAG) THEN
               CALL SEQREW(LRFILE)
               CALL HSTARLCU(X(LDA),X(LFA),X(LDB),X(LFB),X(LXP),
     *                       X(LXK),NINTMX,IA)
            END IF
            CALL SEQREW(IS)
            CALL HSTARU(X(LDA),X(LFA),X(LDB),X(LFB),X(LXP),
     *                  X(LIXPK),X(LXP),X(LXK),NINTMX,IA,NOPK)
            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     ----- POSSIBLE NUCLEAR SCF LOOP(S) FOR NEO -----
C
      ADDNEO = 0.0D+00
      IF(NEORUN.EQ.1) THEN
         CALL NEOHF(X(LH1),X(LFA),X(LDA),X(LFB),X(LDB),X(LWRK1),
     *              X(LWRK2),X(LWRK3),X(LWRK4),ADDNEO,L1,L2,
     *              ICNT,EHFCL,ITER,EN)
      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)
      IF(CVGED  .AND.  ICCFLG.GT.0) GO TO 710
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     --- POSSIBLE ADDITION OF NEO ENERGY ---
C
      ETOT = ETOT + ADDNEO
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 .OR. IPCFP) 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 ITERS HAVE BEEN UPHILL, GRAB TWO ITERS AGO.
C           IF ONLY THE LAST ITER 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)
         IF(NB.GT.0) THEN
            CALL SOGRAD(X(LGRADB),X(LFB),X(LVB),X(LSCR),NPRB,NB,
     *                  L0,L1,ORBGRB)
         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)
               END IF
            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 PROCEDURES -----
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
      IF(ABINIT) THEN
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
         CALL TFTRI(X(LWRK1),X(LFA),X(LQ),X(LSCR),L0,L1,L1)
         CALL SYMDIA(X(LWRK1),X(LVA),X(LEA),X(LSCR),X(LIWRK),L0,L2,L1)
         CALL TFSQB(X(LVA),X(LQ),X(LSCR),L0,L1,L1)
      ELSE
         CALL GLDIAG(L1,L1,L1,X(LFA),X(LSCR),X(LEA),X(LVA),
     *               IGERR,X(LIWRK))
         IF(IGERR.NE.0) CALL ABRT
      END IF
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
      IF(ABINIT) THEN
         IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
         CALL TFTRI(X(LWRK1),X(LFB),X(LQ),X(LSCR),L0,L1,L1)
         CALL SYMDIA(X(LWRK1),X(LVB),X(LEB),X(LSCR),X(LIWRK),L0,L2,L1)
         CALL TFSQB(X(LVB),X(LQ),X(LSCR),L0,L1,L1)
      ELSE
         CALL GLDIAG(L1,L1,L1,X(LFB),X(LSCR),X(LEB),X(LVB),
     *               IGERR,X(LIWRK))
         IF(IGERR.NE.0) CALL ABRT
      END IF
C
  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)
      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)
         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(NEORUN.EQ.1)
     *   CVGED  = (CVGING  .AND.  (CVDENS.AND.CVENGY.OR.CVDIIS))
      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
        LCFLAG=LCFLAGS
        LRINT=LRINTS
        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*NANGPT(1).LT.NRAD0*NANGPT0(1)  .AND.  .NOT.SG1) 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
C     ROHF MAKEFP RUNS MUST USE ROOTHAAN CANONICALIZATION,
C     FORCE THESE PARAMETERS FOR THE FINAL SCF ITERATION
C
      IF(CVGING  .AND.  RUNTYP.EQ.MAKEFP) THEN
         IF(AROHF(1).NE.-HALF  .OR.  BROHF(1).NE.ONEPT5 .OR.
     *       AROHF(2).NE. HALF  .OR.  BROHF(2).NE. HALF  .OR.
     *       AROHF(3).NE.ONEPT5 .OR.  BROHF(3).NE.-HALF) THEN
            IF(MASPRT  .AND.  .NOT.CVGED) WRITE(IW,9390)
            AROHF(1)=-HALF
            AROHF(2)=HALF
            AROHF(3)=ONEPT5
            BROHF(1)=ONEPT5
            BROHF(2)=HALF
            BROHF(3)=-HALF
         END IF
      END IF
C
C     THE COUPLED CLUSTER PROGRAM WANTS THE FOCK MATRICES THAT
C     CORRESPONDS -EXACTLY- TO THE FINAL ORBITALS.  EVEN AT
C     CONVERGENCE THERE ARE ALWAYS SOME RESIDUAL OFF-DIAGONAL
C     FOCK MATRIX ELEMENTS, SO WE MUST COMPUTE THEM 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),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
         GO TO 310
      END IF
  710 CONTINUE
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
         IF(ABINIT) THEN
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
            CALL TFTRI(X(LWRK1),X(LFA),X(LQ),X(LSCR),L0,L1,L1)
            CALL SYMDIA(X(LWRK1),X(LVA),X(LEA),X(LSCR),X(LIWRK),
     *                  L0,L2,L1)
            CALL TFSQB(X(LVA),X(LQ),X(LSCR),L0,L1,L1)
         ELSE
            CALL GLDIAG(L1,L1,L1,X(LFA),X(LSCR),X(LEA),X(LVA),
     *                  IGERR,X(LIWRK))
            IF(IGERR.NE.0) CALL ABRT
         END IF
         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
         IF(ABINIT) THEN
            IF(MINMEM) CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
            CALL TFTRI(X(LWRK1),X(LFB),X(LQ),X(LSCR),L0,L1,L1)
            CALL SYMDIA(X(LWRK1),X(LVB),X(LEB),X(LSCR),X(LIWRK),
     *                  L0,L2,L1)
            CALL TFSQB(X(LVB),X(LQ),X(LSCR),L0,L1,L1)
         ELSE
            CALL GLDIAG(L1,L1,L1,X(LFB),X(LSCR),X(LEB),X(LVB),
     *                  IGERR,X(LIWRK))
            IF(IGERR.NE.0) CALL ABRT
         END IF
         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*NANGPT(1).LT.NRAD0*NANGPT0(1)  .AND.  .NOT.SG1)) 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)
      CALL DAWRIT(IDAF,IODA,IRMON,L1,356,1)
      IF(SCFTYP.EQ.ROHF) CALL DAWRIT(IDAF,IODA,IRMON,L1,357,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)
      CALL DAWRIT(IDAF,IODA,IRMON,L1,357,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
         IF(RUNTYP.NE.AMEX) THEN
                              WRITE(IP,8010) ' $VEC   '
         ELSE
            IF(MEXSTATE.EQ.1) WRITE(IP,8010) ' $VEC1  '
            IF(MEXSTATE.EQ.2) WRITE(IP,8010) ' $VEC2  '
         END IF
         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,8010) ' $END   '
      END IF
C
C     --- IF NEO RUN OUPUT NUCLEAR MOS ---
C
      IF(SOME .AND. NEORUN.EQ.1) THEN
         CALL NMOOUT(MPUNCH)
      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')
 8010 FORMAT(A8)
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 CONVERGENCE THRESHOLD=',1P,E10.2/
     *       5X,'COARSE -> FINE DFT GRID SWITCH THRESHOLD=',1P,E10.2,
     *          ' (SWITCH IN $DFT)'/
     *       5X,'              HF -> DFT SWITCH THRESHOLD=',1P,E10.2,
     *          ' (SWOFF IN $DFT)')
 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 ITERS=',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-))
 9105 FORMAT(/1X,'ROHF HAS CONVERGED, NOW COMPUTING EXACT ALPHA,BETA',
     *           ' FOCK MATRICES'/
     *        1X,'FOR USE DURING THE COUPLED CLUSTER CALCULATION',
     *           ' THAT FOLLOWS.')
 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 FINE GRID')
 9335 FORMAT(/1X,'DFT CODE IS SWITCHING FROM THE FINE GRID NRAD=',I3,
     *           ',  NLEB=',I5/
     *       22X,'TO THE COARSE GRID NRAD0=',I3,', NLEB0=',I5)
 9340 FORMAT(/1X,'DFT CODE IS SWITCHING FROM THE FINE GRID NRAD=',I3,
     *          ',  NTHE, NPHI=',2I3/
     *       22X,'TO THE COARSE GRID NRAD0=',I3,
     *          ', NTHE0,NPHI0=',2I3)
 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.')
 9390 FORMAT(1X,'ULTIMATE SCF CYCLE OF MAKEFP SWITCHES TO THE',
     *          ' ROOTHAAN CANONICALIZATION...')
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)
C
      END
