C 13 MAR 06 - MWS - ASSIGN CI LAGRANGIAN TO UNIQUE DAF RECORD
C 17 JAN 06 - MWS - DD_SHELLS: COMPLETE H,I BOOKKEEPPING CHANGES
C 14 NOV 05 - LVS - CPWXYO,CPH2O: FIX SPHERICAL HARMONIC BUG
C 19 SEP 05 - YA  - IMPLEMENT DISTRIBUTED MEMORY RHF RESPONSE EQUATIONS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  7 MAR 05 - IA  - CALC. MAGNETIC HESSIAN (H2) FOR DYN. POLARIZABILITY
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL
C  7 SEP 04 - MWS - PAD COMMON BLOCK INTFIL
C 23 JUL 04 - DGF - CPRHF: READ CORRECT CI LAGRANGIAN IF SPHER.HARM.
C 19 MAY 04 - MWS - CPINP: CHANGE RHF DEFAULT TO AO BASIS CPHF
C  9 DEC 03 - OQ  - CPRHF: SAVE INFORMATION FOR EXTENDED TDHF PACKAGE
C  3 SEP 03 - SPW - AOFLM2: ADD CIS ARGUMENT TO TWOEI CALL
C 12 DEC 02 - MWS - AOFLM2: INT. ACCURACY ADJUSTMENT IF DIRECT JOB
C 22 MAY 02 - KRG - CPDIIS,CDIISU: TRUNCATE DIIS SPACE IF SINGULARITIES
C 24 JAN 02 - CMA - CDIISU: NEW FOR UMP2 CPHF, SOLVCP: MOD. ITER SCHEME
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C 25 JUN 01 - MWS - ALTER COMMON BLOCK WFNOPT
C 20 FEB 01 - MWS - AO CPHF BY PRECONDITIONED CONJUGATE GRADIENT
C 29 DEC 00 - MWS - STRAIGHTFORWARD PARALLELIZATION OF AO BASIS CPHF
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER
C 11 JUN 00 - MWS - CPRHF: ALWAYS ALLOCATE A HONDO INTEGRAL BUFFER
C  1 MAY 00 - MWS - CPWXYO: FIX SPHERICAL HARMONICS PROBLEM
C 21 DEC 99 - MWS - MAKE GUGWFN COMMON CONSISTENT
C 13 FEB 99 - MAF - CILAI: CORRECT DGEMM CALLS IF SPHERICAL HARMONICS
C  1 DEC 98 - MWS - CHANGES TO DEBUGGING OUTPUT
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C 26 OCT 98 - MAF - CPRHF: ALLOW FOR USE OF SPHERICAL HARMONICS
C  6 JAN 98 - MWS - CHANGE CALL TO RACLOS
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C  2 SEP 97 - MWS - CPRHF: WATCH OUT FOR IN MEMORY OVERFLOW IF 32 BITS
C 24 MAR 97 - MWS - CPDIIS: REDUCE I/O, INCREASE AO CPHF ITERATION LIMIT
C 17 JAN 97 - SPW - ZDENCI: FIX CORE/VALENCE SEMICORE ECP CONTRIBUTION
C 18 DEC 96 - TLW - CPFCK,CPHFX,CPINP,CPRHF: MODIFIED FOR AO BASIS CPHF,
C                   ADD AOCPCL,AOFLM2,AOHST2 ROUTINES, MOVE CPDIIS HERE
C 26 NOV 96 - SPW - CPFA,CPFCK,CPRHF,CPTA,XDELTA,ZDENCI,ZGRDCI: CHANGES
C                   FOR FROZEN CORE CI GRADIENT, ADDED CILAI
C 17 OCT 96 - SPW,MWS - ADD RESPONSE CODE FOR RHF+CI GRADIENT,
C                   INCLUDING NEW XDELTA,ZDENCI,ZGRDCI ROUTINES
C 13 JUN 96 - MWS - SPARAX,SPARXA: REMOVE SOME FTNCHECK WARNINGS.
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C 16 FEB 96 - MWS - IMPROVEMENTS TO IN- AND OUT-OF-CORE SOLVER
C 21 APR 95 - SPW - CPHFX,CPFCK,CPRHF,CPWAB3: POLARIZABILITY, ADD CPINP
C 27 MAR 95 - SPW - CPRHF,CPTA,CPWAB3: IR INTENSITY, ADDED CPSDDM
C 30 DEC 94 - MWS - CPWXYO: ONLY MASTER NODE SHOULD SKIP 1E- INTS
C 15 DEC 94 - MWS - USE GSUMCP TO AVOID LARGE GLOBAL ORB. HESS. SUMS
C 11 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  5 AUG 94 - MWS - CPRHF,CPFCK,CPWXYI,CPWXYO: USE DOUBLE LABEL PACKING
C  1 JUN 94 - MWS - IMPLEMENT PARALLEL FORMATION OF CPHF EQUATIONS
C 28 FEB 94 - MD  - CPFCK: RESHAPE FMO ARRAY
C 27 JAN 94 - MWS - SOLVCG: IMPROVE FAILURE TO CONVERGE MESSAGE
C  2 NOV 93 - HS  - CPRHF: FIX MEMORY GLITCH
C  5 AUG 93 - MWS - CPRHF: PRINT CORRECT OUT OF MEMORY NEED
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C  1 FEB 92 - MWS - MODIFY EXTERNAL CPHF SOLVER TO MINIMIZE I/O
C 11 JAN 92 - TLW - CPWXYI: MAKE READ PARALLEL
C 10 JAN 92 - MWS,TLW - CHANGE OPENCI TO SEQOPN, REWIND WITH SEQREW
C  4 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR
C  7 OCT 91 - MWS - CHANGE UNIX BYTE UNPACKING
C 14 AUG 91 - TLW - CPSYM: ADD FTR AND GTR TO COMMON SYMSPD
C  3 NOV 90 - MWS - SKIP CPHF OVER DUMMY ATOMS
C  7 OCT 90 - MWS - IMPLEMENT OUT OF MEMORY OPTION FOR RHF CPHF
C  7 AUG 90 - TLW - ADD CF AND CG TO COMMON NSHEL
C 22 JUN 90 - MWS - ALLOW OS-TCSCF TO CALL CPROHF CODE
C  3 JUN 90 - JAM - CHANGE VAX BYTE PACKING TO FULL 8 BITS
C  8 MAY 90 - MWS - FLUSH PRINT BUFFER WHEN CPHF EQNS ARE SET UP.
C 27 NOV 89 - MWS - REMOVE STUB ROUTINE, RENAME SOLVER CODE, ALPHABETIZE
C 20 JUN 89 - MWS - ADD DUMMY STUB ROUTINE FOR CP-ROHF PROBLEM
C  1 JUN 89 - MWS - MAKE SEPARATE CPRHF ROUTINE, CPHFX IS BOSS.
C  4 APR 89 - MWS - USE LETTERS IN MEMORY POINTERS
C 13 MAR 89 - MWS - CPFA: TRANSFORM TO MO BASIS IS NOW DONE BY JDDEND
C 25 FEB 89 - STE - CPFCM: DELETE 9996
C 24 JAN 89 - MWS - PRINT OUT MEMORY NEEDS FOR EACH CPHF STEP
C 18 JAN 89 - MWS - ADAPT ANALYTIC RHF HESSIAN CODE FROM MICHEL'S HONDO7
C*MODULE CPHF    *DECK CILAI
      SUBROUTINE CILAI(ZKL,PMN,X,Y,XLMN,BUF,IBUF,XLAI1,
     *                 NOCACT,NFZC,NOC,NVIR,NUM,NUM2,NUM3,C)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL PACK2E
C
      DIMENSION ZKL(NOCACT,NFZC),PMN(NUM2),XLMN(NUM2),
     *          X(NUM,NUM),Y(NUM,NUM),BUF(NINTMX),IBUF(NINTMX),
     *          XLAI1(NOC,NVIR),C(NUM,NUM)
C
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00)
C
C     ----- COMPLETE CONSTRUCTION OF THE CI LAGRANGIAN -----
C
C        BEGIN TRANSFORMING CORE-VALENCE -ZKL- TO AO BASIS AS -PMN-
C
      CALL TRPOSE(XLAI1,X,NOC,NVIR,1)
C
      CALL VCLR(X,1,NUM3)
      CALL VCLR(Y,1,NUM3)
C
C     ---- GET ORBITAL COEFFICIENTS ----
C
      CALL DAREAD(IDAF,IODA,C,NUM3,15,0)
C
C     ---- TRNSFORM FROZEN CORE - VALENCE DENSITY -ZKL- TO AO BASIS ----
C
      CALL MRARTR(ZKL,NOCACT,NOCACT,NFZC,C,NUM,NUM,X,NUM)
      CALL DGEMM('N','N',NUM,NUM,NOCACT,TWO,C(1,NFZC+1),
     *            NUM,X,NUM,ONE,Y,NUM)
C
      MUNU = 0
      DO 110 MU=1,NUM
         DO 100 NU=1,MU
            MUNU=MUNU+1
            PMN(MUNU) = Y(MU,NU) + Y(NU,MU)
  100    CONTINUE
  110 CONTINUE
C
C           CONSTRUCT FOCK-LIKE MATRIX
C           DIRECT METHOD = RECOMPUTE 2E- AO INTEGRALS
C           STANDARD METHOD = PROCESS INTEGRALS FROM DISK
C
      CALL FLMAT(PMN,Y,XLMN,BUF,IBUF,NUM)
C
C     ---- TRANSFORM THIS TERM TO MO BASIS, AND ADD
C          TO OCCUPIED-VIRTUAL CI LAGRANGIAN ASYMMETRY ----
C
      CALL MRARBR(Y,NUM,NUM,NUM,C,NUM,NOC,X,NUM)
      CALL DGEMM('T','N',NVIR,NOC,NUM,ONE,C(1,NOC+1),NUM,X,NUM,
     *           ONE,XLAI1,NVIR)
C
      CALL TRPOSE(XLAI1,X,NVIR,NOC,1)
C
      RETURN
      END
C*MODULE CPHF    *DECK CPDIIS
      SUBROUTINE CPDIIS(IW,ITDIIS,PAI,ERR,WRK,A,X,IPVT,B,IODIIS,
     *                  NOCP,MAXIT,MAXIT2,MAXIO,ERDIIS,NOTOPN,
     *                  NROT,NOC,NVIR,NXYZ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NOTOPN,DBG,GOPARR,DSKWRK,MASWRK,GPSAVE,DSKSAV
C
      DIMENSION PAI(NROT*NXYZ),ERR(NROT*NXYZ),WRK(NROT*NXYZ),
     *          NOCP(NXYZ),IODIIS(MAXIO),A(MAXDII,MAXDII),X(MAXIT,NXYZ),
     *          IPVT(MAXIT),B(MAXIT2,NXYZ)
C
      COMMON /DIISSO/ SOGTOL,ETHRSH,MAXDII,IRAF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      DATA DBUG,DBUGME/8HDEBUG   ,8HCPDIIS  /
C
C                 THIS ROUTINE PERFORMS THE
C        *** DIRECT INVERSION IN THE ITERATIVE SUBSPACE ***
C        INTERPOLATION USING THE CURRENT AND PREVIOUS CPHF
C        SOLUTIONS TO SPEED UP THE CONVERGENCE OF THE SELF
C        CONSISTENT SOLUTION.
C        IT IS A MODIFIED VERSION OF THE SUBROUTINE DIIS.
C
C        THE METHOD IS P.PULAY, J.COMPUT.CHEM., 3, 556-560 (1982).
C        BUT SEE ALSO P.PULAY, CHEM.PHYS.LETT., 73, 393-398 (1980),
C        T.P.HAMILTON, P.PULAY, J.CHEM.PHYS., 84, 5728-5734 (1986).
C
C     ON ENTRY, -PAI- AND AND -ERR- ARE THE CURRENT CPHF
C               AND ERROR MATRICES, EXPRESSED IN THE MO BASIS.
C     ON EXIT, -ERR- IS DESTROYED, -PAI-  WILL CONTAIN
C               THE INTERPOLATED CPHF SOLUTION (IF ITDIIS.GT.2)
C
C     ITDIIS.EQ.1 MEANS DIIS IS NOT YET TURNED ON
C     ITDIIS.EQ.2 MEANS DIIS HAS BEEN INITIATED
C     ITDIIS.GT.2 MEANS A DIIS INTERPOLATION OF ITDIIS-1
C                 FOCK MATRICES HAS BEEN PERFORMED.
C
      DBG = (NPRINT.EQ.5  .OR.  EXETYP.EQ.DBUG  .OR.  EXETYP.EQ.DBUGME)
     *      .AND. MASWRK
C
C     DIIS DATA IS SAVED ON DIRECT FILE -IRAF- IN CYCLIC ORDER,
C                 1,2,3,...,MAXDII = LAST MAXDII ERROR MATRICES
C        MAXDII + 1,2,3,...,MAXDII = LAST MAXDII CPHF SOLUTIONS
C
      LRAFE = 0
      LRAFPAI= MAXDII
      DSKSAV = DSKWRK
      DSKWRK = .FALSE.
C
      IF(NOTOPN) THEN
         NOTOPN = .FALSE.
         IRAF   = 20
         NDAF20 = MAXIO
         LEN20  = NROT*NXYZ
         CALL RAOPEN(IRAF,IODIIS,0,NDAF20,LEN20,-5)
      END IF
C
C     ----- SAVE THE CURRENT CPHF SOLUTION -----
C
      LPAI = LRAFPAI + MOD(ITDIIS-1,MAXDII) + 1
      CALL RAWRIT(IRAF,IODIIS,PAI,NROT*NXYZ,LPAI,0)
C
C     ----- SAVE THE CURRENT ERROR MATRIX -----
C
      LERR = LRAFE + MOD(ITDIIS-1,MAXDII) + 1
      CALL RAWRIT(IRAF,IODIIS,ERR,NROT*NXYZ,LERR,0)
C
C     ----- START DIIS PROCEDURE IF ERDIIS < ETHRSH -----
C
      ETHRSH = 5.0D-02
      IF(NXYZ.GT.1) ETHRSH = 3.0D-01
      LOC=0
      ERDIIS=ZERO
      DO 110 IXYZ=1,NXYZ
         IF(NOCP(IXYZ).EQ.0) THEN
            IMAX = IDAMAX(NROT,ERR(LOC+1),1)
            EMAX = ABS(ERR(LOC+IMAX))
            IF(EMAX.GT.ERDIIS) ERDIIS=EMAX
         END IF
         LOC = LOC+NROT
  110 CONTINUE
      IF(ERDIIS.GT.ETHRSH  .AND.  ITDIIS.EQ.1) THEN
         DSKWRK = DSKSAV
         RETURN
      END IF
      ITDIIS = ITDIIS+1
      IF (MASWRK  .AND.  ITDIIS.EQ.2) WRITE(IW,900)
C
C        WHEN RUNNING IN PARALLEL, THE O(N**2) COMMUNICATIONS
C        COSTS IN -RAREAD- BELOW ARE THE SAME MAGNITUDE AS
C        THE COMPUTATION IN -TRAREC- AND -DAXPY-.
C        IT SEEMS WISEST JUST TO LET THE MASTER DO THIS I/O,
C        THEN BROADCAST THE INTERPOLATION RESULTS AT THE END.
C
      GPSAVE = GOPARR
      GOPARR = .FALSE.
C
C         LOOP OVER THE -NXYZ- RESPONSES
C
      DO 200 IXYZ = 1, NXYZ
         IF (NOCP(IXYZ).NE.0) GO TO 200
         ITEMP = (IXYZ-1)*NROT
C
C         FORM LAST ROW (ROW ITDIIS) OF TRIANGULAR MATRIX B,
C         FIRST DOING THE DIAGONAL AND THE FIRST ELEMENT OF THE ROW.
C
         BJJ=DDOT(NROT,ERR(ITEMP+1),1,ERR(ITEMP+1),1)
C
         IF(ITDIIS.EQ.2) THEN
            CALL VCLR(B(1,IXYZ),1,MAXIT2)
            B(1,IXYZ)=ZERO
            B(2,IXYZ)=-ONE
            B(3,IXYZ)=BJJ
            IF (IXYZ.EQ.NXYZ) THEN
              GOPARR = GPSAVE
              DSKWRK = DSKSAV
              RETURN
            ELSE
              GO TO 200
            END IF
         ELSE
            J1   = (ITDIIS*ITDIIS-ITDIIS)/2 + 1
            JJ   = (ITDIIS*ITDIIS+ITDIIS)/2
            B(J1,IXYZ)= -ONE
            B(JJ,IXYZ)= BJJ
         END IF
  200 CONTINUE
C
C        THE REST OF THE BIJ'S.
C        NOTE THAT WE ONLY COMPUTE THE NA-2 VALUES NEXT TO THE
C        DIAGONAL, SO THAT THE OTHER ELEMENTS (EXCEPT THE FIRST
C        COLUMN) ARE RANDOM VALUES.
C
      NA=MIN(ITDIIS,MAXDII)
      NAM1=NA-1
      IJ=JJ-NA+1
      DO 320 IX=2,NAM1
         IJ=IJ+1
         LERR = LRAFE + MOD(ITDIIS-NA+IX-2,MAXDII) + 1
         CALL RAREAD(IRAF,IODIIS,WRK,NROT*NXYZ,LERR,0)
         DO 310 IXYZ = 1, NXYZ
            IF (NOCP(IXYZ).NE.0) GO TO 310
            ITEMP = (IXYZ-1)*NROT
            BIJ=DDOT(NROT,ERR(ITEMP+1),1,WRK(ITEMP+1),1)
            B(IJ,IXYZ)=BIJ
  310    CONTINUE
  320 CONTINUE
C
      DO 330 IXYZ=1,NXYZ
         IF(NOCP(IXYZ).NE.0) GO TO 330
         IF(DBG) THEN
            WRITE(IW,*) 'DIIS EQUATIONS - ROTATION',IXYZ
            CALL PRTRI(B(1,IXYZ),ITDIIS)
         END IF
C
C     ----- SET UP AND SOLVE THE SET OF DIIS LINEAR EQUATIONS -----
C
  325    CONTINUE
         CALL DIISEQ(A,NA,B(1,IXYZ),JJ,ITDIIS)
         CALL VCLR(X(1,IXYZ),1,NA)
         X(1,IXYZ)=-ONE
         IERR=0
         CALL SLVLEQ(A,X(1,IXYZ),IPVT,NA,NA,0,IERR)
         IF(IERR.NE.0) THEN
           NA = NA - 1
           IF (MASWRK) WRITE(IW,*)
     *         'TRUNCATING RHF MP2 RESPONSE VECTOR DIIS EQUATIONS'
           IF (NA .NE. 1) GO TO 325
           IF (MASWRK) WRITE(IW,*)
     *         'ERROR: RESPONSE VECTOR DIIS EQUATIONS ARE SINGULAR'
           CALL ABRT
           STOP
         END IF
         IF(DBG) THEN
            WRITE(IW,*) 'DIIS INTERPOLATION COEFFICIENTS'
            WRITE(IW,910) (X(I,IXYZ),I=1,NA)
         END IF
  330 CONTINUE
C
C     ----- FORM THE INTERPOLATED CPHF SOLUTION -----
C     THE INTERPOLATION IS SUMMATION C(I)*PAI(I)
C
      CALL VCLR(PAI,1,NROT*NXYZ)
      DO 420 IX=2,NA
         LPAI = LRAFPAI  + MOD(ITDIIS-NA+IX-2,MAXDII) + 1
         CALL RAREAD(IRAF,IODIIS,WRK,NROT*NXYZ,LPAI,0)
         DO 410 IXYZ = 1, NXYZ
            IF (NOCP(IXYZ).NE.0) GO TO 410
            ITEMP = (IXYZ-1)*NROT
            CI = X(IX,IXYZ)
            CALL DAXPY(NROT,CI,WRK(ITEMP+1),1,PAI(ITEMP+1),1)
  410    CONTINUE
  420 CONTINUE
C
      IF(DBG) THEN
         DO 430 IXYZ = 1, NXYZ
            IF (NOCP(IXYZ).NE.0) GO TO 430
            ITEMP = (IXYZ-1)*NROT
            WRITE(IW,*) 'DIIS INTERPOLATED CPHF SOLUTION IS'
            CALL PRSQ(PAI(ITEMP+1),NOC,NVIR,NVIR)
  430    CONTINUE
      END IF
C
      GOPARR=GPSAVE
      DSKWRK = DSKSAV
      IF(GOPARR) THEN
         CALL DDI_BCAST(1005,'F',PAI,NXYZ*NROT,MASTER)
      END IF
      RETURN
C
  900 FORMAT(' ..... INITIATING DIIS PROCEDURE .....')
  910 FORMAT(1X,5F13.8)
      END
C*MODULE CPHF    *DECK CDIISU
      SUBROUTINE CDIISU(IW,ITDIIS,PAI1,PAI2,ERR,WRK,A,X,IPVT,B,IODIIS,
     *                  NOCP,MAXIT,MAXIT2,MAXIO,ERDIIS,NOTOPN,
     *                  NBF,NBF3,NXYZ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL NOTOPN,DBG,GOPARR,DSKWRK,MASWRK,GPSAVE,DSKSAV
C
      DIMENSION PAI1(NBF3*NXYZ),ERR(NBF3*NXYZ),WRK(NBF3*NXYZ),
     *          PAI2(NBF3*NXYZ),
     *          NOCP(NXYZ),IODIIS(MAXIO),A(MAXIT,MAXIT),X(MAXIT,NXYZ),
     *          IPVT(MAXIT),B(MAXIT2,NXYZ)
C
      COMMON /DIISSO/ SOGTOL,ETHRSH,MAXDII,IRAF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      DATA DBUG,DBUGME/8HDEBUG   ,8HCDIISU  /
C
C                 THIS ROUTINE PERFORMS THE
C        *** DIRECT INVERSION IN THE ITERATIVE SUBSPACE ***
C        INTERPOLATION USING THE CURRENT AND PREVIOUS CPHF
C        SOLUTIONS TO SPEED UP THE CONVERGENCE OF THE SELF
C        CONSISTENT SOLUTION.
C        IT IS A MODIFIED VERSION OF THE SUBROUTINE DIIS.
C
C        THE METHOD IS P.PULAY, J.COMPUT.CHEM., 3, 556-560 (1982).
C        BUT SEE ALSO P.PULAY, CHEM.PHYS.LETT., 73, 393-398 (1980),
C        T.P.HAMILTON, P.PULAY, J.CHEM.PHYS., 84, 5728-5734 (1986).
C
C     ON ENTRY, -PAI- AND AND -ERR- ARE THE CURRENT CPHF
C               AND ERROR MATRICES, EXPRESSED IN THE MO BASIS.
C     ON EXIT, -ERR- IS DESTROYED, -PAI-  WILL CONTAIN
C               THE INTERPOLATED CPHF SOLUTION (IF ITDIIS.GT.2)
C
C     ITDIIS.EQ.1 MEANS DIIS IS NOT YET TURNED ON
C     ITDIIS.EQ.2 MEANS DIIS HAS BEEN INITIATED
C     ITDIIS.GT.2 MEANS A DIIS INTERPOLATION OF ITDIIS-1
C                 FOCK MATRICES HAS BEEN PERFORMED.
C
      DBG = (NPRINT.EQ.5  .OR.  EXETYP.EQ.DBUG  .OR.  EXETYP.EQ.DBUGME)
     *      .AND. MASWRK
C
C     DIIS DATA IS SAVED ON DIRECT FILE -IRAF- IN CYCLIC ORDER,
C                 1,2,3,...,MAXDII = LAST MAXDII ERROR MATRICES
C        MAXDII + 1,2,3,...,MAXDII = LAST MAXDII CPHFA SOLUTIONS
C      2*MAXDII + 1,2,3,...,MAXDII = LAST MAXDII CPHFB SOLUTIONS
C
      LRAFE = 0
      LRAFPAI1= MAXDII
      LRAFPAI2= 2*MAXDII
      DSKSAV = DSKWRK
      DSKWRK = .FALSE.
C
      IF(NOTOPN) THEN
         NOTOPN = .FALSE.
         IRAF   = 20
         NDAF20 = MAXIO
         LEN20  = NBF3*NXYZ
         CALL RAOPEN(IRAF,IODIIS,0,NDAF20,LEN20,-5)
      END IF
C
C     ----- SAVE THE CURRENT CPHF SOLUTIONS -----
C
      LPAI1 = LRAFPAI1 + MOD(ITDIIS-1,MAXDII) + 1
      CALL RAWRIT(IRAF,IODIIS,PAI1,NBF3*NXYZ,LPAI1,0)
      LPAI2 = LRAFPAI2 + MOD(ITDIIS-1,MAXDII) + 1
      CALL RAWRIT(IRAF,IODIIS,PAI2,NBF3*NXYZ,LPAI2,0)
C
C     ----- SAVE THE CURRENT ERROR MATRIX -----
C
      LERR = LRAFE + MOD(ITDIIS-1,MAXDII) + 1
      CALL RAWRIT(IRAF,IODIIS,ERR,NBF3*NXYZ,LERR,0)
C
C     ----- START DIIS PROCEDURE IF ERDIIS < ETHRSH -----
C
      ETHRSH = 5.0D-02
      IF(NXYZ.GT.1) ETHRSH = 3.0D-01
      LOC=0
      ERDIIS=ZERO
      DO 110 IXYZ=1,NXYZ
         IF(NOCP(IXYZ).EQ.0) THEN
            IMAX = IDAMAX(NBF3,ERR(LOC+1),1)
            EMAX = ABS(ERR(LOC+IMAX))
            IF(EMAX.GT.ERDIIS) ERDIIS=EMAX
         END IF
         LOC = LOC+NBF3
  110 CONTINUE
      IF(ERDIIS.GT.ETHRSH  .AND.  ITDIIS.EQ.1) THEN
         DSKWRK = DSKSAV
         RETURN
      END IF
      ITDIIS = ITDIIS+1
C
      IF (MASWRK  .AND.  ITDIIS.EQ.2) WRITE(IW,900)
C
C        WHEN RUNNING IN PARALLEL, THE O(N**2) COMMUNICATIONS
C        COSTS IN -RAREAD- BELOW ARE THE SAME MAGNITUDE AS
C        THE COMPUTATION IN -TRAREC- AND -DAXPY-.
C        IT SEEMS WISEST JUST TO LET THE MASTER DO THIS I/O,
C        THEN BROADCAST THE INTERPOLATION RESULTS AT THE END.
C
      GPSAVE = GOPARR
      GOPARR = .FALSE.
C
C         LOOP OVER THE -NXYZ- RESPONSES
C
      DO 200 IXYZ = 1, NXYZ
         IF (NOCP(IXYZ).NE.0) GO TO 200
         ITEMP = (IXYZ-1)*NBF3
C
C         FORM LAST ROW (ROW ITDIIS) OF TRIANGULAR MATRIX B,
C         FIRST DOING THE DIAGONAL AND THE FIRST ELEMENT OF THE ROW.
C
         BJJ=DDOT(NBF3,ERR(ITEMP+1),1,ERR(ITEMP+1),1)
C
         IF(ITDIIS.EQ.2) THEN
            CALL VCLR(B(1,IXYZ),1,MAXIT2)
            B(1,IXYZ)=ZERO
            B(2,IXYZ)=-ONE
            B(3,IXYZ)=BJJ
            IF (IXYZ.EQ.NXYZ) THEN
              GOPARR = GPSAVE
              DSKWRK = DSKSAV
              RETURN
            ELSE
              GO TO 200
            END IF
         ELSE
            J1   = (ITDIIS*ITDIIS-ITDIIS)/2 + 1
            JJ   = (ITDIIS*ITDIIS+ITDIIS)/2
            B(J1,IXYZ)= -ONE
            B(JJ,IXYZ)= BJJ
         END IF
  200 CONTINUE
C
C        THE REST OF THE BIJ'S.
C        NOTE THAT WE ONLY COMPUTE THE NA-2 VALUES NEXT TO THE
C        DIAGONAL, SO THAT THE OTHER ELEMENTS (EXCEPT THE FIRST
C        COLUMN) ARE RANDOM VALUES.
C
      NA=MIN(ITDIIS,MAXDII)
      NAM1=NA-1
      IJ=JJ-NA+1
      DO 320 IX=2,NAM1
         IJ=IJ+1
         LERR = LRAFE + MOD(ITDIIS-NA+IX-2,MAXDII) + 1
         CALL RAREAD(IRAF,IODIIS,WRK,NBF3*NXYZ,LERR,0)
         DO 310 IXYZ = 1, NXYZ
            IF (NOCP(IXYZ).NE.0) GO TO 310
            ITEMP = (IXYZ-1)*NBF3
            BIJ=DDOT(NBF3,ERR(ITEMP+1),1,WRK(ITEMP+1),1)
            B(IJ,IXYZ)=BIJ
  310    CONTINUE
  320 CONTINUE
C
      DO 330 IXYZ=1,NXYZ
         IF(NOCP(IXYZ).NE.0) GO TO 330
         IF(DBG) THEN
            WRITE(IW,*) 'DIIS EQUATIONS - ROTATION',IXYZ
            CALL PRTRI(B(1,IXYZ),ITDIIS)
         END IF
C
C     ----- SET UP AND SOLVE THE SET OF DIIS LINEAR EQUATIONS -----
C
  325    CONTINUE
         CALL DIISEQ(A,NA,B(1,IXYZ),JJ,ITDIIS)
         CALL VCLR(X(1,IXYZ),1,NA)
         X(1,IXYZ)=-ONE
         IERR=0
         CALL SLVLEQ(A,X(1,IXYZ),IPVT,NA,NA,0,IERR)
         IF(IERR.NE.0) THEN
           NA = NA - 1
           IF (MASWRK) WRITE(IW,*)
     *         'TRUNCATING UHF MP2 RESPONSE VECTOR DIIS EQUATIONS'
           IF (NA .NE. 1) GO TO 325
           IF (MASWRK) WRITE(IW,*)
     *         'ERROR: RESPONSE VECTOR DIIS EQUATIONS ARE SINGULAR'
           CALL ABRT
           STOP
         END IF
         IF(DBG) THEN
            WRITE(IW,*) 'DIIS INTERPOLATION COEFFICIENTS'
            WRITE(IW,910) (X(I,IXYZ),I=1,NA)
         END IF
  330 CONTINUE
C
C     ----- FORM THE INTERPOLATED CPHF SOLUTION -----
C     THE INTERPOLATION IS SUMMATION C(I)*PAI(I)
C
      CALL VCLR(PAI1,1,NBF3*NXYZ)
      DO 420 IX=2,NA
         LPAI1 = LRAFPAI1 + MOD(ITDIIS-NA+IX-2,MAXDII) + 1
         CALL RAREAD(IRAF,IODIIS,WRK,NBF3*NXYZ,LPAI1,0)
         DO 410 IXYZ = 1, NXYZ
            IF (NOCP(IXYZ).NE.0) GO TO 410
            ITEMP = (IXYZ-1)*NBF3
            CI = X(IX,IXYZ)
            CALL DAXPY(NBF3,CI,WRK(ITEMP+1),1,PAI1(ITEMP+1),1)
  410    CONTINUE
  420 CONTINUE
C
      CALL VCLR(PAI2,1,NBF3*NXYZ)
      DO 426 IX=2,NA
         LPAI2 = LRAFPAI2 + MOD(ITDIIS-NA+IX-2,MAXDII) + 1
         CALL RAREAD(IRAF,IODIIS,WRK,NBF3*NXYZ,LPAI2,0)
         DO 424 IXYZ = 1, NXYZ
            IF (NOCP(IXYZ).NE.0) GO TO 426
            ITEMP = (IXYZ-1)*NBF3
            CI = X(IX,IXYZ)
            CALL DAXPY(NBF3,CI,WRK(ITEMP+1),1,PAI2(ITEMP+1),1)
  424    CONTINUE
  426 CONTINUE
C
      IF(DBG) THEN
         DO 430 IXYZ = 1, NXYZ
            IF (NOCP(IXYZ).NE.0) GO TO 430
            ITEMP = (IXYZ-1)*NBF3
            WRITE(IW,*) 'DIIS INTERPOLATED ALPHA CPHF SOLUTION IS'
            CALL PRSQ(PAI1(ITEMP+1),NBF,NBF,NBF)
            ITEMP = (IXYZ-1)*NBF3
            WRITE(IW,*) 'DIIS INTERPOLATED BETA CPHF SOLUTION IS'
            CALL PRSQ(PAI2(ITEMP+1),NBF,NBF,NBF)
  430    CONTINUE
      END IF
C
      GOPARR=GPSAVE
      DSKWRK = DSKSAV
      IF(GOPARR) THEN
         CALL DDI_BCAST(1005,'F',PAI1,NXYZ*NBF3,MASTER)
         CALL DDI_BCAST(1005,'F',PAI2,NXYZ*NBF3,MASTER)
      END IF
      RETURN
C
  900 FORMAT(' ..... INITIATING DIIS PROCEDURE .....')
  910 FORMAT(1X,5F13.8)
      END
C
C*MODULE CPHF    *DECK CPFA
      SUBROUTINE CPFA(DBG,WAX,AA,DFMO,WAXC,IA,NUM,
     *                NOCC,NVIR,NUM2,NOCC2,NXYZ,NFT18,NFZC,NOCACT,NDER)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION WAX(NOCC,NVIR,NXYZ),AA(NOCC2,NXYZ),DFMO(NUM2),IA(NUM)
      DIMENSION WAXC(NFZC,NOCACT,NXYZ)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK,SVDSKW
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (FOUR=4.0D+00)
C
C     ----- INITIALIZE -WAX- AND -AA- WITH DF/DA TERMS -----
C
      CALL VCLR(WAX,1,NOCC*NVIR*NXYZ)
      CALL VCLR(WAXC,1,NFZC*NOCACT*NXYZ)
      CALL VCLR(AA,1,NOCC2*NXYZ)
C
C        ONLY THE MASTER NODE HAS THE DERIVATIVE FOCK MATRIX DISK FILE
C
      SVDSKW = DSKWRK
      DSKWRK = .FALSE.
      CALL SEQREW(NFT18)
C
      DO 300 IXYZ=1,NXYZ
         CALL SQREAD(NFT18,DFMO,NUM2)
         IF(DBG) THEN
            WRITE(IW,*) 'FCKDER',IXYZ
            CALL PRTRI(DFMO,NUM)
         END IF
C
         DO 120 IVIR=1,NVIR
            DO 110 IOCC=1,NOCC
               IJ=IA(IVIR+NOCC)+IOCC
               WAX(IOCC,IVIR,IXYZ)=FOUR*DFMO(IJ)
  110       CONTINUE
  120    CONTINUE
C
         IF (NDER.EQ.1 .AND. NFZC.GT.0) THEN
            DO 150 IACT=1,NOCACT
               DO 140 IFZC=1,NFZC
                  IJ=IA(IACT+NFZC)+IFZC
                  WAXC(IFZC,IACT,IXYZ)=FOUR*DFMO(IJ)
  140          CONTINUE
  150       CONTINUE
         END IF
C
         DO 220 IOCC=1,NOCC
            DO 210 JOCC=1,IOCC
               IJ=IA(IOCC)+JOCC
               AA(IJ,IXYZ) = FOUR*DFMO(IJ)
  210       CONTINUE
  220    CONTINUE
  300 CONTINUE
C
      CALL SEQREW(NFT18)
      DSKWRK = SVDSKW
      RETURN
      END
C*MODULE CPHF    *DECK CPFCK
      SUBROUTINE CPFCK(WAX,AA,TA,FMO,DTEMP,FTEMP,C,Y,X,WORK,
     *                 HF,WAXC,XX,IX,GHONDO,XINTS,DSH,DDIJ,IA,
     *                 NOCC,NVIR,NORB,NOCC2,NORB2,NXYZ,NNXYZ,NFTI,
     *                 NINTMX,NUM,NUM2,NFZC,NOCACT,NDER,MAXG,NSH2,MXG2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,POLAR,AODRV
C
C        -FMO- IS USED ONLY FOR COMPUTING RESPONSES FROM MO INTEGRALS.
C        -DTEMP-, -FTEMP-, -C-, -Y-, -X-, -WORK- ARE USED ONLY FOR
C           CALCULATION OF RESPONSES FROM AO BASIS INTEGRALS.
C        -HF- IS USED FOR OPTIONAL POLARIZABILITY COMPUTATION.
C        -WAXC- IS USED ONLY DURING CI GRADIENT RUNS.
C
      DIMENSION WAX(NOCC,NVIR,NNXYZ),AA(NOCC2,NXYZ),TA(NOCC2,NXYZ),
     *          FMO(NXYZ,NORB2),DTEMP(NXYZ,NUM2),FTEMP(NXYZ,NUM2),
     *          C(NUM,NUM),Y(NUM,NUM),X(NUM,NUM),WORK(*),
     *          HF(NUM2,3),WAXC(NFZC,NOCACT,NNXYZ),XX(NINTMX),IX(*),
     *          GHONDO(MAXG),XINTS(NSH2),DSH(NSH2),DDIJ(49*MXG2),IA(NUM)
C
      COMMON /CHFINF/ CHFSLV,CPTYPE,NWDCHF,POLAR
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (PT5=0.5D+00, FOUR=4.0D+00)
C
      DATA TYPEAO/8HAO      /
C
C     ----- FORM THE INTEGRAL CONTRIBUTIONS TO -AA- AND -WAX- -----
C
      AODRV = CPTYPE.EQ.TYPEAO
      IF(AODRV) THEN
C
C          EITHER WE ARE WORKING WITH INTEGRALS IN THE AO BASIS...
C
C     TRANSFORM THE TAS INTO THE AO BASIS,
C     THESE "DENSITY MATRICES" ARE STORED IN -DTEMP-
C
         DO 290 IXYZ=1,NXYZ
            CALL EXPND(TA(1,IXYZ),WORK,NOCC,0)
            CALL MRARTR(WORK,NOCC,NOCC,NOCC,C,NUM,NUM,X,NUM)
            CALL MRARBR(C,NUM,NUM,NOCC,X,NUM,NUM,Y,NUM)
C
            IJ = 0
            DO 260 I=1,NUM
               DO 250 J=1,I
                  IJ = IJ + 1
                  DTEMP(IXYZ,IJ) = Y(I,J) + Y(J,I)
  250          CONTINUE
  260       CONTINUE
  290    CONTINUE
C
C     NOW BUILD THE "FOCK-LIKE MATRICES" IN -FTEMP-
C
         CALL AOFLM2(DTEMP,FTEMP,GHONDO,XINTS,DSH,DDIJ,XX,IX,
     *               NUM,NXYZ,MAXG,NSH2,MXG2,NINT,NSCHWZ)
C
C     TRANSFORM THE RESULTS TO THE MO BASIS
C
         DO 390 IXYZ = 1,NXYZ
            DO 310 IDUM=1,NUM2
               WORK(IDUM) = FTEMP(IXYZ,IDUM)
  310       CONTINUE
            CALL EXPND(WORK,Y,NUM,0)
            CALL MRARBR(Y,NUM,NUM,NUM,C,NUM,NOCC,X,NUM)
            CALL MRTRBT(C,NUM,NUM,NOCC,X,NUM,WORK,1,1)
C
C     FORM THE AIJ^A CONTRIBUTION OF EQUATION 13.
C     NOTE THAT THE FACTOR OF 4 IS THE 2 FROM EQUATION 13 AND
C     ANOTHER TWO TAKING INTO ACCOUNT THE SYMMETRY OF THE TRANSFORMATION
C     (HAVE TWO TERMS THAT ARE SYMMETRIC, I CALCULATED ONE
C      AND NEED TO MULTIPLY BY TWO WHICH I AM DOING HERE)
C
            DO 330 IJ=1,NOCC2
               AA(IJ,IXYZ) = AA(IJ,IXYZ) + 4.0D+00*WORK(IJ)
  330      CONTINUE
C
C     DO LAST PART OF SECOND TRANSFORMATION INTO THE MO BASIS
C     (FIRST PART IS THE SAME AS THE PREVIOUS TRANSFORMATION)
C     THIS IS FOR EQUATION 14 TO FORM WAX
C
           CALL MRTRBR(C(1,NOCC+1),NUM,NUM,NVIR,X,NUM,NOCC,WORK,NVIR)
C
C     NOW FORM WAX
C     NOTE THAT THE FACTOR OF 8 IS THE 4 FROM EQUATION 14 AND
C     ANOTHER TWO TAKING INTO ACCOUNT THE SYMMETRY OF THE TRANSFORMATION
C     (HAVE TWO TERMS THAT ARE SYMMETRIC, I CALCULATED ONE
C      AND NEED TO MULTIPLY BY TWO WHICH I AM DOING HERE)
C
         I = 1
         DO 360 IOCC=1,NOCC
            DO 350 IVIR=1,NVIR
                  WAX(IOCC,IVIR,IXYZ) = WAX(IOCC,IVIR,IXYZ) +
     *                                  8.0D+00*WORK(I)
                  I = I + 1
  350          CONTINUE
  360       CONTINUE
  390    CONTINUE
C
C          ...OR WE ARE WORKING WITH INTEGRALS TRANSFORMED TO MO BASIS.
C
      ELSE
         CALL VCLR(FMO,1,NXYZ*NORB2)
C
C     ----- READ IN MO INTEGRALS -----
C     TRANSFORMED INTEGRALS ASSUMED IN REVERSE CANONICAL ORDER
C
         CALL SEQREW(NFTI)
         IF (MASWRK) READ(NFTI)
  500    CONTINUE
         CALL PREAD(NFTI,XX,IX,NX,NINTMX)
         IF(NX.EQ.0) GO TO 710
         MX=ABS(NX)
         IF(MX.GT.NINTMX) GO TO 9000
C
C     ----- UNPACK LABEL AND PROCESS INTEGRAL -----
C
         DO 700 M=1,MX
         VAL   = XX(M)
C
                       NPACK = M
                       IF (LABSIZ .EQ. 2) THEN
*I32                     LABEL1 = IX( 2*NPACK - 1 )
*I32                     LABEL2 = IX( 2*NPACK     )
*I32                     IPACK = ISHFT( LABEL1, -16 )
*I32                     JPACK = IAND( LABEL1, 65535 )
*I32                     KPACK = ISHFT( LABEL2, -16 )
*I32                     LPACK = IAND( LABEL2, 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
                       K = IPACK
                       L = JPACK
                       I = KPACK
                       J = LPACK
C
C
C     ----- -AA- TERMS -----
C
         IF(I.GT.NOCC) GO TO 600
         IF(J.EQ.I           ) VAL=VAL*PT5
         IF(L.EQ.K           ) VAL=VAL*PT5
         IF(K.EQ.I.AND.L.EQ.J) VAL=VAL*PT5
         VALJ=(VAL +VAL )
         VALJ=(VALJ+VALJ)
         VALK=-VAL
         NIJ=IA(I)+J
         NKL=IA(K)+L
         NIK=IA(I)+K
         NIL=IA(I)+L
         NJK=IA(MAX(J,K))+MIN(J,K)
         NJL=IA(MAX(J,L))+MIN(J,L)
C
         DO 550 IXYZ=1,NXYZ
            FMO(IXYZ,NIJ)=FMO(IXYZ,NIJ)+VALJ*TA(NKL,IXYZ)
            FMO(IXYZ,NKL)=FMO(IXYZ,NKL)+VALJ*TA(NIJ,IXYZ)
            FMO(IXYZ,NIK)=FMO(IXYZ,NIK)+VALK*TA(NJL,IXYZ)
            FMO(IXYZ,NIL)=FMO(IXYZ,NIL)+VALK*TA(NJK,IXYZ)
            FMO(IXYZ,NJK)=FMO(IXYZ,NJK)+VALK*TA(NIL,IXYZ)
            FMO(IXYZ,NJL)=FMO(IXYZ,NJL)+VALK*TA(NIK,IXYZ)
  550    CONTINUE
         GO TO 700
C
C     ----- -WAX- TERMS -----
C
  600    CONTINUE
         IF(J.GT.NOCC.OR.K.GT.NOCC) GO TO 700
         IF(L.EQ.K) VAL=VAL*PT5
         VALJ=(VAL +VAL )
         VALJ=(VALJ+VALJ)
         VALK=-VAL
         NIJ=IA(I)+J
         NKL=IA(K)+L
         NIK=IA(I)+K
         NIL=IA(I)+L
         NJK=IA(MAX(J,K))+MIN(J,K)
         NJL=IA(MAX(J,L))+MIN(J,L)
C
         DO 690 IXYZ=1,NXYZ
            FMO(IXYZ,NIJ)=FMO(IXYZ,NIJ)+VALJ*TA(NKL,IXYZ)
            FMO(IXYZ,NIK)=FMO(IXYZ,NIK)+VALK*TA(NJL,IXYZ)
            FMO(IXYZ,NIL)=FMO(IXYZ,NIL)+VALK*TA(NJK,IXYZ)
  690    CONTINUE
C
  700    CONTINUE
         IF(NX.GT.0) GO TO 500
C
C          DONE WITH INTEGRAL CONTRIBUTIONS TO -FMO-
C
  710    CONTINUE
         IF(GOPARR) CALL DDI_GSUMF(2101,FMO,NORB2*NXYZ)
C
         CALL DSCAL(NORB2*NXYZ,PT5,FMO,1)
         DO 750 IXYZ=1,NXYZ
            MM=0
            DO 740 M=1,NORB
               MM = MM+M
               FMO(IXYZ,MM)=FMO(IXYZ,MM)+FMO(IXYZ,MM)
  740       CONTINUE
  750    CONTINUE
C
C     ----- -FMO- CONTRIBUTION TO -AA- -----
C
         DO 810 IXYZ=1,NXYZ
         DO 810 IOCC=1,NOCC
         DO 810 JOCC=1,IOCC
         IJ=IA(IOCC)+JOCC
  810    AA(IJ,IXYZ)        =AA(IJ,IXYZ)
     *                      +(FOUR+FOUR)*FMO(IXYZ,IJ)
C
C     ----- -FMO- CONTRIBUTION TO -WAX- -----
C
         DO 830 IXYZ=1,NXYZ
         DO 830 IVIR=1,NVIR
         DO 830 IOCC=1,NOCC
         IJ=IA(IVIR+NOCC)+IOCC
  830    WAX(IOCC,IVIR,IXYZ)=WAX(IOCC,IVIR,IXYZ)
     *                      +(FOUR*FOUR)*FMO(IXYZ,IJ)
C
C     ----- -FMO- CONTRIBUTION TO -WAXC- -----
C
         IF (NDER.EQ.1 .AND. NFZC.GT.0) THEN
            DO 850 IXYZ=1,NXYZ
            DO 850 IACT=1,NOCACT
            DO 850 IFZC=1,NFZC
            IJ=IA(IACT+NFZC)+IFZC
  850       WAXC(IFZC,IACT,IXYZ)=WAXC(IFZC,IACT,IXYZ)
     *                          +(FOUR*FOUR)*FMO(IXYZ,IJ)
         END IF
C
C            END OF SECTION PROCESSING MO INTEGRALS
C
      END IF
C
C     ---- IF POLARIZABILITY GET TRANSFORMED DIPOLE INTEGRALS ----
C                      ---- ADD TO -WAX- ----
C     ---- NOTE THAT MULTIPLICATION BY FOUR NEEDED TO RECONCILE ----
C     ---- SCHAEFER'S AND KOMORNIKI'S FORMULATIONS              ----
C
      IF(POLAR) THEN
         CALL DAREAD(IDAF,IODA,HF(1,1),NUM2,252,0)
         CALL DAREAD(IDAF,IODA,HF(1,2),NUM2,253,0)
         CALL DAREAD(IDAF,IODA,HF(1,3),NUM2,254,0)
C
         DO 950 IVIR=1,NVIR
            DO 960 IOCC=1,NOCC
               IJ=IA(IVIR+NOCC)+IOCC
               WAX(IOCC,IVIR,NXYZ+1)=FOUR*HF(IJ,1)
               WAX(IOCC,IVIR,NXYZ+2)=FOUR*HF(IJ,2)
               WAX(IOCC,IVIR,NXYZ+3)=FOUR*HF(IJ,3)
  960       CONTINUE
  950    CONTINUE
      END IF
C
      RETURN
C
 9000 IF (MASWRK) WRITE(IW,9999) MX,NINTMX
      CALL ABRT
      STOP
C
 9999 FORMAT(' ERROR STOP IN -CPFCK-',/,
     1       ' MX IS LARGER THAN NINTMX. MX =',I10,' NINTMX =',I10)
      END
C*MODULE CPHF    *DECK CPFCM
      SUBROUTINE CPFCM(FCM,NAT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION DNAM(3),FC(9),FCM(*)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA DNAM /8HD/DX    ,8HD/DY    ,8HD/DZ    /
C
      NC=3*NAT
C
C     ----- PRINT FORCE CONSTANT MATRIX -----
C
      IF (MASWRK) WRITE(IW,9998)
      MAX=0
   50 MIN=MAX+1
      MAX=MAX+3
      IF(MAX.GT.NAT) MAX=NAT
      IF (MASWRK) THEN
         WRITE(IW,9997)
         WRITE(IW,9994) (J,J=MIN,MAX)
         WRITE(IW,9997)
         WRITE(IW,9993) ((DNAM(I),I=1,3),J=MIN,MAX)
         WRITE(IW,9997)
      END IF
      JMIN=3*(MIN-1)+1
      JMAX=3* MAX
      I=0
      DO 80 IAT=1,NAT
         DO 70 N=1,3
            I=I+1
            DO 60 J=JMIN,JMAX
               IJ=NC*(J-1)+I
               FC(J-JMIN+1)=FCM(IJ)
   60       CONTINUE
            KMAX=JMAX-JMIN+1
            IF (MASWRK) WRITE(IW,9995) DNAM(N),(FC(J),J=1,KMAX)
   70    CONTINUE
   80 CONTINUE
      IF(MAX.LT.NAT) GO TO 50
      IF (MASWRK) WRITE(IW,9997)
      RETURN
C
 9998 FORMAT(/1X,' --- HESSIAN --- ')
 9997 FORMAT(1X)
 9995 FORMAT(5X,A4,9F12.7)
 9994 FORMAT(5X,'ATOM',3(19X,I2,15X))
 9993 FORMAT(5X,'    ',9(6X,A4,2X))
      END
C*MODULE CPHF    *DECK CPHFX
      SUBROUTINE CPHFX
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL PPGVB,TCSCF,ROGVB,SOME,DBG,GOPARR,DSKWRK,MASWRK,POLAR
C
      PARAMETER (MXSH=5000, MXATM=2000, MXAO=8192)
C
      DIMENSION NOCP((3*MXATM)+3)
C
      COMMON /CHFINF/ CHFSLV,CPTYPE,NWDCHF,POLAR
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /FMCOM / X(1)
      COMMON /FUNCT / E,EG(3,MXATM)
      COMMON /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NORB,NCONF(MXAO),NHAM
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      DATA CPWORD/8HCPHF    /
      DATA RHF/8HRHF     /, ROHF/8HROHF    /, GVB/8HGVB     /,
     *     UHF/8HUHF     /, RMC/8HMCSCF   /
C
C     ----- MAIN DRIVER FOR RESPONSE EQUATION CONTRIBUTIONS -----
C     THIS MEANS ANALYTIC 2ND DERIVATIVES FOR SCF FUNCTIONS,
C     OR 1ST DERIVATIES FOR NON-SCF FUNCTIONS SUCH AS -CI-.
C
      DBG=EXETYP.EQ.CPWORD .AND. MASWRK
      SOME = NPRINT.NE.-5 .AND. MASWRK
      NFT16 = 16
      NFT18 = 18
C
      CALL DERCHK(NDER)
      IF(NDER.EQ.1  .AND.  SCFTYP.NE.RHF) THEN
         IF(MASWRK) WRITE(IW,*)
     *           'CPHF PROGRAMMED FOR RHF+CI GRADIENTS ONLY'
         CALL ABRT
      END IF
C
C     ----- DEFINE UNIQUE -XYZ- FOR WHICH -CPHF- IS NEEDED -----
C
      NXYZ = NAT*3
C
      IF(NDER.EQ.2) THEN
         NUNIQ= 0
         DO 40 IXYZ=1,NXYZ
            NOCP(IXYZ)=1
   40    CONTINUE
         DO 60 IAT=1,NAT
            NUCZ = INT(ZAN(IAT)+0.01D+00) + IZCORE(IAT)
            IF(NUCZ.EQ.0) GO TO 60
            DO 50 IT=1,NT
               IF(MAPCTR(IAT,IT).GT.IAT) GO TO 60
   50       CONTINUE
            IXYZ=3*(IAT-1)
            NOCP(IXYZ+1)=0
            NOCP(IXYZ+2)=0
            NOCP(IXYZ+3)=0
            NUNIQ = NUNIQ+3
   60    CONTINUE
         IF(POLAR) THEN
            NOCP(NXYZ+1)=0
            NOCP(NXYZ+2)=0
            NOCP(NXYZ+3)=0
            NUNIQ = NUNIQ+3
         END IF
      ELSE
         NUNIQ=1
         NOCP(1)=0
         POLAR=.FALSE.
      END IF
C
      IF(NDER.EQ.1) GO TO 300
C
C     ----- INITIALIZE -FCM- WITH ALL NON-CPHF TERMS -----
C
      NEG  = 3*NAT
      NEH  = 9*(NAT*NAT+NAT)/2
      NEGH = NEG + NEH
      NC3  = (3*NAT)*(3*NAT)
C
      CALL VALFM(LOADFM)
      LFCM = LOADFM + 1
      LEG  = LFCM + NC3
      LEH  = LEG  + NEG
      LAST = LEH  + NEH
      NEED = LAST - LFCM
      CALL GETFM(NEED)
C
C     ----- READ FINISHED GRADIENT AND PARTIAL HESSIAN -----
C
      CALL DAREAD(IDAF,IODA,X(LEG),NEGH,67,0)
C
C     ----- SAVE GRADIENT -----
C
      CALL DAWRIT(IDAF,IODA,X(LEG),NEG, 3,0)
      CALL DAWRIT(IDAF,IODA,X(LEG),NEG,29,0)
      CALL DCOPY(NEG,X(LEG),1,EG,1)
      IF(DBG) WRITE(IW,9010)
      IF(DBG) CALL EGOUT(X(LEG),NAT)
C
C     ----- FILL HESSIAN WITH ALL NON-CPHF CONTRIBUTIONS -----
C
      CALL CPWAB0(X(LFCM),X(LEH),NAT)
      IF(DBG) WRITE(IW,9993)
      IF(DBG) CALL CPFCM(X(LFCM),NAT)
      CALL DAWRIT(IDAF,IODA,X(LFCM),NC3,4,0)
      CALL RETFM(NEED)
C
C     ----- NOW DO THE APPROPRIATE CPHF PROBLEM -----
C
  300 CONTINUE
      ROGVB = (SCFTYP.EQ.GVB  .AND.  NPAIR.EQ.0)  .OR.  SCFTYP.EQ.ROHF
      TCSCF = (SCFTYP.EQ.GVB  .AND.  NPAIR.EQ.1)
      PPGVB = (SCFTYP.EQ.GVB  .AND.  NPAIR.GT.1)
C
      IF(SCFTYP.EQ.RHF) CALL CPRHF(NDER,SOME,DBG,NOCP,NXYZ,NUNIQ,
     *                             NFT16,NFT18)
      IF(SCFTYP.EQ.UHF) CALL ABRT
      IF(ROGVB)         CALL CPROHF(TCSCF,SOME,DBG,NOCP,NXYZ,NUNIQ,
     *                              NFT16,NFT18)
      IF(TCSCF)         CALL CPROHF(TCSCF,SOME,DBG,NOCP,NXYZ,NUNIQ,
     *                              NFT16,NFT18)
      IF(PPGVB)         CALL ABRT
      IF(SCFTYP.EQ.RMC) CALL ABRT
C
      IF (MASWRK) WRITE(IW,9000)
      CALL TIMIT(1)
      RETURN
C
 9000 FORMAT(1X,'...... DONE WITH CPHF CONTRIBUTIONS ......')
 9010 FORMAT(10X,15(1H-)/10X,'ENERGY GRADIENT'/10X,15(1H-))
 9993 FORMAT(1X,'-FCM- WITH ALL INTEGRAL DERIVATIVE CONTRIBUTIONS')
      END
C*MODULE CPHF    *DECK CPINP
      SUBROUTINE CPINP
C
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
C
      LOGICAL GOPARR,MASWRK,DSKWRK,POLAR,DIRSCF,FDIFF,OK
C
      COMMON /CHFINF/ CHFSLV,CPTYPE,NWDCHF,POLAR
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
C         NAMELIST DEFINITIONS
C
      PARAMETER (NNAM=4)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA CPHF /8HCPHF    /
      DATA QNAM /8HCPHF    ,8HPOLAR   ,8HSOLVER  ,8HNWORD   /
      DATA KQNAM /5,0,5,1/
C
      DATA BLANK/8H        /
      DATA TYPEAO,TYPEMO,TYPDDI/8HAO      ,8HMO      ,8HAODDI   /
      DATA RHF/8HRHF     /, ANONE/8HNONE    /
C
C     ----- READ $CPHF INPUT GROUP ----
C     CHFSLV IS UNDOCUMENTED DEBUGGING OPTION,
C     FOR MO BASIS RESPONSE EQUATIONS,
C       USE 'CONJG' TO FORCE USE OF CONJUGATE GRADIENTS, EVEN FOR
C            LITTLE PROBLEMS THAT NORMALLY WOULD CALL LINPACK ROUTINES.
C       USE 'ONDISK' TO FORCE THE OUT-OF-CORE CONJUGATE GRADIENT SOLVER.
C     FOR AO BASIS RESPONSE EQUATIONS,
C       USE 'CONJG' FOR ORDINARY PRECONDITIONED CONJUGATE GRADIENT
C       USE 'DIIS' TO USE SIMON WEBB'S DIIS-LIKE ITERATIVE SOLVER
C     FOR EITHER, USE BLANK TO LET THE SOLVER TAKE ITS NORMAL CHOICE.
C
      CPTYPE= TYPEMO
      IF(SCFTYP.EQ.RHF) CPTYPE=TYPEAO
      POLAR = .FALSE.
      CHFSLV= BLANK
      NWDCHF= 0
C
      CALL NAMEIO(IR,JRET,CPHF,NNAM,QNAM,KQNAM,
     *            CPTYPE,POLAR,CHFSLV,NWDCHF,
     *      0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     *      0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     *      0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0)
C
C     1. RHF RESPONSES CAN BE COMPUTED FROM AO BASIS INTEGRALS,
C        BUT NONE OF THE OTHER SCF FUNCTIONS CAN DO THIS.
C     2. EXTENDED TDHF CODE PROGRAMMED ONLY FOR AO BASIS INTEGRALS.
C     3. CI GRADIENT IS PROGRAMMED ONLY FOR MO BASIS INTEGRALS.
C     HERE WE OVERRIDE USER INPUT, RATHER THAN GENERATE AN ERROR:
C
      IF(SCFTYP.NE.RHF)   CPTYPE=TYPEMO
      IF(CITYP.NE.ANONE)  CPTYPE=TYPEMO
      IF(IGETOLI(0).NE.0) CPTYPE=TYPEAO
C
      IF(MASWRK  .AND.  NPRINT.NE.-5) THEN
         WRITE(IW,9010) POLAR,NWDCHF,CPTYPE
      END IF
C
      NERR = 0
C
                            OK = .FALSE.
      IF (CPTYPE.EQ.TYPEAO) OK = .TRUE.
      IF (CPTYPE.EQ.TYPEMO) OK = .TRUE.
      IF (CPTYPE.EQ.TYPDDI) OK = .TRUE.
      IF (.NOT.OK) THEN
         IF(MASWRK) WRITE(IW,*) 'ILLEGAL CHOICE FOR -CPTYPE- IN $CPHF'
         NERR = NERR+1
      END IF
C
      IF (CPTYPE.EQ.TYPDDI  .AND.  .NOT.DIRSCF) THEN
         IF(MASWRK) WRITE(IW,*) 'USE OF CPHF=AODDI REQUIRES DIRSCF=.T.'
         NERR = NERR+1
      END IF
C
      IF(JRET.EQ.2) THEN
         IF (MASWRK) WRITE(IW,9020)
         NERR = NERR+1
      END IF
C
      IF(NERR.GT.0) THEN
         IF(MASWRK) WRITE(IW,*) 'PLEASE FIX ERROR(S) AND TRY AGAIN.'
         CALL ABRT
      END IF
      RETURN
C
 9010 FORMAT(/5X,30(1H-)/5X,'CPHF RESPONSE SOLUTION OPTIONS'/5X,30(1H-)/
     *       5X,'POLAR  =',L8,5X,'NWORD  =',I8/
     *       5X,'CPHF   =',A8)
 9020 FORMAT(1X,'ERROR IN $CPHF INPUT - STOP ')
      END
C*MODULE CPHF    *DECK CPRHF
      SUBROUTINE CPRHF(NDER,SOME,DBG,NOCP,NXYZ,NUNIQ,NFT16,NFT18)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,SOME,CHKMEM,PACK2E,INCORE,GOPARR,DSKWRK,MASWRK,
     *        SVDSKW,SVGPAR,POLAR,MODRV,AODRV,DDAODRV,DIRSCF,FDIFF
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000, MXGSH=30,
     *           MXAO=8192)
C
      DIMENSION NOCP(NXYZ+3)
C
      COMMON /CHFINF/ CHFSLV,CPTYPE,NWDCHF,POLAR
      COMMON /DIISSO/ SOGTOL,ETHRSH,MAXDII,IRAF
      COMMON /FMCOM / X(1)
      COMMON /GUGWFN/ NFZC,NMCC,NDOC,NAOS,NBOS,NALP,NVAL,NEXT,NFZV,
     *                IFORS,IEXCIT,ICICI,NOIRR
      COMMON /IJPAIR/ IA(MXAO)
      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 /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /OPTSCF/ DIRSCF,FDIFF
C
      DATA MAXEQU /128/
      DATA CHECK/8HCHECK   /
      DATA CONJG,ONDISK/8HCONJG   ,8HONDISK  /
      DATA BLANK,DIIS/8H        ,8HDIIS    /
      DATA TYPEMO,TYPEAO,TYPDDI/8HMO      ,8HAO      ,8HAODDI   /
C
C     ----- CLOSED SHELL CPHF CALCULATION -----
C     FOR NDER=1, WE ARE DOING A RHF+CI GRADIENT COMPUTATION
C     IN THIS CASE, WE HAVE NOT CALLED -CPINP- SO FORCE INTEGRAL TYPE
C     FOR NDER=2, WE ARE DOING A RHF ANALYTIC HESSIAN CALCULATION
C
      IF(SOME) WRITE(IW,9000)
      IF(NDER.EQ.1) CPTYPE=TYPEMO
      MODRV   = CPTYPE.EQ.TYPEMO
      AODRV   = CPTYPE.EQ.TYPEAO
      DDAODRV = CPTYPE.EQ.TYPDDI
C
      IF(NDER.EQ.1) THEN
         NOCC = (NFZC + NMCC) + NDOC + NAOS + NBOS + NALP
         NOCACT = NOCC - NFZC
         NCVROT = NFZC*NOCACT
         IF(SOME) WRITE(IW,9005)
      ELSE
         NOCC = NA
      END IF
      NORB = NQMT
      NVIR = NORB - NOCC
      NROT = NOCC * NVIR
      IF(SOME) WRITE(IW,9010) NROT
C
      IF(NDER.EQ.2) THEN
         NC  = NAT*3
         NC3 = NC * NC
      ELSE
         NC  = 1
         NC3 = 1
      END IF
C
      NUM2 =(NUM*NUM+NUM)/2
      NUM3 = NUM*NUM
      NORB2=(NORB*NORB+NORB)/2
      NOCC2=(NOCC*NOCC+NOCC)/2
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
C
      IF(DDAODRV  .OR.  (AODRV.AND.DIRSCF)) THEN
         MAXG = NANGM**4
         NSH2 = (NSHELL*NSHELL+NSHELL)/2
         MXG2 = MXGSH*MXGSH
         INTMAX = 1
      ELSE
         MAXG = 1
         NSH2 = 1
         MXG2 = 1
         INTMAX = NINTMX
      END IF
C
C     ---- IF CALCULATING ALPHA POLARIZABILITIES ----
C     ---- 3 EXTRA SOLUTIONS REQUIRED            ----
C
      IF(POLAR) THEN
         NNXYZ=NXYZ+3
         IF(MASWRK) WRITE(IW,9015) NUNIQ-3,3
      ELSE
         NNXYZ=NXYZ
         IF(MASWRK) WRITE(IW,9015) NUNIQ,0
      END IF
C
      IF(NVIR .EQ. 0) RETURN
C
C     ----- BEGIN CPHF TERMS -----
C     FIRST BRANCH ALL ABOUT TO CHECK MEMORY NEEDS,
C     THEN COME BACK TO -90- AND ACTUALLY BEGIN TO DO THE WORK.
C
      TIM1 = 0.0D+00
      CHKMEM = .TRUE.
      CALL VALFM(LOADFM)
      CALL GOTFM(NGOTMX)
      IF(NWDCHF.GT.0) NGOTMX=MIN(NGOTMX,NWDCHF)
      INCORE=.FALSE.
      NDFA   = 0
      NDTA   = 0
      NDFCK  = 0
      NDWXY  = 0
      NDWXYI = 0
      GO TO 95
C
   90 CONTINUE
      CHKMEM = .FALSE.
      IF(SOME) THEN
         WRITE(IW,9020) NDFA,NDTA,NDFCK,NDWXY,NGOTMX
         IF(.NOT.INCORE  .AND.  MODRV  .AND.  NDWXYI.GT.0)
     *        WRITE(IW,9030) NDWXYI
      END IF
      NDMAX = MAX(NDFA,NDTA,NDFCK,NDWXY)
      IF(NDMAX.GT.NGOTMX) THEN
         IF (MASWRK) WRITE(IW,9040) NDMAX,NGOTMX
         CALL ABRT
         STOP
      END IF
C
      IF(EXETYP.EQ.CHECK) THEN
         CALL GETFM(NDMAX)
         CALL RETFM(NDMAX)
         RETURN
      END IF
C
C     ----- TRANSFORM -DF/DQ- TO MO BASIS -----
C
      CALL TSECND(TIM1)
   95 CONTINUE
      LFCM = 1    + LOADFM
      LWAX = LFCM + NC3
      LC   = LWAX + NROT *NNXYZ
      LAA  = LC   + NUM3
      LTA  = LAA  + NOCC2*NXYZ
      LDFAO= LTA  + NOCC2*NXYZ
      LDFMO= LDFAO+ NUM2
      LT   = LDFMO+ NUM2
      LAST = LT   + NUM
      IF(NDER.EQ.1 .AND. NFZC.GT.0) THEN
         LWAXC= LAST
         LAST = LWAXC+ NCVROT*NXYZ
      ELSE
         LWAXC= LAST
      END IF
      NEED = LAST - LOADFM - 1
      NDFA = NEED
      IF(CHKMEM) GO TO 115
      CALL GETFM(NEED)
C
C        READ IN HESSIAN WITH ALL NON-CPHF TERMS
C
      IF(NDER.EQ.2) CALL DAREAD(IDAF,IODA,X(LFCM),NC3,4,0)
C
C        READ MO VECTORS.
C
      CALL DAREAD(IDAF,IODA,X(LC),NUM3,15,0)
C
      CALL CPFA(DBG,X(LWAX),X(LAA),X(LDFMO),X(LWAXC),
     *          IA,NUM,NOCC,NVIR,NUM2,NOCC2,NXYZ,NFT18,NFZC,NOCACT,NDER)
C
C        SAVE DERIVATIVE FOCK MATRIX FOR EXTENDED TDHF JOBS.
C
      IF(IGETOLI(1).NE.0) THEN
         CALL SVGGA1(X(LDFMO),NFT18)
      END IF
C
      IF (NDER.EQ.1 .AND. NFZC.GT.0) THEN
         CALL DAWRIT(IDAF,IODA,X(LWAXC),NCVROT*NXYZ,304,0)
         IF(DBG) THEN
            WRITE(IW,*) '-WAXC- MATRIX AFTER -DFMO- TERMS'
            CALL PRSQ(X(LWAXC),NXYZ,NCVROT,NCVROT)
         END IF
      END IF
C
      IF(DBG) THEN
         WRITE(IW,*) '-WAX- MATRIX AFTER -DFMO- TERMS'
         CALL PRSQ(X(LWAX),NXYZ,NROT,NROT)
         DO 110 IXYZ=1,NXYZ
            WRITE(IW,9976) IXYZ
            CALL PRTRI(X(LAA+NOCC2*(IXYZ-1)),NOCC)
  110    CONTINUE
      END IF
      CALL RETFM(NEED)
      CALL TSECND(TIM2)
      TIMFA=TIM2-TIM1
      IF(SOME) WRITE(IW,9988) ' -FA-   ',TIMFA
      IF(SOME) CALL FLSHBF(IW)
      TIM1 = TIM2
C
C     ----- TRANSFORM - TA = -1/2 * DS/DA - TO MO BASIS -----
C
  115 CONTINUE
      LFCM = 1+LOADFM
      LWAX = LFCM + NC3
      LC   = LWAX + NROT *NNXYZ
      LAA  = LC   + NUM3
      LTA  = LAA  + NOCC2*NXYZ
      LE   = LTA  + NOCC2*NXYZ
      LDSAO= LE   + NUM
      LDSMO= LDSAO+ NUM2 *NXYZ
      LT   = LDSMO+ NUM2
      LDS  = LT   + NUM
      LAST = LDS  + NUM3*3
      IF(NDER.EQ.2) THEN
         LSDI = LAST
         LSDIA= LSDI + NAT*9
         LH   = LSDIA+ NAT*9
         LF   = LH   + NUM2*3
         LAST = LF   + NUM2
      ELSE
         LSDI  = LAST
         LSDIA = LAST
         LH    = LAST
         LF    = LAST
      END IF
      IF(NDER.EQ.1 .AND. NFZC.GT.0) THEN
         LWAXC= LAST
         LAST = LWAXC+ NCVROT*NXYZ
      ELSE
         LWAXC= LAST
      END IF
      NEED = LAST - LOADFM - 1
      NDTA = NEED
      IF(CHKMEM) GO TO 125
      CALL GETFM(NEED)
C
      IF(NDER.EQ.2) CALL VCLR(X(LH),1,NUM2*3)
C
C        READ 1ST DERIVATIVES OF OVERLAP MATRIX
C
      CALL DAREAD(IDAF,IODA,X(LDS       ),NUM3,63,0)
      CALL DAREAD(IDAF,IODA,X(LDS+NUM3  ),NUM3,64,0)
      CALL DAREAD(IDAF,IODA,X(LDS+NUM3*2),NUM3,65,0)
C
C        READ RHF ORBITAL ENERGIES
C
      CALL DAREAD(IDAF,IODA,X(LE),NUM,17,0)
C
      IF (NDER.EQ.1 .AND. NFZC.GT.0)
     *    CALL DAREAD(IDAF,IODA,X(LWAXC),NCVROT*NXYZ,304,0)
C
      CALL CPTA(NDER,X(LWAX),X(LTA),X(LC),X(LE),X(LDSAO),X(LDSMO),
     *          X(LT),X(LDS),X(LSDI),X(LF),X(LH),X(LWAXC),IA,
     *          NUM,NOCC,NVIR,NORB,NUM2,NOCC2,NXYZ,NAT,NFZC,NOCACT)
C
C        SAVE DERIVATIVE OVERLAP MATRIX FOR EXTENDED TDHF JOBS.
C
      IF(IGETOLI(1).NE.0) THEN
         CALL SVGSA(X(LDSAO),X(LDSMO),X(LC),X(LT))
      ENDIF
C
      IF (NDER.EQ.1 .AND. NFZC.GT.0) THEN
         CALL DAWRIT(IDAF,IODA,X(LWAXC),NCVROT*NXYZ,304,0)
         IF(DBG) THEN
            WRITE(IW,*) '-WAXC- MATRIX AFTER -TA- TERMS'
            CALL PRSQ(X(LWAXC),NXYZ,NCVROT,NCVROT)
         END IF
      END IF
C
      IF(DBG) THEN
         WRITE(IW,*) '-WAX- MATRIX AFTER -TA- TERMS'
         CALL PRSQ(X(LWAX),NXYZ,NROT,NROT)
         DO 120 IXYZ=1,NXYZ
            WRITE(IW,9994) IXYZ
            CALL PRTRI(X(LTA+NOCC2*(IXYZ-1)),NOCC)
  120    CONTINUE
      END IF
C
      CALL TSECND(TIM2)
      TIMTA=TIM2-TIM1
      IF(SOME) WRITE(IW,9988) ' -TA-   ',TIMTA
      IF(SOME) CALL FLSHBF(IW)
C
C     --- ADD OVERLAP DERIVATIVE CONTRIBUTIONS TO DIPOLE DERIVATIVE ---
C
      IF(NDER.EQ.2) THEN
         IF(DBG) THEN
            WRITE(IW,9995)
            CALL DDMOUT(X(LSDI),3*NAT)
         END IF
         CALL DAREAD(IDAF,IODA,X(LSDIA),9*NAT,34,0)
         CALL VADD(X(LSDIA),1,X(LSDI),1,X(LSDIA),1,9*NAT)
         CALL DAWRIT(IDAF,IODA,X(LSDIA),9*NAT,34,0)
C
C     ----- ADD - TA * TB - CONTRIBUTIONS TO -FCM- -----
C
         CALL CPWAB1(X(LFCM),X(LTA),X(LE),IA,NOCC,NOCC2,NXYZ)
         IF(DBG) WRITE(IW,9992)
         IF(DBG) CALL CPFCM(X(LFCM),NAT)
      END IF
C
      CALL RETFM(NEED)
C
C     ----- FORM MODIFIED FOCK MATRICES -----
C     THERE ARE THREE OPTIONS: MO INTEGRALS, OR AO INTEGRALS WITH
C     REPLICATED OR DISTRIBUTED STORAGE FOR THE D/F MATRICES.
C
      CALL TSECND(TIM1)
  125 CONTINUE
C
      L1=NUM
      NAOMX = NANGM   ! MAXIMUM SIZE OF A SHELL
C
C     CHECK DISTRIBUTED MEMORY AVAILABILITY
C
      IF(DDAODRV) THEN
         DMEM = 2.0D+00
         DMEM = (DMEM*NUM*NUM*NNXYZ)/1.0D+06
         NDDDI= INT(DMEM) + 1
         CALL SYSINP( MEMINP, MEMDDI )
         IF(.NOT.CHKMEM  .OR.  EXETYP.EQ.CHECK) THEN
            IF(MASWRK) WRITE(IW,9110) NDDDI,MEMDDI
         END IF
         IF(NDDDI.GT.MEMDDI) THEN
            IF(MASWRK) WRITE(IW,*) 'INCREASE -MEMDDI- IN YOUR INPUT'
            CALL ABRT
         END IF
      END IF
C
      LFCM = LOADFM + 1
      LWAX = LFCM + NC3
      LC   = LWAX + NROT *NNXYZ
      LAA  = LC   + NUM3
      LTA  = LAA  + NOCC2*NXYZ
      LAST = LTA  + NOCC2*NXYZ
C
      IF (DDAODRV) THEN
         LX     = LAST
         LY     = LX     + NUM3
         LWORK  = LY     + NUM3
         LGHOND = LWORK  + MAX(NUM2,NOCC*NOCC,NOCC2)
         LXINTS = LGHOND + MAXG
         LDSH   = LXINTS + NSH2
         LDDIJ  = LDSH   + NSH2
         LDDSH1 = LDDIJ  + 49*MXG2
         LDDSH2 = LDDSH1 + L1*NXYZ*NAOMX
         LDDSH3 = LDDSH2 + L1*NXYZ*NAOMX
         LDFSH1 = LDDSH3 + L1*NXYZ*NAOMX
         LDFSH2 = LDFSH1 + L1*NXYZ*NAOMX
         LDFSH3 = LDFSH2 + L1*NXYZ*NAOMX
         LAST   = LDFSH3 + L1*NXYZ*NAOMX
         LFMO   = LAST
         LDTEMP = LAST
         LFTEMP = LAST
      END IF
      IF(AODRV) THEN
         LDTEMP = LAST
         LFTEMP = LDTEMP + NUM2*NXYZ
         LX     = LFTEMP + NUM2*NXYZ
         LY     = LX     + NUM3
         LWORK  = LY     + NUM3
         LGHOND = LWORK  + MAX(NUM2,NOCC*NOCC,NOCC2)
         LXINTS = LGHOND + MAXG
         LDSH   = LXINTS + NSH2
         LDDIJ  = LDSH   + NSH2
         LAST   = LDDIJ  + 49*MXG2
         LDDSH1 = LAST
         LDDSH2 = LAST
         LDDSH3 = LAST
         LDFSH1 = LAST
         LDFSH2 = LAST
         LDFSH3 = LAST
         LFMO   = LAST
      END IF
      IF(MODRV) THEN
         LFMO   = LAST
         LAST   = LFMO   + NORB2*NXYZ
         LDTEMP = LAST
         LFTEMP = LAST
         LX     = LAST
         LY     = LAST
         LWORK  = LAST
         LGHOND = LAST
         LXINTS = LAST
         LDSH   = LAST
         LDDIJ  = LAST
         LDDSH1 = LAST
         LDDSH2 = LAST
         LDDSH3 = LAST
         LDFSH1 = LAST
         LDFSH2 = LAST
         LDFSH3 = LAST
      END IF
C          JUST LET ALL METHODS ALLOCATE THIS SMALLISH STORAGE?
      LXX  = LAST
      LIX  = LXX + NINTMX
      LAST = LIX + NINTMX
C
      IF(POLAR) THEN
         LHF  = LAST
         LAST = LHF  + NUM2*3
      ELSE
         LHF  = LAST
      END IF
C
      IF(NDER.EQ.1 .AND. NFZC.GT.0) THEN
         LWAXC= LAST
         LAST = LWAXC+ NCVROT*NXYZ
      ELSE
         LWAXC= LAST
      END IF
C
      NEED = LAST - LOADFM - 1
      NDFCK = NEED
      IF(CHKMEM) GO TO 135
      CALL GETFM(NEED)
C
      IF (NDER.EQ.1 .AND. NFZC.GT.0)
     *    CALL DAREAD(IDAF,IODA,X(LWAXC),NCVROT*NXYZ,304,0)
C
C          REPLICATED MEMORY, AO OR MO INTEGRAL DRIVEN ALGORITHMS
C
      IF(AODRV  .OR.  MODRV) THEN
         CALL CPFCK(X(LWAX),X(LAA),X(LTA),X(LFMO),X(LDTEMP),
     *              X(LFTEMP),X(LC),X(LY),X(LX),X(LWORK),X(LHF),
     *              X(LWAXC),X(LXX),X(LIX),X(LGHOND),X(LXINTS),
     *              X(LDSH),X(LDDIJ),IA,NOCC,NVIR,NORB,NOCC2,
     *              NORB2,NXYZ,NNXYZ,IJKT,NINTMX,NUM,NUM2,NFZC,
     *              NOCACT,NDER,MAXG,NSH2,MXG2)
      END IF
C
C          DISTRIBUTED MEMORY, AO DRIVEN ALGORITHM
C
      IF (DDAODRV) THEN
         CALL DD_CPFCK(X(LWAX),X(LAA),X(LTA),
     *                 X(LC),X(LY),X(LX),X(LWORK),X(LHF),
     *                 X(LGHOND),X(LXINTS),X(LDSH),X(LDDIJ),IA,
     *                 NOCC,NVIR,NOCC2,NXYZ,NNXYZ,
     *                 NUM,NUM2,MAXG,NSH2,MXG2,ID_D,ID_F,
     *                 X(LDDSH1),X(LDDSH2),X(LDDSH3),
     *                 X(LDFSH1),X(LDFSH2),X(LDFSH3),NAOMX)
      END IF
C
      IF (NDER.EQ.1 .AND. NFZC.GT.0) THEN
         CALL DAWRIT(IDAF,IODA,X(LWAXC),NCVROT*NXYZ,304,0)
         IF(DBG) THEN
            WRITE(IW,*) '-WAXC- MATRIX AFTER -FCK- CONTRIBUTIONS'
            CALL PRSQ(X(LWAXC),NXYZ,NCVROT,NCVROT)
         END IF
      END IF
C
      IF(DBG) THEN
         WRITE(IW,*) 'COMPLETED -WAX- MATRIX, AFTER -FCK- CONTRIBUTIONS'
         CALL PRSQ(X(LWAX),NNXYZ,NROT,NROT)
         DO 130 IXYZ=1,NXYZ
            WRITE(IW,9973) IXYZ
            CALL PRTRI(X(LAA+NOCC2*(IXYZ-1)),NOCC)
  130    CONTINUE
      END IF
C
      CALL TSECND(TIM2)
      TIMFCK=TIM2-TIM1
      IF(SOME) WRITE(IW,9988) ' -FCK-  ',TIMFCK
      IF(SOME) CALL FLSHBF(IW)
C
C     ----- ADD - TB * AA - CONTRIBUTIONS TO -FCM- -----
C
      IF(NDER.EQ.2) THEN
         CALL CPWAB2(X(LFCM),X(LAA),X(LTA),IA,NOCC,NOCC2,NXYZ)
         IF(DBG) WRITE(IW,9991)
         IF(DBG) CALL CPFCM(X(LFCM),NAT)
      END IF
C
      CALL RETFM(NEED)
C
C     ----- CALCULATE -WXY- MATRIX AND SOLVE CPHF EQNS -----
C
      CALL TSECND(TIM1)
  135 CONTINUE
C
C         MEMORY FOR THE TWO AO INTEGRAL DRIVEN METHODS
C
      L1    = NUM
      NAOMX = NANGM
C
      IF(DDAODRV) THEN
C    NOTE THE FIRST THREE ARE INHERITED FROM ABOVE IN THIS ORDER
         LFCM   = LOADFM + 1
         LWAX   = LFCM   + NC3
         LC     = LWAX   + NROT*NNXYZ
         LYA    = LC     + NUM3
         LWRK1  = LYA    + NROT*NNXYZ
         LWRK2  = LWRK1  + NUM3
         LEIG   = LWRK2  + NUM3
         LGHOND = LEIG   + NUM
         LXINTS = LGHOND + MAXG
         LDSH   = LXINTS + NSH2
         LDDIJ  = LDSH   + NSH2
         LDDSH1 = LDDIJ  + 49*MXG2
         LDDSH2 = LDDSH1 + L1*NNXYZ*NAOMX
         LDDSH3 = LDDSH2 + L1*NNXYZ*NAOMX
         LDFSH1 = LDDSH3 + L1*NNXYZ*NAOMX
         LDFSH2 = LDFSH1 + L1*NNXYZ*NAOMX
         LDFSH3 = LDFSH2 + L1*NNXYZ*NAOMX
         LDMYX  = LDFSH3 + L1*NNXYZ*NAOMX
         LWRK2M = LDMYX  + L1*L1
         LAST   = LWRK2M + L1*L1
      END IF
      IF (AODRV) THEN
C   NOTE THE FIRST THREE ARE INHERITED FROM ABOVE IN THIS ORDER
         LFCM   = LOADFM + 1
         LWAX   = LFCM   + NC3
         LC     = LWAX   + NROT*NNXYZ
         LYA    = LC     + NUM3
         LWRK1  = LYA    + NROT*NNXYZ
         LWRK2  = LWRK1  + NUM3
         LEIG   = LWRK2  + NUM3
         LGHOND = LEIG   + NUM
         LXINTS = LGHOND + MAXG
         LDSH   = LXINTS + NSH2
         LDDIJ  = LDSH   + NSH2
         LXX    = LDDIJ  + 49*MXG2
         LIX    = LXX    + INTMAX
         LDTEMP = LIX    + INTMAX
         LFTEMP = LDTEMP + NUM2*NUNIQ
         LAST   = LFTEMP + NUM2*NUNIQ
         LDDSH1 = LAST
         LDDSH2 = LAST
         LDDSH3 = LAST
         LDFSH1 = LAST
         LDFSH2 = LAST
         LDFSH3 = LAST
         LDMYX  = LAST
         LWRK2M = LAST
      END IF
C
C         SOLVE RESPONSE EQUATIONS USING AO BASIS INTEGRALS
C
      IF(AODRV  .OR.  DDAODRV) THEN
C            DISTRIBUTED DATA CODE CANNOT USE -DIIS- SOLVER
         IF(DDAODRV) CHFSLV=CONJG
         IF(CHFSLV.EQ.BLANK) CHFSLV=CONJG
C           NOTE -LERR- WORKING STORAGE FOR DIIS OVERLAPS DTEMP/FTEMP
         IF(CHFSLV.EQ.DIIS) THEN
            MAXIO  = 2*MAXDII
            MAXIT  = 50+1
            MAXIT2 = (MAXIT*MAXIT+MAXIT)/2
            LAST = MAX(LAST,LDTEMP + NROT*NNXYZ)
            LERR   = LAST
            LYNEW  = LERR   + NROT*NNXYZ
            LADIIS = LYNEW  + NROT*NNXYZ
            LXDIIS = LADIIS + MAXDII*MAXDII
            LIPVT  = LXDIIS + MAXIT*NNXYZ
            LBDIIS = LIPVT  + MAXIT
            LIODII = LBDIIS + MAXIT2*NNXYZ
            LAST   = LIODII + MAXIO
         ELSE
            LRESID = LAST
            LZRES  = LRESID + NROT*NUNIQ
            LPDIR  = LZRES  + NROT*NUNIQ
            LPRCND = LPDIR  + NROT*NUNIQ
            LBNORM = LPRCND + NROT
            LBKNUM = LBNORM + NNXYZ
            LBKDEN = LBKNUM + NNXYZ
            LAST   = LBKDEN + NNXYZ
         END IF
C
         NEED = LAST - LOADFM - 1
C
         NDWXY = NEED
         IF(CHKMEM) GO TO 90
         CALL GETFM(NEED)
C
C        GET RHF ORBITAL ENERGIES, AND START SOLVING.
C
         CALL DAREAD(IDAF,IODA,X(LEIG),NUM,17,0)
C
C            THE DIIS SOLVER IS NOT NORMALLY USED.
C
         IF(CHFSLV.EQ.DIIS) THEN
            CALL AOCPDI(X(LWAX),X(LC),X(LYA),X(LYNEW),X(LDTEMP),
     *                  X(LFTEMP),X(LEIG),X(LWRK1),X(LWRK2),
     *                  X(LERR),X(LADIIS),X(LXDIIS),X(LIPVT),
     *                  X(LBDIIS),X(LIODII),X(LXX),X(LIX),X(LGHOND),
     *                  X(LXINTS),X(LDSH),X(LDDIJ),NOCP,
     *                  NROT,NNXYZ,NUNIQ,NOCC,NVIR,NUM,NUM2,NUM3,
     *                  MAXIT,MAXIT2,MAXIO,MAXG,NSH2,MXG2)
         ELSE
C
C            THE TWO AO DRIVEN ALGORITHMS USE CONJUGATE GRADIENTS
C
            IF (DDAODRV) THEN
C                      DISTRIBUTED STORAGE
               CALL DD_AOCPCG(X(LWAX),X(LYA),X(LRESID),X(LZRES),
     *                        X(LPDIR),X(LPRCND),X(LBNORM),
     *                        X(LBKNUM),X(LBKDEN),X(LC),X(LEIG),
     *                        X(LWRK1),X(LWRK2),X(LDMYX),X(LWRK2M),
     *                        NOCP,X(LGHOND),
     *                        X(LXINTS),X(LDSH),X(LDDIJ),
     *                        NNXYZ,NUNIQ,NFOCK,NROT,
     *                        NOCC,NVIR,NUM,NUM3,NSH2,MAXG,MXG2,NAOMX,
     *                        X(LDDSH1),X(LDDSH2),X(LDDSH3),
     *                        X(LDFSH1),X(LDFSH2),X(LDFSH3))
            ELSE
C                      REPLICATED STORAGE
               CALL AOCPCG(X(LWAX),X(LYA),X(LRESID),X(LZRES),
     *                     X(LPDIR),X(LPRCND),X(LBNORM),
     *                     X(LBKNUM),X(LBKDEN),X(LC),X(LEIG),
     *                     X(LDTEMP),X(LFTEMP),X(LWRK1),X(LWRK2),
     *                     NOCP,X(LGHOND),X(LXINTS),X(LDSH),
     *                     X(LDDIJ),X(LXX),X(LIX),NNXYZ,NUNIQ,
     *                     NFOCK,NROT,NOCC,NVIR,NUM,NUM2,
     *                     NUM3,NSH2,MAXG,MXG2)
            END IF
         END IF
         NSOLV = NNXYZ
C
C        SAVE RESPONSE VECTORS AND OTHER INFO FOR EXTENDED TDHF JOBS.
C
         IF(IGETOLI(1).NE.0) THEN
          CALL SVGGA2(X(LEIG),X(LC),X(LYA),NROT,X(LWRK1),X(LWRK2),
     *                X(LDTEMP),X(LFTEMP),NUM2,X(LGHOND),X(LXINTS),
     *                X(LDSH),X(LDDIJ),X(LXX),X(LIX),MAXG,NSH2,MXG2)
         ENDIF
      END IF
C
C  MO INTEGRAL DRIVEN METHOD
C  NOTE THAT CI GRADIENT MUST PASS THROUGH THE MO INTEGRAL CODE.
C
      IF(MODRV) THEN
         LFCM = 1+LOADFM
         LWAX = LFCM + NC3
         LWII = LWAX + NROT*NNXYZ
         LAST = LWII + NROT
         IF(NDER.EQ.1) THEN
            LLAGR  = LAST
            LDLAGR = LLAGR  + NUM3
            LX     = LDLAGR + NROT
            LY     = LX     + NUM3
            LAST   = LY     + NUM3
         ELSE
            LLAGR  = LAST
            LDLAGR = LAST
            LX     = LAST
            LY     = LAST
         END IF
         IF(NDER.EQ.1 .AND. NFZC.GT.0) THEN
            LZCV   = LAST
            LWAXC  = LZCV   + NCVROT
            LPMN   = LWAXC  + NCVROT*NXYZ
            LXLMN  = LPMN   + NUM2
            LAST   = LXLMN  + NUM2
         ELSE
            LZCV   = LAST
            LWAXC  = LAST
            LPMN   = LAST
            LXLMN  = LAST
         END IF
C                         OVERLAP PART OF -WXY- FORMATION STORAGE...
         LE   = LAST
         LXX  = LE  + NUM
         LIX  = LXX + NINTMX
         LAST1= LIX + NINTMX
C                         ...WITH PART OF THE CPHF SOLUTION STORAGE...
         IF(NDER.EQ.2) THEN
            LYA  = LAST
            LAST2= LYA  + NROT*NNXYZ
         ELSE
            LYA  = LAST
            LAST2= LYA  + NROT
         END IF
C
         LAST = MAX(LAST1,LAST2)
         NNEED= LAST-LOADFM-1
         NFREE= NGOTMX-NNEED
C
C        FOR DEBUGGING, WE MAY WANT TO FORCE A PARTICULAR SOLVER.
C
         IF(CHFSLV.EQ.CONJG) MAXEQU=1
         IF(CHFSLV.EQ.ONDISK) THEN
            MAXEQU=1
            NFREE = NUM*NUM +2*NNXYZ +4*NNXYZ*NROT + (NROT*NROT+10)/2
         END IF
C
C        IF -WXY- IS VERY SMALL, WE SOLVE FOR ONE RESPONSE
C        AT A TIME.  THE CONJUGATE GRADIENT OPTION, IN OR OUT
C        OF CORE SOLVES FOR ALL RESPONSES SIMULTANEOUSLY TO
C        MINIMIZE DISK I/O ON THE EXTERNAL FILE OF -WXY-, OR
C        MEMORY ACCESSES ON -WXY-.
C        FOR 1ST DERIVATIVES, WE NEED SOLVE ONLY FOR THE Z-VECTOR.
C
         IF(NDER.EQ.1) THEN
            NSOLV = 1
         ELSE
            NSOLV = NNXYZ
         END IF
         IF(NROT.LE.MAXEQU) NSOLV=1
C
C         DECIDE IF PROBLEM FITS IN AVAILABLE MEMORY,
C         WATCH OUT FOR 32 BIT SYSTEMS
C
         DMY = 2.0D+00**31 - 2*NSOLV - 4*NROT*NSOLV - 1000
         N32MAX = INT(SQRT(DMY))
         IF(NWDVAR.EQ.1  .OR.  NROT.LE.N32MAX) THEN
            INMEM  = NROT*NROT + 2*NSOLV + 4*NROT*NSOLV
            INCORE = INMEM.LE.NFREE
            NDWXYI = NNEED + INMEM
         ELSE
            INMEM = 0
            INCORE = .FALSE.
            NDWXYI = 0
         END IF
C
C                         ...FOLLOWED BY MORE SOLVER STORAGE,
C                         WITH -WXY- ITSELF ALLOCATED LAST.
C
         IF(INCORE) THEN
            NWIDTH = NROT
            IF(SOME  .AND.  CHKMEM) WRITE(IW,9050)
            LIROT= LAST
            LBNRM= LAST
            LRESD= LBNRM + NSOLV
            LWRK1= LRESD + NSOLV
            LWRK2= LWRK1 + NROT*NSOLV
            LWRK3= LWRK2 + NROT*NSOLV
            LWRK4= LWRK3 + NROT*NSOLV
            LWXY = LWRK4 + NROT*NSOLV
            LAST = LWXY  + NROT*NROT
         ELSE
            NWIDTH = (NFREE - NUM*NUM - 2*NSOLV- 4*NROT*NSOLV)/NROT
            IF(NWIDTH.GT.0) THEN
               NSLICE = (NROT-1)/NWIDTH + 1
            ELSE
               NSLICE=-1
            END IF
            IF(NWIDTH.LE.0  .OR.  (NSLICE.GT.NAT .AND. NAT.GT.5)) THEN
               IF (MASWRK) THEN
                  NEEDX = NUM*NUM + 2*NSOLV + 4*NROT*NSOLV
                  NNEED = NNEED + NEEDX
                  NFREE = NFREE - NEEDX
                  NEEDW = (NROT-1)/(NAT-1)
                  NEED  = NNEED + NROT*NEEDW
                  WRITE(IW,9070) NWIDTH,NSLICE,NAT,NFREE,NNEED,NROT,NEED
               END IF
               CALL ABRT
               STOP
            END IF
            IF(SOME  .AND.  CHKMEM) WRITE(IW,9060) NSLICE,NWIDTH
            LIROT= LAST
            LBNRM= LIROT + NUM*NUM
            LRESD= LBNRM + NSOLV
            LWRK1= LRESD + NSOLV
            LWRK2= LWRK1 + NROT*NSOLV
            LWRK3= LWRK2 + NROT*NSOLV
            LWRK4= LWRK3 + NROT*NSOLV
            LWXY = LWRK4 + NROT*NSOLV
            LAST = LWXY  + NROT*NWIDTH
         END IF
C
         NEED = LAST - LOADFM - 1
         NDWXY = NEED
         IF(CHKMEM) GO TO 90
         CALL GETFM(NEED)
C
C        GET RHF ORBITAL ENERGIES
C
         CALL DAREAD(IDAF,IODA,X(LE),NUM,17,0)
C
C        COMPUTE ORBITAL HESSIAN
C
         IF(INCORE) THEN
            NWIDTH = NROT
            CALL CPWXYI(X(LWXY),X(LE),X(LXX),X(LIX),
     *                  NUM,NOCC,NVIR,IJKT,NINTMX)
            IF(DBG) THEN
               WRITE(IW,9998)
               CALL PRSQ(X(LWXY),NROT,NROT,NROT)
            END IF
         ELSE
            SVDSKW = DSKWRK
            DSKWRK = .FALSE.
            CALL SEQOPN(NFT16,'WORK16','UNKNOWN',.FALSE.,'UNFORMATTED')
            DSKWRK = SVDSKW
            CALL CPWXYO(X(LWXY),X(LE),X(LXX),X(LIX),X(LIROT),X(LWII),
     *                  NROT,NWIDTH,NUM,NOCC,NVIR,IJKT,NINTMX,NFT16,DBG)
         END IF
C
         CALL TSECND(TIM2)
         TIMWXY=TIM2-TIM1
         IF(SOME) THEN
            WRITE(IW,9988) ' -WXY-  ',TIMWXY
            CALL FLSHBF(IW)
         END IF
         TIM1 = TIM2
C
C        --- GET CI LAGRANGIAN XIJ FROM DAF ---
C       --- CONSTRUCT ITS ASYMMETRY (XIJ - XJI) ---
C
         IF(NDER.EQ.1) THEN
            CALL DAREAD(IDAF,IODA,X(LLAGR),NORB*NORB,404,0)
            CALL XDELTA(X(LLAGR),X(LDLAGR),X(LZCV),X(LE),X(LX),X(LY),
     *                  X(LPMN),X(LXLMN),X(LXX),X(LIX),
     *                  NOCC,NVIR,NORB,NUM,NUM2,NUM3,NOCACT,NFZC,NINTMX)
         END IF
C
C        1ST DER: USE Z-VECTOR APPROACH FOR ONE RESPONSE.
C        2ND DER: SOLVE FOR SYMMETRY UNIQUE CPHF RESPONSE VECTORS
C        AT THIS POINT -NSOLV- SHOULD ALREADY BE SET CORRECTLY,
C        SO ALL WE NEED TO DO IS POINT AT THE CORRECT INHOMOGENEITY.
C
C        SOLVING IS DONE SEQUENTIALLY ON THE MASTER NODE AT PRESENT!
C
         NITER=0
         NPASS=0
         SVGPAR = GOPARR
         SVDSKW = DSKWRK
         GOPARR = .FALSE.
         DSKWRK = .FALSE.
         IF(MASWRK) THEN
            LINHMG = LWAX
            IF(NDER.EQ.1) LINHMG = LDLAGR
            IF(NDER.EQ.1) NNXYZ  = 1
            CALL SOLVCP(X(LWXY),X(LINHMG),X(LYA),NROT,NNXYZ,NOCP,
     *                  X(LWII),X(LWRK1),X(LWRK2),X(LWRK3),X(LWRK4),
     *                  X(LBNRM),X(LRESD),NITER,NPASS,NWIDTH,NSOLV,
     *                  INCORE,NFT16,MAXEQU)
C              OTHER NODES SHOULD ZERO SO -CPWAB3- MATH IS DEFINED.
         ELSE
            CALL VCLR(X(LYA),1,NROT*NNXYZ)
         END IF
         GOPARR = SVGPAR
         DSKWRK = SVDSKW
      END IF
C
C          END OF MO BASIS RESPONSE EQUATION SOLVING.
C
      IF(DBG) THEN
         WRITE(IW,*) 'CPHF RESPONSE VECTORS -YA-'
         CALL PRSQ(X(LYA),NNXYZ,NROT,NROT)
      END IF
C
C     --- FORM CI GRADIENT CONTRIBUTION FROM THE Z-VECTOR ---
C     --- FORM RELAXED CI DENSITY FROM THE Z-VECTOR ---
C
      IF(NDER.EQ.1) THEN
         IF(NFZC.GT.0) THEN
            CALL DAREAD(IDAF,IODA,X(LWAXC),NCVROT*NXYZ,304,0)
         END IF
         CALL ZGRDCI(X(LYA),X(LWAX),X(LWAXC),X(LZCV),NVIR,NOCC,
     *               NXYZ,NAT,NFZC,NOCACT)
         CALL ZDENCI(X(LYA),X(LLAGR),X(LZCV),X(LX),X(LY),
     *               NOCC,NUM,NUM2,NUM3,NVIR,NFZC,NOCACT)
      END IF
C
      CALL RETFM(NEED)
      CALL TSECND(TIM2)
      TIMYA=TIM2-TIM1
      IF(SOME) WRITE(IW,9988) ' -YA-   ',TIMYA
      IF(SOME) CALL FLSHBF(IW)
      IF(SOME  .AND.  MODRV) THEN
         IF(NITER.GT.0) WRITE(IW,9080) NUNIQ,NITER
         IF(.NOT.INCORE) WRITE(IW,9090) NPASS
      END IF
C
      IF(NDER.EQ.1) GO TO 900
C
C     ----- ADD WAX * YB - CONTRIBUTIONS TO -FCM- -----
C     SNEAKY: THERE IS A MATRIX BETWEEN WAX AND YA WHOSE SIZE
C     DEPENDS ON THE ALGORITHM USED ABOVE
C
      IF(AODRV  .OR.  DDAODRV) THEN
         ISKIP = NUM3
      ELSE
         ISKIP = NROT
      END IF
      LFCM = LOADFM + 1
      LWAX = LFCM   + NC3
      LAST = LWAX   + NROT*NNXYZ
      LYA  = LAST   + ISKIP
      LH   = LYA    + NROT*NNXYZ
      LDDM = LH     + NUM2*3
      LDDMA= LDDM   + NAT*9
      LSK  = LDDMA  + NAT*9
      LAST = LSK    + NAT
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL CPWAB3(X(LFCM),X(LWAX),X(LYA),X(LH),X(LDDM),IA,
     *            NROT,NXYZ,NNXYZ,NUM2,NOCC,NVIR)
      IF(DBG) WRITE(IW,9990)
      IF(DBG) CALL CPFCM(X(LFCM),NAT)
C
C     ---- ADD RESPONSE CONTRIBUTIONS TO DIPOLE DERIVATIVE ----
C
      IF(DBG) THEN
         WRITE(IW,9996)
         CALL DDMOUT(X(LDDM),3*NAT)
      END IF
      CALL DAREAD(IDAF,IODA,X(LDDMA),NAT*9,34,0)
      CALL VADD(X(LDDMA),1,X(LDDM),1,X(LDDMA),1,NAT*9)
      CALL DAWRIT(IDAF,IODA,X(LDDMA),NAT*9,34,0)
C
C     ---- SYMMETRIZE DIPOLE DERIVATIVE ----
C
      CALL CPSDDM(X(LDDMA),X(LSK),3*NAT)
C
C     ----- SYMMETRIZE -FCM- AND OUTPUT IT -----
C
      CALL CPSYM(X(LFCM),NC)
      IF(DBG) CALL CPFCM(X(LFCM),NAT)
      CALL DAWRIT(IDAF,IODA,X(LFCM),NC3,4,0)
      CALL RETFM(NEED)
C
  900 CONTINUE
      RETURN
C
 9998 FORMAT(' -WXY- MATRIX ')
 9994 FORMAT(' -TA- MATRIX ',I5)
 9992 FORMAT(' ADD T(A) * T(B) CONTRIBUTION TO -FCM- ')
 9991 FORMAT(' ADD T(A) * AA(B) CONTRIBUTION TO -FCM- ')
 9995 FORMAT(/10X,34(1H-)/
     *        10X,'OVERLAP DERIVATIVE CONTRIBUTION TO'/
     *        10X,34(1H-))
 9996 FORMAT(/10X,31(1H-)/
     *        10X,'RESPONSE FACTOR CONTRIBUTION TO'/
     *        10X,31(1H-))
 9990 FORMAT(' ADD WAX * YA CONTRIBUTION TO -FCM- ')
 9988 FORMAT(1X,'       TIME FOR',A8,'= ',F12.3)
 9976 FORMAT(' AFTER -DFMO- CONTRIBUTION TO -AA- ',I3)
 9973 FORMAT(' AFTER -FCK- CONTRIBUTION TO -AA- ',I3)
 9000 FORMAT(/5X,43(1H-)/
     *        5X,'COUPLED-PERTURBED CLOSED SHELL HARTREE-FOCK'/
     *        5X,43(1H-))
 9005 FORMAT(/10X,'...... USING THE Z VECTOR METHOD ......')
 9010 FORMAT(1X,'THE CPHF HAS',I8,' INDEPENDENT ORBITAL ROTATIONS.')
 9015 FORMAT(1X,'SOLVING FOR',I5,' NUCLEAR RESPONSES AND',I2,
     *          ' ELECTRIC FIELD RESPONSES')
 9020 FORMAT(10X,' -FA- WILL USE',I10,' WORDS,'/
     *       10X,' -TA- WILL USE',I10,' WORDS,'/
     *       10X,'-FCK- WILL USE',I10,' WORDS,'/
     *        1X,'-WXY- AND -YA- WILL USE',I10,' WORDS,'/
     *       10X,'     THERE ARE',I10,' WORDS OF REPLICATED MEMORY',
     *           ' AVAILABLE.')
 9030 FORMAT(1X,'IN MEMORY FORMATION OF -WXY- WOULD REQUIRE',I10,
     *          ' WORDS')
 9040 FORMAT(1X,'NOT ENOUGH MEMORY TO DO CPHF, NEED=',I10,' GOT=',I10)
 9050 FORMAT(1X,'CHOOSING IN MEMORY CPHF ALGORITHM')
 9060 FORMAT(1X,'CHOOSING OUT OF MEMORY CPHF ALGORITHM,'/
     *   1X,'-WXY- WILL BE FORMED IN',I5,' SLICES OF',I7,' COLUMNS.')
 9070 FORMAT(/1X,'*** NOT ENOUGH MEMORY TO RUN THE OUT OF MEMORY',
     *          ' CPHF CODE ***'/
     *       1X,'NWIDTH=',I10,'  NSLICE=',I10,'   NAT=',I10/
     *       1X,' NFREE=',I10,'   NNEED=',I10,'  NROT=',I10//
     *       1X,'INCREASE MEMORY IN $SYSTEM TO AT LEAST',I10/
     *       1X,'LARGER AMOUNTS OF MEMORY ARE EVEN BETTER!')
 9080 FORMAT(1X,'SOLVING FOR ALL',I4,' UNIQUE RESPONSES TOOK',
     *          I5,' CG UPDATES.')
 9090 FORMAT(1X,'CONJUGATE GRADIENT SOLVER MADE',I4,
     *          ' READS OF THE EXTERNALLY STORED -WXY-')
 9110 FORMAT(/1X,21(1H-),5X,45(1H-)/
     *       1X,'DISTRIBUTED DATA CPHF',5X,
     *       'PROGRAM BY Y.ALEXEEV, T.L.WINDUS, M.W.SCHMIDT'/
     *       1X,21(1H-),5X,45(1H-)/
     *       1X,' REQUIRED DISTRIBUTED MEMORY=',I12,' MWORDS,'/
     *       1X,'AVAILABLE DISTRIBUTED MEMORY=',I12,' MWORDS.')
      END
C*MODULE HESS    *DECK CPSDDM
      SUBROUTINE CPSDDM(DDM,SKIP,NCOORD)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION DDM(3,NCOORD)
      DIMENSION V(3,3)
C
      LOGICAL SKIP(NAT),OUT,GOPARR,DSKWRK,MASWRK
      PARAMETER (MXSH=5000, 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 /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMSPD/ PTR(3,144),DTR(6,288),FTR(10,480),GTR(15,720)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TDMY(432),INVT(48),NT
C
      PARAMETER (ZERO=0.0D+00, TM9=1.0D-09)
C
C     ----- SYMMETRIZE THE DIPOLE DERIVATIVE TENSOR -----
C
      OUT = NPRINT.EQ.1 .AND. MASWRK
C
C     ----- GET RAW DIPOLE DERIVATIVE MATRIX -----
C
      CALL DAREAD(IDAF,IODA,DDM,3*NCOORD,34,0)
      IF(OUT) WRITE(IW,9020)((DDM(I,J),I=1,3),J=1,NCOORD)
C
C     ----- GET TRANFORMATION MATRICES OF COORDINATES. -----
C
      IF(NT.EQ.1) GO TO 400
      CALL DAREAD(IDAF,IODA,PTR,432,7,0)
C
C     ---- SEE WHICH BLOCKS HAVE ALREADY BEEN COMPUTED ----
C
      DO 220 IC = 1,NAT
         SKIP(IC) = .FALSE.
         DO 210 IT = 1,NT
            IF (MAPCTR(IC,IT) .GT. IC) GO TO 220
  210    CONTINUE
         SKIP(IC) = .TRUE.
  220 CONTINUE
C
C     ----- SYMMETRIZE DIPOLE DERIVATIVES -----
C
      DO 360 IC = 1,NAT
         IF(.NOT.SKIP(IC)) GO TO 360
         DO 340 IT = 1,NT
            ICNU = MAPCTR(IC,IT)
            IF(SKIP(ICNU)) GO TO 340
            INDX = 3*(IC-1)
            N = 3*(IT-1)
            DO 280 JT = 1,3
               DO 260 L=1,3
                  DUM = ZERO
                  DO 240 M=1,3
                     DUM = DUM + DDM(JT,INDX+M)*PTR(L,N+M)
  240             CONTINUE
                  V(JT,L) = DUM
  260          CONTINUE
  280       CONTINUE
            INDX = 3*(ICNU-1)
            DO 320 JT = 1,3
               DO 310 L=1,3
                  DUM = ZERO
                  DO 300 M=1,3
                     DUM = DUM + PTR(JT,N+M)*V(M,L)
  300             CONTINUE
                  DDM(JT,INDX+L) = DUM
  310          CONTINUE
  320       CONTINUE
            SKIP(ICNU) = .TRUE.
  340    CONTINUE
  360 CONTINUE
C
C     ---- CONVERT TO DEBYE/ANGSTROM, ZERO OUT VERY SMALL VALUES ----
C
  400 CONTINUE
      DO 420 I=1,NAT*3
         DO 410 J=1,3
            DDM(J,I)=DDM(J,I)*4.803242D+00
            IF(ABS(DDM(J,I)).LT.TM9) DDM(J,I)=ZERO
  410    CONTINUE
  420 CONTINUE
C
C     ----- STORE IT ON THE DAF -----
C
      CALL DAWRIT(IDAF,IODA,DDM,3*NCOORD,34,0)
      RETURN
C
 9020 FORMAT(/' RAW DIPOLE DERIVATIVE MATRIX'/(3E15.6))
      END
C*MODULE CPHF    *DECK CPTA
      SUBROUTINE CPTA(NDER,WAX,TA,C,E,DSAO,DSMO,T,DS,SDIDER,F,H,
     *                WAXC,IA,NUM,NOCC,NVIR,NORB,NUM2,NOCC2,NXYZ,
     *                NAT,NFZC,NOCACT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C        SDIDER,F,H NEEDED ONLY FOR RHF 2ND DERIVATIVE
C
      DIMENSION WAX(NOCC,NVIR,NXYZ),TA(NOCC2,NXYZ),C(NUM,NUM),E(NUM),
     *          DSAO(NUM2,NXYZ),DSMO(NUM2),T(NUM),DS(NUM,NUM,3),IA(NUM),
     *          SDIDER(9*NAT),F(NUM2),H(NUM2,3),WAXC(NFZC,NOCACT,NXYZ)
C
      PARAMETER (MXGTOT=20000, MXSH=5000)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
C
C
      PARAMETER (PT5=0.5D+00, FOUR=4.0D+00, TWO=2.0D+00, ZERO=0.0D+00)
C
C     ----- COMPUTE DS/DA IN THE MO BASIS -----
C
      CALL VCLR(DSAO,1,NUM2*NXYZ)
C
      DO 150 ISHELL = 1,NSHELL
         IAT  = KATOM(ISHELL)
         IXYZ = 3*(IAT-1)
         LOCI = KLOC(ISHELL) - KMIN(ISHELL)
         MINI = KMIN(ISHELL)
         MAXI = KMAX(ISHELL)
         DO 140 I = MINI,MAXI
            II   = LOCI + I
            DO 130 JJ = 1,NUM
               IJ = IA(MAX(II,JJ)) + MIN(II,JJ)
               DSAO(IJ,IXYZ+1) = DSAO(IJ,IXYZ+1) + DS(II,JJ,1)
               DSAO(IJ,IXYZ+2) = DSAO(IJ,IXYZ+2) + DS(II,JJ,2)
               DSAO(IJ,IXYZ+3) = DSAO(IJ,IXYZ+3) + DS(II,JJ,3)
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
C
C     ---- GET DIPOLE INTEGRALS AND TRANSFORM TO MO BASIS   ----
C     ---- WRITE TRANSFORMED INTEGRALS TO DAF FOR LATER USE ----
C
      IF(NDER.EQ.2) THEN
         CALL DAREAD(IDAF,IODA,F,NUM2,95,0)
         CALL TFTRI(H(1,1),F,C,T,NORB,NUM,NUM)
         CALL DAREAD(IDAF,IODA,F,NUM2,96,0)
         CALL TFTRI(H(1,2),F,C,T,NORB,NUM,NUM)
         CALL DAREAD(IDAF,IODA,F,NUM2,97,0)
         CALL TFTRI(H(1,3),F,C,T,NORB,NUM,NUM)
C
         CALL DAWRIT(IDAF,IODA,H(1,1),NUM2,252,0)
         CALL DAWRIT(IDAF,IODA,H(1,2),NUM2,253,0)
         CALL DAWRIT(IDAF,IODA,H(1,3),NUM2,254,0)
      END IF
C
      DO 500 IXYZ=1,NXYZ
         CALL TFTRI(DSMO,DSAO(1,IXYZ),C,T,NORB,NUM,NUM)
C
C     ----- SET -TA- -----
C
         DO 220 IOCC=1,NOCC
            DO 210 JOCC=1,IOCC
               IJ=IA(IOCC)+JOCC
               TA(IJ,IXYZ)=(-PT5)*DSMO(IJ)
  210       CONTINUE
  220    CONTINUE
C
C     ----- CONTRIBUTION TO THE INHOMOGENEITY -----
C
         DO 320 IVIR=1,NVIR
            DO 310 IOCC=1,NOCC
               IJ=IA(IVIR+NOCC)+IOCC
               WAX(IOCC,IVIR,IXYZ)=WAX(IOCC,IVIR,IXYZ)
     *                            -FOUR*DSMO(IJ)*E(IOCC)
  310       CONTINUE
  320    CONTINUE
C
         IF (NDER.EQ.1 .AND. NFZC.GT.0) THEN
            DO 340 IACT=1,NOCACT
               DO 330 IFZC=1,NFZC
                  IJ=IA(IACT+NFZC)+IFZC
                  WAXC(IFZC,IACT,IXYZ)=WAXC(IFZC,IACT,IXYZ)
     *                               -FOUR*DSMO(IJ)*E(IFZC)
  330          CONTINUE
  340       CONTINUE
         END IF
C
C     ----- CONTRIBUTION TO DIPOLE DERIVATIVE -----
C
         IF(NDER.EQ.2) THEN
            NN=1 + (IXYZ-1)*3
            SDIDER(NN  )=ZERO
            SDIDER(NN+1)=ZERO
            SDIDER(NN+2)=ZERO
            DO 440 IOCC=1,NOCC
               DO 430 JOCC=1,IOCC
                  IJ=IA(IOCC)+JOCC
                  VAL=DSMO(IJ)
                  IF (IOCC .NE. JOCC) VAL= VAL + VAL
                  SDIDER(NN  )=SDIDER(NN  )+(TWO*VAL*H(IJ,1))
                  SDIDER(NN+1)=SDIDER(NN+1)+(TWO*VAL*H(IJ,2))
                  SDIDER(NN+2)=SDIDER(NN+2)+(TWO*VAL*H(IJ,3))
  430          CONTINUE
  440       CONTINUE
         END IF
  500 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK CPSYM
      SUBROUTINE CPSYM(A,NC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(NC,NC)
      DIMENSION T(3,3),U(3,3),V(3,3)
C
      PARAMETER (MXSH=5000, 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,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /SYMSPD/ PTR(3,144),DTR(6,288),FTR(10,480),GTR(15,720)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TDMY(432),INVT(48),NT
C
      DATA ZERO,ONE,TWO /0.0D+00,1.0D+00,2.0D+00/
C
C     ----- SYMMETRIZE THE HESSIAN MATRIX -----
C     READ IN TRANFORMATION MATRICES OF COORDINATES.
C
      CALL DAREAD(IDAF,IODA,PTR,432,7,0)
C
C     ----- FILL IN SYMMETRY EQUIVALENT BLOCKS -----
C
      DO 400 JAT=1,NAT
      DO 310 IT=1,NT
      IF(MAPCTR(JAT,IT).GT.JAT) GO TO 400
  310 CONTINUE
      DO 390 IAT=1,NAT
      LOCI=3*(IAT-1)
      LOCJ=3*(JAT-1)
      DO 320 J=1,3
      DO 320 I=1,3
  320 T(I,J)=A(LOCI+I,LOCJ+J)
C
      DO 380 IT=1,NT
      KAT=MAPCTR(IAT,IT)
      LAT=MAPCTR(JAT,IT)
      N=3*(INVT(IT)-1)
      DO 340 L=1,3
      DO 340 K=1,3
      DUM=ZERO
      DO 330 M=1,3
  330 DUM=DUM+T(K,M)*PTR(M,L+N)
  340 U(K,L)=DUM
      DO 360 L=1,3
      DO 360 K=1,3
      DUM=ZERO
      DO 350 M=1,3
  350 DUM=DUM+PTR(M,K+N)*U(M,L)
  360 V(K,L)=DUM
      LOCK=3*(KAT-1)
      LOCL=3*(LAT-1)
      DO 370 L=1,3
      DO 370 K=1,3
  370 A(LOCK+K,LOCL+L)=V(K,L)
  380 CONTINUE
C
  390 CONTINUE
  400 CONTINUE
C
      DO 410 I=1,NC
      DO 410 J=1,I
      SUM =(A(I,J)+A(J,I))/TWO
      A(J,I)=SUM
  410 A(I,J)=SUM
C
      IF(NT.EQ.1) RETURN
C
C     ----- SYMMETRIZE HESSIAN MATRIX -----
C
      DO 800 IC = 1,NAT
      DO 700 JC = 1,NAT
C
C     ----- APPLY PROJECTION OPERATOR -----
C
      DO 510 J  = 1,3
      DO 510 I  = 1,3
  510 V(I,J) = ZERO
C
      DO 570 IT = 1,NT
      KC = MAPCTR(IC,IT)
      LC = MAPCTR(JC,IT)
C
      LOCL=3*(LC-1)
      LOCK=3*(KC-1)
      DO 520 L = 1,3
      DO 520 K = 1,3
  520 T(K,L) = A(LOCK+K,LOCL+L)
      N = 3*(IT-1)
      DO 540 L = 1,3
      DO 540 K = 1,3
      SUM = ZERO
      DO 530 M = 1,3
  530 SUM = SUM + T(K,M) * PTR(M,L+N)
  540 U(K,L) = SUM
      DO 560 K = 1,3
      DO 560 L = 1,3
      SUM = ZERO
      DO 550 M = 1,3
  550 SUM = SUM + PTR(M,K+N) * U(M,L)
  560 V(K,L) = V(K,L) + SUM
  570 CONTINUE
C
      FAC = ONE / NT
      LOCJ=3*(JC-1)
      LOCI=3*(IC-1)
      DO 580 J = 1,3
      DO 580 I = 1,3
  580 V(I,J) = V(I,J) * FAC
C
C     ----- REMAP PROJECTED BLOCK ONTO EQUIVALENT BLOCKS -----
C
      DO 660 IT = 1,NT
      KC = MAPCTR(IC,IT)
      LC = MAPCTR(JC,IT)
C
      N = 3*(INVT(IT) - 1)
      DO 620 L = 1,3
      DO 620 K = 1,3
      SUM = ZERO
      DO  610 M = 1,3
  610 SUM = SUM + V(K,M) * PTR(M,L+N)
  620 U(K,L) = SUM
      DO 640 L = 1,3
      DO 640 K = 1,3
      SUM = ZERO
      DO 630 M = 1,3
  630 SUM = SUM + PTR(M,K+N) * U(M,L)
  640 T(K,L) = SUM
C
      LOCL=3*(LC-1)
      LOCK=3*(KC-1)
      DO 650 L = 1,3
      DO 650 K = 1,3
  650 A(LOCK+K,LOCL+L) = T(K,L)
  660 CONTINUE
C
  700 CONTINUE
  800 CONTINUE
C
C     ----- END OF SYMMETRIZATION -----
C
      RETURN
      END
C*MODULE CPHF    *DECK CPWAB0
      SUBROUTINE CPWAB0(FCM,EH,NAT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION EH(9,*),FCM(*)
C
C     EXPAND HESSIAN TO FULL SQUARE STORAGE.
C
      DO 210 IAT=1,NAT
         DO 200 JAT=1,IAT
            IJAT=(IAT*(IAT-1))/2+JAT
            IJC=0
            DO 110 IC=1,3
               DO 100 JC=1,3
                  IJC=IJC+1
                  I=3*(IAT-1)+IC
                  J=3*(JAT-1)+JC
                  IJ=I+3*NAT*(J-1)
                  JI=J+3*NAT*(I-1)
                  FCM(IJ)=EH(IJC,IJAT)
                  FCM(JI)=EH(IJC,IJAT)
  100          CONTINUE
  110       CONTINUE
  200    CONTINUE
  210 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK CPWAB1
      SUBROUTINE CPWAB1(FCM,TA,E,IA,NOCC,NOCC2,NXYZ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION FCM(NXYZ,NXYZ),TA(NOCC2,NXYZ),E(*),IA(*)
C
      PARAMETER (ZERO=0.0D+00, EIGHT=8.0D+00)
C
C     ----- ADD (EI+EJ)*TA*TB CONTRIBUTION TO HESSIAN -----
C
      DO 210 IXYZ=1,NXYZ
         DO 200 JXYZ=1,IXYZ
            DUM=ZERO
            DO 110 IOCC=1,NOCC
               DO 100 JOCC=1,NOCC
                  IJ=IA(MAX(IOCC,JOCC))+MIN(IOCC,JOCC)
                  DUM=DUM+(E(IOCC)+E(JOCC))*TA(IJ,IXYZ)*TA(IJ,JXYZ)
  100          CONTINUE
  110       CONTINUE
            DUM=DUM*EIGHT
            FCM(IXYZ,JXYZ)=FCM(IXYZ,JXYZ)+DUM
            IF(JXYZ.EQ.IXYZ) GO TO 200
            FCM(JXYZ,IXYZ)=FCM(JXYZ,IXYZ)+DUM
  200    CONTINUE
  210 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK CPWAB2
      SUBROUTINE CPWAB2(FCM,AA,TA,IA,NOCC,NOCC2,NXYZ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION FCM(NXYZ,NXYZ),TA(NOCC2,NXYZ),AA(NOCC2,NXYZ),IA(*)
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- ADD T(A)*A(B) + T(B)*A(A) CONTRIBUTION TO HESSIAN -----
C
      DO 210 IXYZ=1,NXYZ
         DO 200 JXYZ=1,IXYZ
            DUM=ZERO
            DO 110 IOCC=1,NOCC
               DO 100 JOCC=1,NOCC
                  IJ=IA(MAX(IOCC,JOCC))+MIN(IOCC,JOCC)
                  DUM=DUM + TA(IJ,IXYZ)*AA(IJ,JXYZ)
     *                    + TA(IJ,JXYZ)*AA(IJ,IXYZ)
  100          CONTINUE
  110       CONTINUE
            FCM(IXYZ,JXYZ)=FCM(IXYZ,JXYZ)+DUM
            IF(JXYZ.EQ.IXYZ) GO TO 200
            FCM(JXYZ,IXYZ)=FCM(JXYZ,IXYZ)+DUM
  200    CONTINUE
  210 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK CPWAB3
      SUBROUTINE CPWAB3(FCM,WAX,YA,H,DDM,IA,NROT,NXYZ,NNXYZ,
     *                  NUM2,NOCC,NVIR)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL POLAR
C
      PARAMETER (MXATM=2000)
C
      DIMENSION FCM(NXYZ,NXYZ),WAX(NROT,NNXYZ),
     *          YA(NROT,NNXYZ),H(NUM2,3)
      DIMENSION DDM(9*NAT),IA(NUM)
      DIMENSION APOL(6)
C
      COMMON /CHFINF/ CHFSLV,CPTYPE,NWDCHF,POLAR
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
C
      PARAMETER (ZERO=0.0D+00, FOUR=4.0D+00)
C
C     ----- ADD FINAL CPHF WAX(A)*Y(B) CONTRIBUTION TO HESSIAN -----
C
      DO 210 IXYZ=1,NXYZ
         DO 200 JXYZ=1,NXYZ
            DUM=ZERO
            DO 100 IROT=1,NROT
               DUM=DUM+WAX(IROT,IXYZ)*YA(IROT,JXYZ)
  100       CONTINUE
            FCM(IXYZ,JXYZ)=FCM(IXYZ,JXYZ)+DUM
  200    CONTINUE
  210 CONTINUE
C
C     ---- GET TRANSFORMED DIPOLE INTEGRALS AND CALCULATE RESPONSE ----
C     ---- FACTOR CONTRIBUTION TO DIPOLE DERIVATIVE                ----
C
      CALL DAREAD(IDAF,IODA,H(1,1),NUM2,252,0)
      CALL DAREAD(IDAF,IODA,H(1,2),NUM2,253,0)
      CALL DAREAD(IDAF,IODA,H(1,3),NUM2,254,0)
C
      CALL VCLR(DDM,1,9*NAT)
C
      DO 340 IXYZ=1,NXYZ
         NN= 1 + (IXYZ-1)*3
         IROT=0
         DO 360 IVIR=1,NVIR
            DO 370 IOCC=1,NOCC
               IROT=IROT + 1
               IJ=IA(IVIR+NOCC)+IOCC
               DDM(NN  )=DDM(NN  )-(FOUR*YA(IROT,IXYZ)*H(IJ,1))
               DDM(NN+1)=DDM(NN+1)-(FOUR*YA(IROT,IXYZ)*H(IJ,2))
               DDM(NN+2)=DDM(NN+2)-(FOUR*YA(IROT,IXYZ)*H(IJ,3))
  370       CONTINUE
  360    CONTINUE
  340 CONTINUE
C
C     ---- CALCULATE ALPHA POLARIZABILITY TENSOR ----
C
      IF(POLAR) THEN
         DO 400 K=1,3
            DO 410 L=1,K
            KL=IA(K)+L
            APOL(KL)=ZERO
            IROT=0
               DO 420 IVIR=1,NVIR
                  DO 430 IOCC=1,NOCC
                     IROT=IROT + 1
                     IJ=IA(IVIR+NOCC)+IOCC
                     APOL(KL)=APOL(KL)-(FOUR*YA(IROT,NXYZ+K)*H(IJ,L))
  430             CONTINUE
  420          CONTINUE
  410       CONTINUE
  400 CONTINUE
C
C     ---- WRITE ALPHA POLARIZABILITY TENSOR TO DAF ----
C
      CALL DAWRIT(IDAF,IODA,APOL,6,251,0)
C
      END IF
C
      RETURN
      END
C*MODULE CPHF    *DECK CPWXYI
      SUBROUTINE CPWXYI(WXY,E,XX,IX,L1,NOCC,NVIR,NFTI,NINTMX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION WXY(NOCC,NVIR,NOCC,NVIR),E(L1),XX(NINTMX),IX(*)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (FOUR=4.0D+00)
C
C     ----- COMPUTE ORBITAL HESSIAN -WXY- MATRIX -----
C               USING AN IN MEMORY ALGORITHM
C
      CALL VCLR(WXY,1,NOCC*NVIR*NOCC*NVIR)
C
C     ----- READ IN MO INTEGRALS TO CREATE -WXY- MATRIX -----
C     TRANSFORMED INTEGRALS ASSUMED IN REVERSE CANONICAL ORDER
C
      CALL SEQREW(NFTI)
      IF(MASWRK) READ(NFTI)
  100 CONTINUE
      CALL PREAD(NFTI,XX,IX,NX,NINTMX)
      IF(NX.EQ.0) GO TO 300
      MX=IABS(NX)
      IF(MX.GT.NINTMX) GO TO 9000
C
C     ----- UNPACK LABELS AND PROCESS INTEGRALS -----
C
      DO 200 M = 1,MX
      VAL   = XX(M)
C
                       NPACK = M
                       IF (LABSIZ .EQ. 2) THEN
*I32                     LABEL1 = IX( 2*NPACK - 1 )
*I32                     LABEL2 = IX( 2*NPACK     )
*I32                     IPACK = ISHFT( LABEL1, -16 )
*I32                     JPACK = IAND( LABEL1, 65535 )
*I32                     KPACK = ISHFT( LABEL2, -16 )
*I32                     LPACK = IAND( LABEL2, 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
                       K = IPACK
                       L = JPACK
                       I = KPACK
                       J = LPACK
C
      II = MAX(I,J)
      JJ = MIN(I,J)
      KK = MAX(K,L)
      LL = MIN(K,L)
      IF(KK.LT.II) GO TO 180
      IF(KK.EQ.II.AND.LL.LE.JJ) GO TO 180
      NN = II
      II = KK
      KK = NN
      NN = JJ
      JJ = LL
      LL = NN
  180 CONTINUE
C
      IF(II.LE.NOCC) GO TO 200
      IF(JJ.LE.NOCC) GO TO 190
      IF(KK.GT.NOCC) GO TO 200
C
C     ----- ( VIR VIR / OCC OCC ) -----
C
      WXY(KK,II-NOCC,LL,JJ-NOCC)=WXY(KK,II-NOCC,LL,JJ-NOCC)-VAL
      IF(JJ.EQ.II.OR.LL.EQ.KK) GO TO 200
      WXY(LL,II-NOCC,KK,JJ-NOCC)=WXY(LL,II-NOCC,KK,JJ-NOCC)-VAL
      GO TO 200
C
C     ----- ( VIR OCC / VIR OCC ) -----
C
  190 CONTINUE
      IF(KK.LE.NOCC) GO TO 200
      IF(LL.GT.NOCC) GO TO 200
      WXY(JJ,II-NOCC,LL,KK-NOCC)=WXY(JJ,II-NOCC,LL,KK-NOCC)+VAL*FOUR
      IF(KK.EQ.II) THEN
         WXY(JJ,KK-NOCC,LL,II-NOCC)=WXY(JJ,KK-NOCC,LL,II-NOCC)-VAL
      ELSE
         WXY(LL,II-NOCC,JJ,KK-NOCC)=WXY(LL,II-NOCC,JJ,KK-NOCC)-VAL
      END IF
C
  200 CONTINUE
      IF(NX .GT. 0) GO TO 100
C
C         DONE WITH INTEGRAL CONTRIBUTIONS TO -WXY-
C
  300 CONTINUE
      CALL SEQREW(NFTI)
      IF(GOPARR) CALL GSUMCP(2102,WXY,NOCC*NVIR*NOCC*NVIR)
C
C     ----- COMPLETE -WXY- MATRIX CONSTRUCTION -----
C     ADD ORBITAL ENERGY TERM, AND SYMMETRIZE THE MATRIX
C
      DO 320 IVIR=1,NVIR
         DO 310 IOCC=1,NOCC
            WXY(IOCC,IVIR,IOCC,IVIR) = WXY(IOCC,IVIR,IOCC,IVIR)
     *                               + (E(IVIR+NOCC)-E(IOCC))
  310    CONTINUE
  320 CONTINUE
C
      DO 370 IVIR=1,NVIR
         DO 360 IOCC=1,NOCC
            DO 350 JVIR=1,IVIR
               JOMAX = NOCC
               IF(JVIR.EQ.IVIR) JOMAX = IOCC
               DO 340 JOCC=1,JOMAX
                  WXY(IOCC,IVIR,JOCC,JVIR) =
     *                                  FOUR*WXY(IOCC,IVIR,JOCC,JVIR)
                  WXY(JOCC,JVIR,IOCC,IVIR) = WXY(IOCC,IVIR,JOCC,JVIR)
  340          CONTINUE
  350       CONTINUE
  360    CONTINUE
  370 CONTINUE
      RETURN
C
 9000 IF (MASWRK) WRITE(6,9999) MX,NINTMX
      CALL ABRT
      STOP
C
 9999 FORMAT(1X,'*** ERROR, MX=',I10,' EXCEEDS NINTMX=',I10)
      END
C*MODULE CPHF    *DECK CPWXYO
      SUBROUTINE CPWXYO(WXY,E,XX,IX,IROT,WXYII,NROT,NWIDTH,L1,
     *                  NOCC,NVIR,NFTI,NINTMX,NFT16,DBG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK,SVDSKW
C
      DIMENSION WXY(NROT,NWIDTH),WXYII(NROT),IROT(L1,L1),E(L1),
     *          XX(NINTMX),IX(*)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (HALF=0.5D+00, FOUR=4.0D+00)
C
C     ----- COMPUTE ORBITAL HESSIAN -WXY- MATRIX -----
C             USING AN OUT OF MEMORY ALGORITHM
C
      MROT = 0
      DO 50 I=1,NOCC+NVIR
         DO 40 J=1,I
            IF(I.GT.NOCC  .AND.  J.LE.NOCC) THEN
               MROT = MROT+1
               IROT(I,J) = MROT
               IROT(J,I) = MROT
            ELSE
               IROT(I,J) = 0
               IROT(J,I) = 0
            END IF
   40    CONTINUE
   50 CONTINUE
      IF(MROT.NE.NROT) THEN
         IF(MASWRK) WRITE(IW,9030) MROT,NROT,NOCC,L1
         CALL ABRT
      END IF
C
      IF(MASWRK) REWIND NFT16
C
      KOL2 = 0
  100 CONTINUE
      KOL0 = KOL2
      KOL1 = KOL2 + 1
      KOL2 = KOL2 + NWIDTH
      IF(KOL2.GT.NROT) KOL2=NROT
      NCOL = KOL2 - KOL0
C
      CALL VCLR(WXY,1,NROT*NCOL)
C
C     ----- READ IN MO INTEGRALS TO CREATE -WXY- MATRIX -----
C     TRANSFORMED INTEGRALS ASSUMED IN REVERSE CANONICAL ORDER
C
      CALL SEQREW(NFTI)
      IF(MASWRK) READ(NFTI)
  170 CONTINUE
      CALL PREAD(NFTI,XX,IX,NX,NINTMX)
      IF(NX.EQ.0) GO TO 300
      MX=IABS(NX)
      IF(MX.GT.NINTMX) GO TO 9000
C
C     ----- UNPACK LABELS AND PROCESS INTEGRALS -----
C
      DO 200 M = 1,MX
      VAL   = XX(M)
C
                       NPACK = M
                       IF (LABSIZ .EQ. 2) THEN
*I32                     LABEL1 = IX( 2*NPACK - 1 )
*I32                     LABEL2 = IX( 2*NPACK     )
*I32                     IPACK = ISHFT( LABEL1, -16 )
*I32                     JPACK = IAND( LABEL1, 65535 )
*I32                     KPACK = ISHFT( LABEL2, -16 )
*I32                     LPACK = IAND( LABEL2, 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
                       K = IPACK
                       L = JPACK
                       I = KPACK
                       J = LPACK
C
      II = MAX(I,J)
      JJ = MIN(I,J)
      KK = MAX(K,L)
      LL = MIN(K,L)
      IF(KK.LT.II) GO TO 180
      IF(KK.EQ.II.AND.LL.LE.JJ) GO TO 180
      NN = II
      II = KK
      KK = NN
      NN = JJ
      JJ = LL
      LL = NN
  180 CONTINUE
      IF(II.LE.NOCC) GO TO 200
C
      IF(JJ.LE.NOCC) GO TO 190
      IF(KK.GT.NOCC) GO TO 200
C
C     ----- ( VIR VIR / OCC OCC ) -----
C
      IKROT = IROT(I,K)
      JLROT = IROT(J,L)
      IF(JLROT.GE.KOL1  .AND.  JLROT.LE.KOL2)
     *   WXY(IKROT,JLROT-KOL0) = WXY(IKROT,JLROT-KOL0) - VAL
      IF(IKROT.GE.KOL1  .AND.  IKROT.LE.KOL2)
     *   WXY(JLROT,IKROT-KOL0) = WXY(JLROT,IKROT-KOL0) - VAL
C
      IF(JJ.EQ.II.OR.LL.EQ.KK) GO TO 200
      ILROT = IROT(I,L)
      JKROT = IROT(J,K)
      IF(JKROT.GE.KOL1  .AND.  JKROT.LE.KOL2)
     *   WXY(ILROT,JKROT-KOL0) = WXY(ILROT,JKROT-KOL0) - VAL
      IF(ILROT.GE.KOL1  .AND.  ILROT.LE.KOL2)
     *   WXY(JKROT,ILROT-KOL0) = WXY(JKROT,ILROT-KOL0) - VAL
      GO TO 200
C
C     ----- ( VIR OCC / VIR OCC ) -----
C
  190 CONTINUE
      IF(KK.LE.NOCC) GO TO 200
      IF(LL.GT.NOCC) GO TO 200
      IJROT = IROT(I,J)
      KLROT = IROT(K,L)
      ILROT = IROT(I,L)
      JKROT = IROT(J,K)
      IF(KLROT.GE.KOL1  .AND.  KLROT.LE.KOL2)
     *   WXY(IJROT,KLROT-KOL0) = WXY(IJROT,KLROT-KOL0) + VAL*FOUR
      IF(IJROT.GE.KOL1  .AND.  IJROT.LE.KOL2)
     *   WXY(KLROT,IJROT-KOL0) = WXY(KLROT,IJROT-KOL0) + VAL*FOUR
      IF(JKROT.GE.KOL1  .AND.  JKROT.LE.KOL2)
     *   WXY(ILROT,JKROT-KOL0) = WXY(ILROT,JKROT-KOL0) - VAL
      IF(ILROT.GE.KOL1  .AND.  ILROT.LE.KOL2)
     *   WXY(JKROT,ILROT-KOL0) = WXY(JKROT,ILROT-KOL0) - VAL
C
  200 CONTINUE
      IF(NX .GT. 0) GO TO 170
C
C     ----- COMPLETE -WXY- MATRIX CONSTRUCTION -----
C     HALVE DIAGONAL, ADD ORBITAL ENERGY TERM, SCALE BY 4
C
  300 CONTINUE
      CALL SEQREW(NFTI)
      IF(GOPARR) CALL GSUMCP(2103,WXY,NROT*NCOL)
C
      MROT = 0
      DO 320 IVIR=1,NVIR
         DO 310 IOCC=1,NOCC
            MROT = MROT+1
            IF(MROT.LT.KOL1) GO TO 310
            IF(MROT.GT.KOL2) GO TO 310
            WXY(MROT,MROT-KOL0) = HALF*WXY(MROT,MROT-KOL0)
     *                          + (E(IVIR+NOCC)-E(IOCC))
  310    CONTINUE
  320 CONTINUE
C
      CALL DSCAL(NROT*NCOL,FOUR,WXY,1)
      IF(DBG) THEN
         WRITE(IW,9050) KOL1,KOL2
         CALL PRSQ(WXY,NCOL,NROT,NROT)
      END IF
C
      SVDSKW = DSKWRK
      DSKWRK = .FALSE.
      CALL SQWRIT(NFT16,WXY,NROT*NCOL)
      DSKWRK = SVDSKW
C
C         STORE DIAGONAL ELEMENT FOR LATER USE BY SOLVER
C
      DO 410 JROT=KOL1,KOL2
         WXYII(JROT) = WXY(JROT,JROT-KOL1+1)
  410 CONTINUE
      IF(KOL2.LT.NROT) GO TO 100
C
      IF(MASWRK) REWIND NFT16
      RETURN
C
 9000 IF (MASWRK) WRITE(IW,9999) MX,NINTMX
      CALL ABRT
      STOP
C
 9999 FORMAT(1X,'*** ERROR, MX=',I10,' EXCEEDS NINTMX=',I10)
 9050 FORMAT(1X,'SLICE OF -WXY- MATRIX FOR ROTATIONS',I5,' TO',I5)
 9030 FORMAT(1X,'UNEXPECTED INTERNAL TRAP ENCOUNTERED IN CPWXYO'/
     *       1X,'UNEXPECTEDLY, MROT.NE.NROT, MROT=',I10,' NROT=',I10/
     *       1X,'EXTRA INFO IS NOCC,L1=',2I10)
      END
C*MODULE CPHF    *DECK AOCPCL
      SUBROUTINE AOCPCL(WAX,C,YA,YNEW,RHS,DTEMP,FTEMP,EIG,WRK1,WRK2,
     *                  XX,IX,GHONDO,XINTS,DSH,DDIJ,NOCP,MODE,
     *                  NNXYZ,NUNIQ,NXYZF,NFOCK,NINT,NSCHWZ,
     *                  NROT,NOCC,NVIR,L1,L2,L3,NSH2,MAXG,MXG2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION WAX(NROT,NNXYZ),C(L1,L1),YA(NROT,NNXYZ),
     *          YNEW(NROT,NNXYZ),RHS(NROT,NUNIQ),
     *          DTEMP(NUNIQ*L2),FTEMP(NUNIQ*L2),
     *          WRK1(L1,L1),WRK2(L3),EIG(L1),NOCP(NNXYZ),
     *          GHONDO(MAXG),XINTS(NSH2),DSH(NSH2),DDIJ(49*MXG2),
     *          XX(*),IX(*)
C
C        --- CLOSED SHELL FOCK-LIKE MATRICES FOR CPHF EQUATIONS ---
C        WE CAN COMPUTE EITHER THE RIGHT HAND SIDE A*YA IN -RHS-
C        OR THE IMPROVED SOLUTION -YNEW- DEPENDING ON THE CALL -MODE-.
C        ONLY ONE OF -YNEW- OR -RHS- SHOULD BE ALLOCATED STORAGE.
C        THE VALUE -MODE- EQUALS 0 IS FOR THE DIIS SOLVER, WHILE
C        THE PCG SOLVER USES 1 AND 2 FOR ITS CALLS.
C
C        COUNT HOW MANY FOCK-LIKE MATRICES ARE NEEDED ON THIS ITERATION
C        -NXYZF- SHOULD BE LESS OR EQUAL TO -NUNIQ-
C
      NXYZF = 0
      DO 110 IXYZ = 1,NNXYZ
         IF (NOCP(IXYZ).EQ.0) NXYZF = NXYZF+1
  110 CONTINUE
      NFOCK = NFOCK+NXYZF
C
C        TRANSFORM CURRENT GUESS AT SOLUTION -YA- TO THE AO BASIS
C        THE RESULT ARE "DENSITY-LIKE MATRICES" STORED IN -DTEMP-
C
      IXYZF = 0
      IUNIQ = 0
      DO 270 IXYZ = 1,NNXYZ
         IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
         IF(NOCP(IXYZ).NE.0) GO TO 270
         IXYZF = IXYZF+1
C
                       IKOL = IXYZ
         IF(MODE.EQ.2) IKOL = IUNIQ
         CALL MRARTR(YA(1,IKOL),NOCC,NOCC,NVIR,C(1,NOCC+1),
     *               L1,L1,WRK2,L1)
         CALL MRARBR(C,L1,L1,NOCC,WRK2,L1,L1,WRK1,L1)
C
         IJ = 0
         DO 260 I=1,L1
            DO 250 J=1,I
               DTEMP(IXYZF+IJ) = WRK1(I,J) + WRK1(J,I)
               IJ = IJ + NXYZF
  250       CONTINUE
  260    CONTINUE
  270 CONTINUE
C
C  BUILD THE CORRESPONDING "FOCK-LIKE MATRICES" IN -FTEMP-
C
      CALL AOFLM2(DTEMP,FTEMP,GHONDO,XINTS,DSH,DDIJ,XX,IX,
     *            L1,NXYZF,MAXG,NSH2,MXG2,NINT,NSCHWZ)
C
C  TRANSFORM BACK INTO THE MO BASIS
C
      IXYZF = 0
      IUNIQ = 0
      DO 390 IXYZ = 1,NNXYZ
         IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
         IF(NOCP(IXYZ).NE.0) GO TO 390
C
         IXYZF = IXYZF+1
         CALL DCOPY(L2,FTEMP(IXYZF),NXYZF,WRK1,1)
         CALL EXPND(WRK1,WRK2,L1,0)
         CALL MRARBR(WRK2,L1,L1,L1,C(1,NOCC+1),L1,NVIR,WRK1,L1)
         CALL MRTRBR(C,L1,L1,NOCC,WRK1,L1,NVIR,WRK2,NOCC)
C
C     FORM THE NEW RESPONSE VECTOR.
C     NOTE THAT THE FACTOR OF 8 IS THE 2 FROM EQUATION 13 AND
C     ANOTHER TWO TAKING INTO ACCOUNT THE SYMMETRY OF THE TRANSFORMATION
C     (HAVE TWO TERMS THAT ARE SYMMETRIC, I CALCULATED ONE
C      AND NEED TO MULTIPLY BY TWO WHICH I AM DOING HERE)
C
         IF(MODE.EQ.0) THEN
            IJ = 0
            DO 320 IVIR = NOCC+1,NOCC+NVIR
               DO 310 IOCC= 1,NOCC
                  IJ = IJ + 1
                  YNEW(IJ,IXYZ) = (-WAX(IJ,IXYZ) - 8.0D+00*WRK2(IJ)) /
     *                            (4.0D+00*(EIG(IVIR) - EIG(IOCC)))
  310          CONTINUE
  320       CONTINUE
         ELSE
            IJ = 0
                          IKOL = IXYZ
            IF(MODE.EQ.2) IKOL = IUNIQ
            DO 360 IVIR = NOCC+1,NOCC+NVIR
               DO 350 IOCC= 1,NOCC
                  IJ = IJ + 1
                  RHS(IJ,IUNIQ) = 8.0D+00*WRK2(IJ)
     *                  + (4.0D+00*(EIG(IVIR) - EIG(IOCC)))*YA(IJ,IKOL)
  350          CONTINUE
  360       CONTINUE
         END IF
  390 CONTINUE
C
      RETURN
      END
C*MODULE CPHF    *DECK AOSHLD
      SUBROUTINE AOSHLD(D,DSH,IA,L1,L2,NSH2,NFO)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION D(NFO,L2),DSH(NSH2),IA(L1)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- COMPRESS DENSITY OVER AOS TO DENSITY OVER SHELLS -----
C
      IJSH=0
      DO 240 ISH=1,NSHELL
         MINI = KLOC(ISH)
         MAXI = MINI + KMAX(ISH) - KMIN(ISH)
         DO 230 JSH=1,ISH
            MINJ = KLOC(JSH)
            MAXJ = MINJ + KMAX(JSH) - KMIN(JSH)
            IJSH = IJSH+1
            DMAX = ZERO
            DO 130 I=MINI,MAXI
               IF(ISH.EQ.JSH) MAXJ=I
               DO 120 J=MINJ,MAXJ
                  IJ = IA(I) + J
                  DO 110 IFO=1,NFO
                     IF(ABS(D(IFO,IJ)).GT.DMAX) DMAX = ABS(D(IFO,IJ))
  110             CONTINUE
  120          CONTINUE
  130       CONTINUE
            DSH(IJSH) = DMAX
  230    CONTINUE
  240 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK AOFLM2
      SUBROUTINE AOFLM2(PMN,FMN,GHONDO,XINTS,DSH,DDIJ,BUF,IBUF,
     *                  NBF,NXYZ,MAXG,NSH2,MXG2,NINT,NSCHWZ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL PACK2E,SCHWRZ,DIRSCF,FDIFF,SHLOUT,TDSKWRK
C
      DIMENSION PMN(*), FMN(*), GHONDO(MAXG), XINTS(NSH2), DSH(NSH2),
     *          DDIJ(49*MXG2), BUF(NINTMX), IBUF(NINTMX)
C
      PARAMETER (MXSH=5000, MXATM=2000, MXAO=8192)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SHLT  / SHLTOL,CUTOFF,ICOUNT,SHLOUT
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
      PARAMETER (HALF=0.5D+00)
C
      DATA RHF/8HRHF     /
C
C           NOW FORM FOCK-LIKE MATRIX
C           DIRECT METHOD = RECOMPUTE 2E- AO INTEGRALS
C           STANDARD METHOD = PROCESS INTEGRALS FROM DISK
C           WE NEED TO TEMPORARILY TURN OFF SYMMETRY
C
      NTTEMP = NT
      NT = 1
      L1 = NBF
      L2 = (NBF*NBF+NBF)/2
      NINT  =0
      NSCHWZ=0
C
      IF(DIRSCF) THEN
         SCHWRZ = ISCHWZ.EQ.1
         IF(SCHWRZ) THEN
            CALL DAREAD(IDAF,IODA,XINTS,NSH2,54,0)
            CALL AOSHLD(PMN,DSH,IA,L1,L2,NSH2,NXYZ)
         END IF
         CALL VCLR(FMN,1,NXYZ*L2)
         CUTSV  = CUTOFF
         CUTOFF = MIN(CUTOFF,1.0D-10)
         CALL TWOEI(RHF,DIRSCF,.FALSE.,.FALSE.,.FALSE.,
     *              INTTYP,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *              DUMMY,DUMMY,IDUMMY,1,XINTS,NSH2,GHONDO,
     *              MAXG,DDIJ,IA,PMN,FMN,DUMMY,DUMMY,DSH,
     *              DUMMY,DUMMY,NXYZ)
         CUTOFF = CUTSV
         CALL DSCAL(NXYZ*L2,HALF,FMN,1)
         II=0
         DO 210 I=1,L1
            II = II+I
            IJ = (II-1)*NXYZ+1
            DO 200 J=0,NXYZ-1
               FMN(IJ+J) = FMN(IJ+J) + FMN(IJ+J)
  200       CONTINUE
  210    CONTINUE
C
      ELSE
         TDSKWRK = DSKWRK
         DSKWRK  = .TRUE.
         CALL SEQREW(IJK)
         CALL AOHST2(PMN,FMN,BUF,IBUF,NINTMX,IA,NOPK,NXYZ)
         DSKWRK  = TDSKWRK
      END IF
C
C   --- SUM UP PARTIAL FOCK MATRICES ---
C
      IF(GOPARR) THEN
         CALL DDI_GSUMF(1000,FMN   ,NXYZ*L2)
         CALL DDI_GSUMI(1001,NINT  ,1)
         CALL DDI_GSUMI(1002,NSCHWZ,1)
      END IF
C
C        RESTORE THE VALUE OF NT (SYMMETRY)
C
      NT = NTTEMP
      RETURN
      END
C*MODULE CPHF    *DECK AOHST2
      SUBROUTINE AOHST2(D,F,XX,IX,NINTMX,IA,NOPK,NXYZ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
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
C
      DIMENSION D(NXYZ,*),F(NXYZ,*),IA(*),XX(NINTMX),IX(*)
C
      PARAMETER (HALF=0.5D+00)
C
C     ----- ROUTINE HSTAR FORMS THE SKELETON MATRIX
C                   F=( H' + H )/2
C
C              F(I,J)=(H**(I,J) + H**(J,I))/2
C
C     INDICES IN LABELS ARE IN STANDARD ORDER_
C      I.GE.J , K.GE.L , (IJ).GE.(KL)
C
C     ALL CONTRIBUTIONS ARE MADE INTO LOWER HALF OF
C     SKELETON MATRIX.
C     ONLY OFF-DIAGONAL ELEMENTS NEED BE DIVIDED BY TWO,
C     TO OBTAIN THE CORRECT F MATRIX.
C
      NUMTRI = NXYZ*(NUM*NUM+NUM)/2
      CALL VCLR(F,1,NUMTRI)
      I = 0
      J = 0
      K = 0
      L = 0
      NXX = 0
*I64  MASK32 = 2**32 - 1
      IF (NOPK .NE. 1) GO TO 300
C
C     ----- INTEGRALS ARE NOT IN SUPERMATRIX FORM (NOPK=.TRUE.) -----
C
  120 CONTINUE
      CALL PREAD(IS,XX,IX,NXX,NINTMX)
      IF (NXX .EQ. 0) GO TO 220
      NINT = IABS(NXX)
      IF (NINT .GT. NINTMX) CALL ABRT
      DO 200 M = 1,NINT
C
                       NPACK = M
                       IF (LABSIZ .EQ. 2) THEN
*I32                     LABEL1 = IX( 2*NPACK - 1 )
*I32                     LABEL2 = IX( 2*NPACK     )
*I32                     IPACK = ISHFT( LABEL1, -16 )
*I32                     JPACK = IAND( LABEL1, 65535 )
*I32                     KPACK = ISHFT( LABEL2, -16 )
*I32                     LPACK = IAND( LABEL2, 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(M)
         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
      VAL4 = (VAL+VAL)+(VAL+VAL)
      DO 190 IXYZ=1,NXYZ
        F(IXYZ,NIJ) = F(IXYZ,NIJ)+VAL4*D(IXYZ,NKL)
        F(IXYZ,NKL) = F(IXYZ,NKL)+VAL4*D(IXYZ,NIJ)
        F(IXYZ,NIK) = F(IXYZ,NIK)-VAL*D(IXYZ,NJL)
        F(IXYZ,NIL) = F(IXYZ,NIL)-VAL*D(IXYZ,NJK)
        F(IXYZ,NJK) = F(IXYZ,NJK)-VAL*D(IXYZ,NIL)
        F(IXYZ,NJL) = F(IXYZ,NJL)-VAL*D(IXYZ,NIK)
  190 CONTINUE
  200 CONTINUE
C
      IF (NXX .GT. 0) GO TO 120
C
C     DONE CONSTRUCTING MATRIX, OFF DIAGONAL ELEMENTS NEED HALVING
C
  220 CONTINUE
      CALL DSCAL(NUMTRI,HALF,F,1)
      II = 0
      DO 260 I=1,NUM
        II = II + I
        DO 250 IXYZ=1,NXYZ
           F(IXYZ,II) = F(IXYZ,II)+F(IXYZ,II)
  250   CONTINUE
  260 CONTINUE
      CALL SEQREW(IS)
      RETURN
C     ******
C
C     ----- INTEGRALS ARE IN SUPERMATRIX FORM (NOPK=.FALSE.) -----
C
  300 CONTINUE
      NIJ=0
      DO 310 M = 1,NUM
        NIJ = NIJ+M
        DO 305 IXYZ=1,NXYZ
          D(IXYZ,NIJ) = D(IXYZ,NIJ)*HALF
  305  CONTINUE
  310 CONTINUE
C
C     ---- SCALAR PROCESSING OF THE P INTEGRAL FILE -----
C
  320 CONTINUE
      CALL PREAD(IS,XX,IX,NXX,NINTMX)
      IF (NXX .EQ. 0) GO TO 400
C
      NINT = IABS(NXX)
      IF (NINT .GT. NINTMX) CALL ABRT
C
      DO 330 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
         VAL = XX(M)
         DO 325 IXYZ=1,NXYZ
           F(IXYZ,NIJ) = F(IXYZ,NIJ) + VAL*D(IXYZ,NKL)
           F(IXYZ,NKL) = F(IXYZ,NKL) + VAL*D(IXYZ,NIJ)
  325    CONTINUE
  330 CONTINUE
      IF (NXX .GT. 0) GO TO 320
C
C     ----- RESTORE DENSITY MATRIX, HALVE FOCK MATRIX -----
C
  400 CONTINUE
      NIJ = 0
      DO 410 M = 1,NUM
        NIJ = NIJ+M
        DO 405 IXYZ=1,NXYZ
          D(IXYZ,NIJ) = D(IXYZ,NIJ)+D(IXYZ,NIJ)
  405   CONTINUE
  410 CONTINUE
C
      CALL DSCAL(NUMTRI,HALF,F,1)
      CALL SEQREW(IS)
      RETURN
      END
C*MODULE CPHF    *DECK AOCPCG
      SUBROUTINE AOCPCG(WAX,YA,RESID,ZRES,PDIR,
     *                  PRECND,BNORM,BKNUM,BKDEN,
     *                  VEC,EIG,DTEMP,FTEMP,WRK1,WRK2,
     *                  NOCP,GHONDO,XINTS,DSH,DDIJ,XX,IX,
     *                  NNXYZ,NUNIQ,NFOCK,NROT,NOCC,NVIR,
     *                  L1,L2,L3,NSH2,MAXG,MXG2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION WAX(NROT,NNXYZ),YA(NROT,NNXYZ),RESID(NROT,NUNIQ),
     *          ZRES(NROT,NUNIQ),PDIR(NROT,NUNIQ),PRECND(NROT),
     *          BNORM(NNXYZ),BKNUM(NNXYZ),BKDEN(NNXYZ),
     *          VEC(L1,L1),EIG(L1),DTEMP(NUNIQ,L2),FTEMP(NUNIQ,L2),
     *          WRK1(L1,L1),WRK2(L1,L1),NOCP(NNXYZ),
     *          GHONDO(MAXG),XINTS(NSH2),DSH(NSH2),DDIJ(49*MXG2),
     *          XX(*),IX(*)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,DIRSCF,FDIFF
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00, TOL=5.0D-05)
C
      DATA MAXIT/50/
C
C        --- SOLVE MULTIPLE SETS OF LINEAR EQUATIONS A*YA+WAX=0 ---
C        THIS ROUTINE USES THE ORDINARY PRECONDITIONED CONJUGATE
C        GRADIENT PROCEDURE.  NOTE THAT "ORDINARY" MEANS -A- IS A
C        POSITIVE DEFINITE SYMMETRIC MATRIX, I.E. THE ORBITAL HESSIAN.
C        THE DIMENSION OF -A- IS -NROT-, AND THERE ARE -NNXYZ- COLUMNS
C        IN BOTH THE INHOMOGENEITY (WHICH IS THE NEGATIVE OF -WAX-)
C        AND IN THE -YA- RESPONSE VECTORS BEING SOLVED FOR.  ONLY
C        -NUNIQ- RESPONSES ARE REQUIRED, DEPENDING ON SYMMETRY, WITH
C        THE LIST -NOCP- NAMING WHICH RESPONSES ARE ACTUALLY NEEDED.
C
C        WRITTEN BY MIKE SCHMIDT, AT TOKYO TORITSU DAIGAKU, JAN 2001.
C        THIS ROUTINE WAS INSPIRED BY -DCG- WRITTEN BY ANNE GREENBAUM
C        AND MARK SEEGER, IN THE SPARSE LINEAR ALGEBRA PACKAGE -SLAP-
C        WHICH WAS DOWNLOADED FROM NETLIB.
C        EXTENSIVE MODIFICATIONS HAVE BEEN MADE, EXCEPT TO THE ACTUAL
C        SOLVING TECHNIQUE, TO SUPPORT THE NEEDS OF QUANTUM CHEMISTRY.
C        MULTIPLE SOLUTIONS ARE SOUGHT, WITH THE A*YA MULTIPLICATIONS
C        DONE SIMULTANEOUSLY, ALTHOUGH EACH SOLVING REMAINS SEPARATE.
C        THE PRECONDITIONER CHOSEN IS THE RECIPROCAL OF THE DIAGONAL
C        ELEMENTS, APPROXIMATED IN THE SAME WAY AS GALINA CHABAN'S
C        SECOND ORDER SCF CONVERGER, SEE EQUATION 1.17 IN G.CHABAN,
C        M.W.SCHMIDT, M.S.GORDON, THEORET.CHIM.ACTA 97, 88-95(1997).
C        NOTE THAT AN APPROXIMATION IS NEEDED SINCE THE MATRIX A IS
C        NEVER GENERATED, INSTEAD PRODUCTS A*YA ARE FORMED DIRECTLY.
C        THE INITIAL GUESS WAS SUGGESTED BY JAN JENSEN, IT AMOUNTS
C        TO ASSUMING THE INITIAL RESPONSES ARE ZERO SO THAT THE
C        INTEGRAL CONTRIBUTIONS TO THE A MATRIX VANISH, LEAVING A
C        SIMPLE REARRANGEMENT TO PRODUCE THE INITIAL GUESS USED HERE.
C        CONVERGENCE CRITERION WAS SELECTED BY NUMERICAL EXPERIMENT.
C        FOR FURTHER INFORMATION, SEE THE COMMENTS IN THE ORIGINAL
C        SLAP LIBRARY ROUTINES, AND THE "NUMERICAL RECIPES" BOOK.
C        ANOTHER INTERESTING REFERENCE IS P.E.S.WORMER, F.VISSER,
C        J.PALDUS, J.COMPUT.PHYS. 48, 23-44(1982).
C
C        SET UP PRECONDITIONER AND INITIAL GUESS OF RESPONSES
C
      IROT = 0
      DO 130 IVIR = NOCC+1,NOCC+NVIR
         DO 120 IOCC= 1,NOCC
            IROT = IROT + 1
            PRECND(IROT) = 1.0D+00/(4.0D+00*(EIG(IVIR) - EIG(IOCC)))
            FACTOR = -PRECND(IROT)
            DO 110 IXYZ = 1,NNXYZ
               YA(IROT,IXYZ) = FACTOR * WAX(IROT,IXYZ)
  110       CONTINUE
  120    CONTINUE
  130 CONTINUE
C
C         THE INITIAL ITERATION IS DONE BEFORE THE MAIN LOOP,
C         CALCULATE INITIAL ITERATION'S RESIDUAL -RESID-
C
      NFOCK = 0
      MODE = 1
      DUMMY = ZERO
      ITER=1
      CALL AOCPCL(WAX,VEC,YA,DUMMY,RESID,DTEMP,FTEMP,EIG,WRK1,WRK2,
     *            XX,IX,GHONDO,XINTS,DSH,DDIJ,NOCP,MODE,
     *            NNXYZ,NUNIQ,NXYZF,NFOCK,NINT,NSCHWZ,
     *            NROT,NOCC,NVIR,L1,L2,L3,NSH2,MAXG,MXG2)
C
      IUNIQ=0
      DO 160 IXYZ=1,NNXYZ
         IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
         IF(NOCP(IXYZ).NE.0) GO TO 160
         DO 150 IROT=1,NROT
            RESID(IROT,IUNIQ) =  -WAX(IROT,IXYZ) - RESID(IROT,IUNIQ)
  150    CONTINUE
  160 CONTINUE
C
C        CALCULATE INITIAL PSEUDORESIDUAL -ZRES-, CHECK CONVERGENCE
C
      ERR = ZERO
      IUNIQ=0
      DO 210 IXYZ=1,NNXYZ
         IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
         IF(NOCP(IXYZ).NE.0) GO TO 210
         DO IROT=1,NROT
            ZRES(IROT,IUNIQ) = PRECND(IROT)*RESID(IROT,IUNIQ)
         ENDDO
         BNORM(IXYZ)=SQRT(DDOT(NROT,  WAX(1, IXYZ),1,  WAX(1, IXYZ),1))
         RNORM      =SQRT(DDOT(NROT,RESID(1,IUNIQ),1,RESID(1,IUNIQ),1))
         TEST = RNORM/BNORM(IXYZ)
         IF(TEST.LT.TOL) NOCP(IXYZ)=2
         ERR = MAX(ERR,TEST)
  210 CONTINUE
      IF(MASWRK) THEN
         WRITE(IW,9000) TOL
         IF(DIRSCF) THEN
            WRITE(IW,9010)
            WRITE(IW,9020) ITER,ERR,NXYZF,NINT,NSCHWZ
         ELSE
            WRITE(IW,9030)
            WRITE(IW,9020) ITER,ERR,NXYZF
         END IF
         CALL FLSHBF(IW)
      END IF
      IF(ERR.LT.TOL) GO TO 800
C
C        THE REMAINING CG ITERATIONS START NOW...
C
      MODE=2
      BKDEN(1) = 1.0D+00   ! REMOVES SPURIOUS FTNCHEK COMPLAINT
      DO 400 ITER=2,MAXIT
C
C           CALCULATE COEFFICIENT -BK- AND DIRECTION VECTOR -PDIR-
C
         IUNIQ=0
         DO 320 IXYZ=1,NNXYZ
            IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
            IF(NOCP(IXYZ).NE.0) GO TO 320
            BKNUM(IXYZ) = DDOT(NROT,ZRES(1,IUNIQ),1,RESID(1,IUNIQ),1)
            IF(BKNUM(IXYZ).LE.-TOL) THEN
               IF(MASWRK) WRITE(IW,9040)
               CALL ABRT
            END IF
            IF(ITER.EQ.2) THEN
               CALL DCOPY(NROT,ZRES(1,IUNIQ),1,PDIR(1,IUNIQ),1)
            ELSE
               BK = BKNUM(IXYZ)/BKDEN(IXYZ)
               DO IROT=1,NROT
                  PDIR(IROT,IUNIQ) =    ZRES(IROT,IUNIQ)
     *                             + BK*PDIR(IROT,IUNIQ)
               ENDDO
            END IF
            BKDEN(IXYZ) = BKNUM(IXYZ)
  320    CONTINUE
C
C           CALCULATE COEFFICIENT -AK-, NEW ITERATE -YA-,
C           NEW RESIDUAL -RESID-, AND NEW PSEUDO-RESIDUAL -ZRES-.
C
         CALL AOCPCL(WAX,VEC,PDIR,DUMMY,ZRES,DTEMP,FTEMP,EIG,WRK1,WRK2,
     *               XX,IX,GHONDO,XINTS,DSH,DDIJ,NOCP,MODE,
     *               NNXYZ,NUNIQ,NXYZF,NFOCK,NINT,NSCHWZ,
     *               NROT,NOCC,NVIR,L1,L2,L3,NSH2,MAXG,MXG2)
C
         ERR = ZERO
         IUNIQ=0
         DO 340 IXYZ=1,NNXYZ
            IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
            IF(NOCP(IXYZ).NE.0) GO TO 340
            AKDEN = DDOT(NROT,PDIR(1,IUNIQ),1,ZRES(1,IUNIQ),1)
C
C              THIS TERMINATION IS SUPPOSED TO BE DUE TO THE
C              MATRIX -A-'S NOT BEING POSITIVE DEFINITE.  A TEST
C              CALCULATION SHOWED THAT A CASE WITH UHF INSTABILITY
C              DID NOT GET INTO THIS ERROR TERMINATION SECTION,
C              SO AN INSTABILITY IN THE ORBITAL HESSIAN MAY BE A
C              NECESSARY BUT NOT SUFFICIENT CONDITION TO GET HERE.
C
            IF(AKDEN.LE.-TOL) THEN
               IF(MASWRK) WRITE(IW,9050)
               IF(MASWRK) WRITE(IW,9060)
               CALL ABRT
            END IF
            AK = BKNUM(IXYZ)/AKDEN
            CALL DAXPY(NROT, AK,PDIR(1,IUNIQ),1,   YA(1, IXYZ),1)
            CALL DAXPY(NROT,-AK,ZRES(1,IUNIQ),1,RESID(1,IUNIQ),1)
            DO IROT=1,NROT
               ZRES(IROT,IUNIQ) = PRECND(IROT)*RESID(IROT,IUNIQ)
            ENDDO
C
C              CHECK CONVERGENCE
C
            RNORM = SQRT(DDOT(NROT,RESID(1,IUNIQ),1,RESID(1,IUNIQ),1))
            TEST = RNORM/BNORM(IXYZ)
            IF(TEST.LT.TOL) NOCP(IXYZ)=2
            ERR = MAX(ERR,TEST)
  340    CONTINUE
         IF(MASWRK) THEN
            IF(DIRSCF) THEN
               WRITE(IW,9020) ITER,ERR,NXYZF,NINT,NSCHWZ
            ELSE
               WRITE(IW,9020) ITER,ERR,NXYZF
            END IF
            CALL FLSHBF(IW)
         END IF
         IF(ERR.LT.TOL) GO TO 800
  400 CONTINUE
C
C        CALCULATION DID NOT CONVERGE AFTER TOO MANY CYCLES.
C
      IF(MASWRK) WRITE(IW,9070) MAXIT
      IF(MASWRK) WRITE(IW,9060)
      CALL ABRT
      STOP
C
C        PRINT CONVERGENCE MESSAGE, RESTORE ORIGINAL -NOCP- ARRAY
C
  800 CONTINUE
      IF(MASWRK) WRITE(IW,9080) ITER,NFOCK,NUNIQ
      DO IXYZ=1,NNXYZ
         IF(NOCP(IXYZ).EQ.2) NOCP(IXYZ)=0
      ENDDO
      RETURN
C
 9000 FORMAT(1X,'PRECONDITIONED CONJUGATE GRADIENT SOLVER',5X,
     *          'CONV. TOLERANCE=',1P,E8.2)
 9010 FORMAT(1X,12X,'MAXIMUM',10X,'RESPONSES',8X,'NONZERO',5X,'BLOCKS'/
     *       1X,'ITER',4X,'RESPONSE ERROR',8X,'IMPROVED',3X,
     *          'AO INTEGRALS',4X,'SKIPPED')
 9020 FORMAT(1X,I3,5X,1P,E13.5,0P,8X,I6,3X,I15,I11)
 9030 FORMAT(1X,'ITER',4X,'RESPONSE ERROR',8X,'IMPROVED')
 9040 FORMAT(1X,'THE PRECONDITIONER IS NOT POSITIVE DEFINITE.'/
     *       1X,'THIS MAY BE DUE TO PECULIAR ORBITAL ENERGIES.')
 9050 FORMAT(//1X,'THE ORBITAL HESSIAN IS NOT POSITIVE DEFINITE.'//)
 9060 FORMAT(1X,'MOST OFTEN THIS IS',
     *          ' CAUSED BY USE OF AN INAPPROPRIATE WAVEFUNCTION.'/
     *       1X,'CHANGE SCFTYP, OR CHECK HOMO/LUMO FILLING ORDER.'//)
 9070 FORMAT(//1X,'*** TOO MANY ITERATIONS IN AOCPCG *** MAXIT=',I5/
     *       1X,'THIS VALUE CANNOT BE RAISED BY THE INPUT BECAUSE'/
     *       1X,'MORE CPHF ITERATIONS ARE UNLIKELY TO HELP.'//)
 9080 FORMAT(1X,'THE CPHF HAS CONVERGED AFTER',I3,' ITERATIONS.'/
     *       1X,'IT REQUIRED',I6,' FOCK-LIKE BUILDS TO FIND THE',I4,
     *          ' SYMMETRY UNIQUE RESPONSES.')
      END
C*MODULE CPHF    *DECK AOCPDI
      SUBROUTINE AOCPDI(WAX,VEC,YA,YNEW,DTEMP,FTEMP,EIG,WRK1,WRK2,
     *                  ERR,ADIIS,XDIIS,IPVT,BDIIS,IODIIS,
     *                  XX,IX,GHONDO,XINTS,DSH,DDIJ,NOCP,
     *                  NROT,NNXYZ,NUNIQ,NOCC,NVIR,L1,L2,L3,
     *                  MAXIT,MAXIT2,MAXIO,MAXG,NSH2,MXG2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL CVGD,NOTOPN,GOPARR,DSKWRK,MASWRK
C            DTEMP/FTEMP DOUBLE AS WORK STORAGE FOR CPDIIS, SEE BELOW.
      DIMENSION WAX(NROT,NNXYZ),VEC(L1,L1),YA(NROT,NNXYZ),
     *          YNEW(NROT,NNXYZ),DTEMP(NUNIQ*L2),FTEMP(NUNIQ*L2),
     *          ERR(NROT,NNXYZ),WRK1(L1,L1),WRK2(L3),XX(*),IX(*),
     *          EIG(L1),ADIIS(MAXDII,MAXDII),XDIIS(MAXIT),IPVT(MAXIT),
     *          BDIIS(MAXIT2,NNXYZ),IODIIS(MAXIO),NOCP(NNXYZ),
     *          GHONDO(MAXG),XINTS(NSH2),DSH(NSH2),DDIJ(49*MXG2)
C
      COMMON /DIISSO/ SOGTOL,ETHRSH,MAXDII,IRAF
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (FOUR=4.0D+00, ZERO=0.0D+00, TOL=1.0D-10)
C
C     ----- SOLVE RHF RESPONSE EQUATIONS USING AO BASIS INTEGRALS -----
C     ON ENTRY, -WAX- IS THE USUAL INHOMOGENEITY, UNCHANGED ON EXIT.
C     ON EXIT, -YA- ARE THE USUAL CPHF RESPONSES, IN THE MO BASIS.
C
C     START WITH A GUESS OF YA = -WAX/4(EI-EJ) DUE TO JAN JENSEN.
C     THIS GUESS AMOUNTS TO THE ASSUMPTION THAT -YA- IS ZERO DURING
C     AN INITIAL ITERATION, SO THE INTEGRAL TERM VANISHES FROM
C     THE RESPONSE EQUATIONS.
C
      IROT = 0
      DO 22 IVIR = NOCC+1,NOCC+NVIR
         DO 21 IOCC= 1,NOCC
            IROT = IROT + 1
            FACTOR = -1.0D+00/(FOUR*(EIG(IVIR) - EIG(IOCC)))
            DO 20 IXYZ = 1,NNXYZ
               YA(IROT,IXYZ) = FACTOR * WAX(IROT,IXYZ)
   20       CONTINUE
   21    CONTINUE
   22 CONTINUE
C
      ERDIIS = ZERO
      NOTOPN = .TRUE.
      NFOCK = 0
      ITDIIS = 1
      ITER = 0
C
C     BEGIN DIIS ITERATIONS...
C
   30 CONTINUE
      ITER = ITER + 1
C
C        FORM PRODUCTS A*YA, AND PRODUCE IMPROVED RESPONSES YNEW
C
      MODE = 0
      DUMMY =0.0D+00
      CALL AOCPCL(WAX,VEC,YA,YNEW,DUMMY,DTEMP,FTEMP,EIG,WRK1,WRK2,
     *            XX,IX,GHONDO,XINTS,DSH,DDIJ,NOCP,MODE,
     *            NNXYZ,NUNIQ,NXYZF,NFOCK,NINT,NSCHWZ,
     *            NROT,NOCC,NVIR,L1,L2,L3,NSH2,MAXG,MXG2)
C
C        RUN DIIS EXTRAPOLATION, SO MUST FIRST GET THE ERROR MATRIX
C
      DO 260 IXYZ = 1, NNXYZ
         IF (NOCP(IXYZ).NE.0) GO TO 260
         DO 250 IJ = 1,NROT
            ERR(IJ,IXYZ) = YNEW(IJ,IXYZ) - YA(IJ,IXYZ)
  250    CONTINUE
  260 CONTINUE
C
C  THIS IS SNEAKY: -DTEMP- AND -FTEMP- ARE CONSECUTIVE STORAGE,
C  AND ARE NO LONGER NEEDED BY THIS ITERATION.  THEREFORE THEY
C  ARE PASSED TO -CPDIIS- TO BE ITS NROT*NNXYZ WORKING VECTOR.
C  THIS MAY EXCEED 2*NUNIQ*L2, SO ALLOCATOR HAS TO TAKE -MAX-.
C
      CALL CPDIIS(IW,ITDIIS,YNEW,ERR,DTEMP,ADIIS,XDIIS,IPVT,
     *            BDIIS,IODIIS,NOCP,MAXIT,MAXIT2,MAXIO,
     *            ERDIIS,NOTOPN,NROT,NOCC,NVIR,NNXYZ)
      IF(MASWRK) THEN
         WRITE(IW,9020) ITER,NXYZF,ERDIIS
         CALL FLSHBF(IW)
      END IF
C
C  CHECK THE CONVERGENCE
C
      CVGD = .TRUE.
      DO 310 IXYZ=1,NNXYZ
         IF (NOCP(IXYZ).NE.0) GO TO 310
         DEL = 0
         DO 300 IJ = 1,NROT
            DEL = DEL + (YNEW(IJ,IXYZ) - YA(IJ,IXYZ))**2
            YA(IJ,IXYZ) = YNEW(IJ,IXYZ)
  300    CONTINUE
         DEL = SQRT(DEL/NROT)
         IF (DEL.GT.TOL) THEN
            CVGD=.FALSE.
         ELSE
            IF(NOCP(IXYZ).EQ.0) NOCP(IXYZ)=2
         END IF
  310 CONTINUE
C
C         NOTE THAT ITDIIS EXCEEDS MAXIT BY ONE IN -CPDIIS-
C
      IF(ITER.GE.MAXIT-1) THEN
         IF(MASWRK) WRITE(IW,9030) ITER
         CALL ABRT
         STOP
      END IF
      IF (.NOT.CVGD) GO TO 30
C
C     DIIS HAS CONVERGED...
C
      IF(MASWRK) WRITE(IW,9040) ITER,NFOCK,NUNIQ
      CALL RACLOS(IRAF,'DELETE')
      NOTOPN=.TRUE.
C
C  RESTORE THE NOCP VECTOR
C
      DO 800 I=1,NNXYZ
         IF(NOCP(I).EQ.2) NOCP(I)=0
  800 CONTINUE
      RETURN
C
 9020 FORMAT(1X,'CPHF ITER',I3,' IMPROVED',I4,
     *          ' RESPONSES, MAXIMUM RESPONSE ERROR=',1P,E13.5)
 9030 FORMAT(5X,'WARNING! THE CPHF IS NOT CONVERGED AFTER ',
     *         I3,' ITERATIONS.')
 9040 FORMAT(1X,'THE CPHF HAS CONVERGED AFTER',I3,' ITERATIONS.'/
     *       1X,'IT REQUIRED',I6,' FOCK-LIKE BUILDS TO FIND THE',I4,
     *          ' SYMMETRY UNIQUE RESPONSES.')
      END
C*MODULE CPHF    *DECK XDELTA
      SUBROUTINE XDELTA(XLAGR,DLAGR,ZKL,E,X,Y,PMN,XLMN,BUF,IBUF,
     *                  NOCC,NVIR,NORB,NUM,NUM2,NUM3,NOCACT,NFZC,NINTMX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION XLAGR(NORB,NORB),DLAGR(NOCC,NVIR),ZKL(NOCACT,NFZC),
     *          E(NORB),X(NUM3),Y(NUM3),PMN(NUM2),XLMN(NUM2),
     *          BUF(NINTMX),IBUF(*)
C
C        --- FORM THE ASYMMETRY OF THE CI LAGRANGIAN ---
C
      DO 10 I=1,NVIR
         DO 20 J=1,NOCC
           DLAGR(J,I)=XLAGR(I+NOCC,J)-XLAGR(J,I+NOCC)
  20     CONTINUE
  10  CONTINUE
C
      IF(NFZC.EQ.0) RETURN
C
C     -- IF FROZEN CORE CALCULATE CORE-VALENCE DENSITY CORRECTION ZKL --
C
      DO 30 K=1,NOCACT
         DO 40 L=1,NFZC
            DLK=E(L)-E(K+NFZC)
            ZKL(K,L)=(XLAGR(K+NFZC,L)-XLAGR(L,K+NFZC))/DLK
  40     CONTINUE
  30  CONTINUE
C
C    --- FOR FROZEN CORE NEED EXTRA TERM IN LAGRANGIAN ---
C
      CALL CILAI(ZKL,PMN,X,Y,XLMN,BUF,IBUF,DLAGR,
     *           NOCACT,NFZC,NOCC,NVIR,NUM,NUM2,NUM3,XLAGR)
      RETURN
      END
C*MODULE CPHF    *DECK ZDENCI
      SUBROUTINE ZDENCI(PCORR,V,ZCV,X,Y,
     *                  NOC,NBF,NBF2,NBF3,NVIR,NFZC,NOCACT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, FOUR=4.0D+00, PT25=0.25D+00)
C
      DIMENSION PCORR(*),V(NBF,NBF),ZCV(NOCACT,NFZC),X(NBF3),Y(NBF3)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
C
C     ---- THIS ROUTINE TRANSFORMS THE Z-VECTOR INTO THE AO BASIS ----
C     ---- AND ADDS 4*Z (AO) TO THE 1-PARTICLE DENSITY            ----
C
      CALL TRPOSE(PCORR,X,NOC,NVIR,1)
C
      CALL VCLR(X,1,NBF3)
      CALL VCLR(Y,1,NBF3)
C
C     ---- GET ORBITAL COEFFICIENTS ----
C
      CALL DAREAD(IDAF,IODA,V,NBF3,15,0)
C
C     ---- TRNSFORM Z-VECTOR TO AO BASIS ----
C
      CALL MRARTR(PCORR,NVIR,NVIR,NOC,V,NBF,NBF,X,NBF)
      CALL DGEMM('N','N',NBF,NBF,NVIR,ONE,V(1,NOC+1),
     *            NBF,X,NBF,ZERO,Y,NBF)
C
      IF(NFZC.GT.0) THEN
         DO 50 I=1,NOCACT
            DO 60 J=1,NFZC
               ZCV(I,J)=ZCV(I,J)*PT25
   60       CONTINUE
   50    CONTINUE
         CALL MRARTR(ZCV,NOCACT,NOCACT,NFZC,V,NBF,NBF,X,NBF)
         CALL DGEMM('N','N',NBF,NBF,NOCACT,ONE,V(1,NFZC+1),
     *              NBF,X,NBF,ONE,Y,NBF)
      END IF
C
      CALL DCOPY(NBF3,Y,1,V,1)
C
      MUNU = 0
      DO 110 MU=1,NBF
         DO 100 NU=1,MU
            MUNU=MUNU+1
            X(MUNU) = FOUR*(V(MU,NU) + V(NU,MU))
  100    CONTINUE
  110 CONTINUE
C
C     ---- ADD TO CI 1-PARTICLE DENSITY ----
C
      CALL DAREAD(IDAF,IODA,Y,NBF2,16,0)
      CALL VADD(X,1,Y,1,Y,1,NBF2)
C
C     ---- WRITE RELAXED DENSITY TO DAF ----
C
      CALL DAWRIT(IDAF,IODA,Y,NBF2,16,0)
      RETURN
      END
C*MODULE CPHF    *DECK ZGRDCI
      SUBROUTINE ZGRDCI(Z,B,BCV,ZCV,NVIR,NOCC,NXYZ,NAT,NFZC,NOCACT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000,TWO=2.0D+00, PT5=0.5D+00)
C
      DIMENSION B(NOCC,NVIR,NXYZ), Z(NOCC,NVIR), BCV(NFZC,NOCACT,NXYZ)
      DIMENSION ZCV(NOCACT,NFZC)
C
      COMMON /GRAD  / DE(3,MXATM)
C
C        PLACE Z-VECTOR CONTRIBUTIONS INTO THE CI GRADIENT
C
      DO 10 NA=1,NAT
         NAI=3*(NA-1)
         DO 20 I=1,NVIR
            DO 30 J=1,NOCC
               DE(1,NA)=DE(1,NA) + TWO*B(J,I,NAI+1)*Z(J,I)
               DE(2,NA)=DE(2,NA) + TWO*B(J,I,NAI+2)*Z(J,I)
               DE(3,NA)=DE(3,NA) + TWO*B(J,I,NAI+3)*Z(J,I)
   30       CONTINUE
   20    CONTINUE
   10 CONTINUE
C
C     --- FOR FROZEN CORE NEED CORE-VALENCE CONTRIBUTIONS ---
C     --- THE EQUATIONS CALL FOR A FACTOR OF 2 BUT WE MUST DIVIDE ---
C     --- THIS BY 4 TO ACCOUNT FOR B WHICH IS 4 TIMES TOO BIG     ---
C
      IF (NFZC.GT.0) THEN
         DO 50 NA=1,NAT
            NAI=3*(NA-1)
            DO 60 I=1,NOCACT
               DO 70 J=1,NFZC
                  DE(1,NA)=DE(1,NA) + PT5*BCV(J,I,NAI+1)*ZCV(I,J)
                  DE(2,NA)=DE(2,NA) + PT5*BCV(J,I,NAI+2)*ZCV(I,J)
                  DE(3,NA)=DE(3,NA) + PT5*BCV(J,I,NAI+3)*ZCV(I,J)
   70          CONTINUE
   60       CONTINUE
   50    CONTINUE
      END IF
C
      RETURN
      END
C*MODULE CPHF    *DECK LINEQU
      SUBROUTINE LINEQU(A,LDA,B,N,IB,T,DETA,IERR,NODCMP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(LDA,*),B(N),IB(N),T(N)
C
C     ----- SOLVE A * X = B , WITH X RETURNED IN B -----
C
      IF(NODCMP.NE.1) GO TO 20
C
      CALL LUDCMP(A,LDA,N,IB,T,DETA,IERR)
      DO 10 J=1,N
   10 DETA=DETA*A(J,J)
C
   20 CONTINUE
      CALL LUBKSB(A,LDA,N,IB,B)
C
      RETURN
      END
C*MODULE CPHF    *DECK LUBKSB
      SUBROUTINE LUBKSB(A,LDA,N,IB,B)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(LDA,*),IB(N),B(N)
C
      DATA ZERO /0.0D+00/
C
C     ----- NUMERICAL RECIPES (P.37), CAMBRIDGE UNIVERSITY PRESS -----
C          W.H.PRESS, B.P.FLANNERY, S.A.TEUKOLSKY, W.T.VETTERLING
C
      II=0
      DO 12 I=1,N
         LL=IB(I)
         SUM=B(LL)
         B(LL)=B(I)
         IF(II.NE.0) THEN
            DO 11 J=II,I-1
               SUM=SUM-A(I,J)*B(J)
   11       CONTINUE
         ELSE IF (SUM.NE.ZERO) THEN
            II=I
         END IF
         B(I)=SUM
   12 CONTINUE
      DO 14 I=N,1,-1
         SUM=B(I)
         IF(I.LT.N) THEN
            DO 13 J=I+1,N
               SUM=SUM-A(I,J)*B(J)
   13       CONTINUE
         END IF
         B(I)=SUM/A(I,I)
   14 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK LUDCMP
      SUBROUTINE LUDCMP(A,LDA,N,IB,VV,D,IERR)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION A(LDA,*),IB(N),VV(N)
C
      DATA TINY     /1.0D-20/
      DATA ZERO,ONE /0.0D+00,1.0D+00/
C
C     ----- NUMERICAL RECIPES (P.35), CAMBRIDGE UNIVERSITY PRESS -----
C          W.H.PRESS, B.P.FLANNERY, S.A.TEUKOLSKY, W.T.VETTERLING
C
      IERR=0
      D=ONE
      IMAX=0
      DO 12 I=1,N
         AAMAX=ZERO
         DO 11 J=1,N
            IF( ABS(A(I,J)).GT.AAMAX) AAMAX= ABS(A(I,J))
   11    CONTINUE
         IF(AAMAX.EQ.ZERO) THEN
            IERR=1
            RETURN
         END IF
         VV(I)=ONE/AAMAX
   12 CONTINUE
      DO 19 J=1,N
         IF(J.GT.1) THEN
            DO 14 I=1,J-1
               SUM=A(I,J)
               IF(I.GT.1) THEN
                  DO 13 K=1,I-1
                     SUM=SUM-A(I,K)*A(K,J)
   13             CONTINUE
                  A(I,J)=SUM
               END IF
   14       CONTINUE
         END IF
         AAMAX=ZERO
         DO 16 I=J,N
            SUM=A(I,J)
            IF(J.GT.1) THEN
               DO 15 K=1,J-1
                  SUM=SUM-A(I,K)*A(K,J)
   15          CONTINUE
               A(I,J)=SUM
            END IF
            DUM=VV(I)* ABS(SUM)
            IF(DUM.GE.AAMAX) THEN
               IMAX=I
               AAMAX=DUM
            END IF
   16    CONTINUE
         IF(J.NE.IMAX) THEN
            DO 17 K=1,N
               DUM=A(IMAX,K)
               A(IMAX,K)=A(J,K)
               A(J,K)=DUM
   17       CONTINUE
            D=-D
            VV(IMAX)=VV(J)
         END IF
         IB(J)=IMAX
         IF(J.NE.N) THEN
            IF(A(J,J).EQ.ZERO) A(J,J)=TINY
            DUM=ONE/A(J,J)
            DO 18 I=J+1,N
               A(I,J)=A(I,J)*DUM
   18       CONTINUE
         END IF
   19 CONTINUE
      IF(A(N,N).EQ.ZERO) A(N,N)=TINY
      RETURN
      END
C*MODULE CPHF    *DECK SOLVCG
      SUBROUTINE SOLVCG(A,B,X,ADIAG,N,NITER,NPASS,INCORE,NWIDTH,NFT16,
     *                  WRK1,WRK2,XI,XJ,NOCP,BNORM,RESDU,NSOLV,
     *                  NFTH21,OMEGA,FREQI,NVIR,NOCC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL CVGING,INCORE,GOPARR,DSKWRK,MASWRK,OMEGA
C
      DIMENSION A(N,NWIDTH),X(N,NSOLV),B(N,NSOLV),WRK1(N,NSOLV),
     *          WRK2(N,NSOLV),XI(N,NSOLV),XJ(N,NSOLV),NOCP(NSOLV),
     *          BNORM(NSOLV),RESDU(NSOLV),ADIAG(N)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00, EPS=1.0D-05, ONE=1.0D+00)
C
C     ----- SOLVE A * X = B -----
C     USING AN ITERATIVE CONJUGATE GRADIENT ALGORITHM
C
C     SEE "NUMERICAL RECIPES (FORTRAN VERSION)", PAGE 70
C     W.H.PRESS, B.P.FLANNERY, S.A.TEUKOLSKY, W.T.VETTERLING
C     CAMBRIDGE UNIVERSITY PRESS, 1989.
C
C     THIS CODE HAS BEEN SPECIALIZED TO THE CPHF PROBLEM OCCURING IN
C     QUANTUM CHEMISTRY, I.E. THE COEFFICIENT MATRIX -A- IS ASSUMED
C     TO BE SYMMETRIC BY SPARAX AND SPARXA.
C
      EPS2=N*EPS*EPS
      IF(.NOT.INCORE .AND. .NOT.OMEGA) CALL SEQREW(NFT16)
C
C        EVALUATE MAGNITUDE OF RIGHT HAND SIDE
C
      IF(OMEGA) CALL SEQREW(NFTH21)
C
      CALL SPARAX(A,X,XI,ADIAG,NOCP,INCORE,NFT16,N,NWIDTH,NSOLV,
     *            OMEGA,NFTH21,FREQI,NVIR,NOCC)
C
      DO 140 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).GT.0) GO TO 140
         DO 130 J=1,N
            XI(J,ISOLV) = XI(J,ISOLV)-B(J,ISOLV)
  130    CONTINUE
         BNORM(ISOLV)= DDOT(N, B(1,ISOLV),1, B(1,ISOLV),1)
         RESDU(ISOLV)= DDOT(N,XI(1,ISOLV),1,XI(1,ISOLV),1)
  140 CONTINUE
C
C        EVALUATE THE STARTING GRADIENT
C
      CALL SPARXA(A,XI,WRK1,ADIAG,NOCP,INCORE,NFT16,N,NWIDTH,NSOLV,
     *            OMEGA,NFTH21,FREQI,NVIR,NOCC)
C
      DO 180 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).GT.0) GO TO 180
         DO 170 J=1,N
            WRK1(J,ISOLV) = -WRK1(J,ISOLV)
            WRK2(J,ISOLV) =  WRK1(J,ISOLV)
  170    CONTINUE
  180 CONTINUE
C
C        ----- BEGIN ITERATIONS HERE -----
C        IF OUT OF CORE, WE'VE ALREADY READ THE DISK FILE ONCE
C
      MAXCP = 50
      MAXCP2= 200
      ITER = 0
      NPASS = 1
      RSQMAX = ZERO
      RSQPRV = ZERO
  200 CONTINUE
      ITER  = ITER+1
      NPASS = NPASS+1
      CVGING = RSQMAX .LT. RSQPRV
      RSQPRV = RSQMAX
C
      CALL SPARAX(A,WRK2,XI,ADIAG,NOCP,INCORE,NFT16,N,NWIDTH,NSOLV,
     *            OMEGA,NFTH21,FREQI,NVIR,NOCC)
C
      DO 340 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).GT.0) GO TO 340
         NITER = NITER+1
         ANUM = DDOT(N,WRK1(1,ISOLV),1,WRK2(1,ISOLV),1)
         ADEN = DDOT(N,  XI(1,ISOLV),1,  XI(1,ISOLV),1)
         IF(ADEN.EQ.ZERO) THEN
            IF(ANUM.NE.ZERO) THEN
               IF(MASWRK) WRITE(IW,*) 'VERY SINGULAR MATRIX IN SOLVCG'
               CALL ABRT
               STOP
            ELSE
               ANUM=ONE
               ADEN=ONE
            END IF
         END IF
         ANUM=ANUM/ADEN
         CALL DCOPY(N,X(1,ISOLV),1,XI(1,ISOLV),1)
         CALL DAXPY(N,ANUM,WRK2(1,ISOLV),1,X(1,ISOLV),1)
  340 CONTINUE
C
      CALL SPARAX(A,X,XJ,ADIAG,NOCP,INCORE,NFT16,N,NWIDTH,NSOLV,
     *            OMEGA,NFTH21,FREQI,NVIR,NOCC)
C
      NRSQ = 0
      RSQMAX = ZERO
      DO 440 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).GT.0) GO TO 440
         DO 420 J=1,N
            XJ(J,ISOLV) = XJ(J,ISOLV) - B(J,ISOLV)
  420    CONTINUE
         RSQ = DDOT(N,XJ(1,ISOLV),1,XJ(1,ISOLV),1)
         NRSQ   = NRSQ+1
         RSQMAX = MAX(RSQ,RSQMAX)
C
C                          NORMAL CONVERGENCE FOR SOLUTION -ISOLV-
C
         IF(RSQ.EQ.RESDU(ISOLV) .OR. RSQ.LE.BNORM(ISOLV)*EPS2) THEN
            NOCP(ISOLV) = 2
         ELSE
            RESDU(ISOLV) = RSQ
         END IF
  440 CONTINUE
C
C            PRINT RESULT FOR THIS ITERATION
C
      IF(MASWRK) WRITE(IW,9020) ITER,NRSQ,RSQMAX
      CALL FLSHBF(IW)
C
C                  RETURN IF WE'VE FOUND ALL SOLUTIONS.
C
      DO 500 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).EQ.0) GO TO 510
 500  CONTINUE
      RETURN
C
 510  CONTINUE
      CALL SPARXA(A,XJ,XI,ADIAG,NOCP,INCORE,NFT16,N,NWIDTH,NSOLV,
     *            OMEGA,NFTH21,FREQI,NVIR,NOCC)
C
      DO 540 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).GT.0) GO TO 540
C
C                                     RARE, BUT NORMAL SOLUTION
C
         GG = DDOT(N,WRK1(1,ISOLV),1,WRK1(1,ISOLV),1)
         IF(GG.EQ.ZERO) THEN
            NOCP(ISOLV)=2
            GO TO 540
         END IF
C
         DGG=ZERO
         DO 520 J=1,N
            DGG=DGG + (XI(J,ISOLV) + WRK1(J,ISOLV)) * XI(J,ISOLV)
  520    CONTINUE
         GAM=DGG/GG
         DO 530 J=1,N
            WRK1(J,ISOLV)= -XI(J,ISOLV)
            WRK2(J,ISOLV)=WRK1(J,ISOLV) + GAM*WRK2(J,ISOLV)
  530    CONTINUE
  540 CONTINUE
C
C                  RETURN IF WE'VE FOUND ALL SOLUTIONS.
C
      DO 580 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).EQ.0) GO TO 590
  580 CONTINUE
      RETURN
C     ******
C
C          THE STRATEGY IS TO ALLOW AT MOST -MAXCP2- ITERATIONS,
C          BUT WE ALSO WILL STOP AFTER -MAXCP- ITERATIONS UNLESS
C          WE HAVE MADE SOME PROGRESS ON CURRENT OR PREVIOUS ITER.
C
  590 CONTINUE
      IF(ITER.GT.MAXCP2) GO TO 700
      IF(ITER.LE.MAXCP)  GO TO 200
      IF(CVGING  .OR.  RSQMAX.LT.2.0D+00*RSQPRV) GO TO 200
C
C       WE ARE NOT CONVERGING...
C
  700 CONTINUE
      IF (MASWRK) WRITE(IW,9000) MAXCP
      CALL ABRT
      STOP
 9000 FORMAT(1X,'*** TOO MANY ITERATIONS IN SOLVCG *** MAXCP=',I5//
     *       1X,'THIS VALUE CANNOT BE RAISED BY THE INPUT BECAUSE MORE',
     *          ' ITERATIONS WILL NOT HELP.'/
     *       1X,'THE FAILURE TO SOLVE IS DUE TO THE ILL CONDITIONED',
     *          ' ORBITAL HESSIAN,'/1X,'MOST OFTEN THIS IS',
     *          ' CAUSED BY USE OF AN INAPPROPRIATE WAVEFUNCTION.'/
     *       1X,'CHANGE SCFTYP, OR CHECK HOMO/LUMO FILLING ORDER.'/)
 9020 FORMAT(1X,'ITER',I4,' IMPROVED',I5,' RESPONSES, MAX RESIDUE=',
     *       1P,E15.7)
      END
C*MODULE CPHF    *DECK SOLVCP
      SUBROUTINE SOLVCP(WXY,WAX,YA,NROT,NXYZ,NOCP,WXYII,
     *                  WRK1,WRK2,WRK3,WRK4,BNORM,RESDU,
     *                  NITER,NPASS,NWIDTH,NSOLV,INCORE,
     *                  NFT16,MAXEQU)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL INCORE
C
      DIMENSION WXY(NROT,NWIDTH),WAX(NROT,NXYZ),YA(NROT,NXYZ),
     *          WXYII(NROT),NOCP(NXYZ),
     *          WRK1(NROT,NSOLV),WRK2(NROT,NSOLV),WRK3(NROT,NSOLV),
     *          WRK4(NROT,NSOLV),BNORM(NSOLV),RESDU(NSOLV)
C
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TOL=1.0D-10)
C
C     ----- SOLVE LINEAR EQUATIONS WXY * YA - WAX = 0 -----
C
C     THE EQUATIONS ARE OF DIMENSION -NROT-, AND THERE ARE -NXYZ-
C     INHOMOGENEITIES.  -NOCP- TELLS WHICH SOLUTIONS -YA- ARE NOT
C     NEEDED DUE TO SYMMETRY OF THE MOLECULE, 0/1=SOLVE/SKIP.
C
C     SMALL (.LE.-MAXEQU-) SYSTEMS OF EQUATIONS ARE SOLVED DIRECTLY
C     BY USING LU DECOMPOSITION, LARGER SYSTEMS BY AN ITERATIVE
C     CONJUGATE GRADIENT MINIMIZATION.  LARGER SYSTEMS MAY OR MAY
C     NOT HOLD ALL OF -WXY- IN MEMORY, DEPENDING ON -INCORE-.
C
C     THE INHOMOGENEITY -WAX-, SOLUTIONS -YA-, AND SEVERAL WORK
C     VECTORS ARE ASSUMED ALWAYS TO FIT IN MEMORY.  ON EXIT, A
C     MEMORY RESIDENT -WXY- IS DESTROYED, BUT -WAX- IS UNCHANGED.
C
C     WHEN -INCORE- IS TRUE, -NWIDTH- EQUALS -NROT-, AND THE MATRIX
C     MUST EXIST ALREADY IN -WXY-.   BOTH IN MEMORY ALGORITHMS ARE
C     GENERAL, WITH NO ASSUMPTION ABOUT THE SYMMETRY OF -WXY-.
C     THE SMALL SYSTEM METHOD SEEKS SOLUTIONS ONE AT A TIME, SO THAT
C     THE VALUE FOR -NSOLV- SHOULD BE 1.  FOR THE LARGER METHODS,
C     -NSOLV- SHOULD EQUAL -NXYZ- TO DEVELOP ALL SOLUTIONS AT ONCE,
C     WHICH MINIMIZES DISK I/O ON THE EXTERNAL -WXY- MATRIX, OR
C     MEMORY ACCESSES ON -WXY- IF IT SITS IN MEMORY.
C
C     WHEN -INCORE- IS FALSE, THE -WXY- MATRIX IS STORED ON DISK
C     FILE -NFT16-, IN STRIPS WHICH ARE -NWIDTH- COLUMNS WIDE.
C     THE INITIAL MATRIX -WXY- MUST BE SYMMETRIC, WHICH FACT WHICH
C     IS EXPLOITED IN THE OUT OF MEMORY SOLVER.  ON ENTRY, -WXYII-
C     MUST CONTAIN THE DIAGONAL OF THE EXTERNALLY STORED -WXY-.
C
C     ORIGINAL VERSION OF THIS ROUTINE IS DUE TO MICHEL DUPUIS.
C     OUT OF MEMORY STORAGE OF -WXY- CODED BY MWS, OCTOBER 1990,
C     AND MODIFIED IN JANUARY 1992 AND AGAIN IN JANUARY 1996.
C
C     ----- PRE-CONDITION DIAGONAL OF THE EQUATIONS TO ONE -----
C
      IF(INCORE) THEN
         DO 110 IROT=1,NROT
            WXYII(IROT) = ONE/WXY(IROT,IROT)
  110    CONTINUE
      ELSE
         DO 120 IROT=1,NROT
            WXYII(IROT) = ONE/WXYII(IROT)
  120    CONTINUE
      END IF
C
C     CONDITIONING FOR LINPACK IN MEMORY SOLVER
C     CONDITIONING OF -WXY- IS DONE INSIDE THE CONJUGATE GRADIENT SOLVER
C
      IF(NROT.LE.MAXEQU .AND. INCORE) THEN
         DO 230 JROT=1,NROT
            DO 220 IROT=1,NROT
               WXY(IROT,JROT)=WXY(IROT,JROT)*WXYII(IROT)
  220       CONTINUE
  230    CONTINUE
      END IF
C
C     AND OF COURSE CONDITION THE INHOMOGENEITY AS WELL
C
      DO 320 IXYZ=1,NXYZ
         DO 310 IROT=1,NROT
            WAX(IROT,IXYZ)=WAX(IROT,IXYZ)*WXYII(IROT)
  310    CONTINUE
  320 CONTINUE
C
C     ----- GENERATE INITIAL GUESS AT THE SOLUTIONS -----
C     WE ALSO CHANGE THE SIGN OF THE INHOMOGENEITY HERE.
C     IF INHOMOGENEITY IS SMALL, WE CAN SKIP THAT SOLUTION.
C
      DO 420 IXYZ=1,NXYZ
         IF(NOCP(IXYZ).EQ.0) THEN
            WAXMAX=ZERO
            DO 410 IROT=1,NROT
               WAXI = -WAX(IROT,IXYZ)
               IF(ABS(WAXI).GT.WAXMAX) WAXMAX=ABS(WAXI)
               WAX(IROT,IXYZ) = WAXI
                YA(IROT,IXYZ) = WAXI
  410       CONTINUE
            IF(WAXMAX.LT.TOL) NOCP(IXYZ)=2
         END IF
         IF(NOCP(IXYZ).GT.0) CALL VCLR(YA(1,IXYZ),1,NROT)
  420 CONTINUE
C
C     ----- THE LINPACK SOLVER LOOPS OVER SOLVING EACH EQUATION -----
C     ----- FOR CONJUGATE GRADIENT, SEEK SOLUTIONS SIMULTANEOUSLY -----
C
      IF(NROT.LE.MAXEQU .AND. INCORE) THEN
         NODCMP=1
         DO 500 IXYZ=1,NXYZ
            IF(NOCP(IXYZ).GT.0) GO TO 500
            CALL LINEQU(WXY,NROT,YA(1,IXYZ),NROT,
     *                  WRK1,WRK2,DETWXY,IERR,NODCMP)
            NODCMP=0
  500    CONTINUE
      ELSE
         CALL SOLVCG(WXY,WAX,YA,WXYII,NROT,NITER,NPASS,INCORE,NWIDTH,
     *               NFT16,WRK1,WRK2,WRK3,WRK4,NOCP,BNORM,RESDU,NSOLV,
     *               NFTH21,.FALSE.,0.0D+00,NVIR,NOCC)
      END IF
C
C     FINALLY, RESTORE ORIGINAL -NOCP- AND -WAX- MATRIX
C
      DO 600 IXYZ=1,NXYZ
         IF(NOCP(IXYZ).EQ.2) NOCP(IXYZ)=0
  600 CONTINUE
C
      DO 610 IROT=1,NROT
         WXYII(IROT)=ONE/WXYII(IROT)
  610 CONTINUE
C
      DO 640 IXYZ=1,NXYZ
         IF(NOCP(IXYZ).EQ.0) THEN
            DO 620 IROT=1,NROT
               WAX(IROT,IXYZ) = -WAX(IROT,IXYZ) * WXYII(IROT)
  620       CONTINUE
         ELSE
            DO 630 IROT=1,NROT
               WAX(IROT,IXYZ) =  WAX(IROT,IXYZ) * WXYII(IROT)
  630       CONTINUE
         END IF
  640 CONTINUE
      RETURN
      END
C
C*MODULE CPHF    *DECK SPARAX
      SUBROUTINE SPARAX(A,X,AX,ADIAG,NOCP,INCORE,NFT16,N,NWIDTH,NSOLV,
     *                  OMEGA,NFTH21,FREQI,NVIR,NOCC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL INCORE,OMEGA
C
      DIMENSION A(N,NWIDTH),X(N,NSOLV),AX(N,NSOLV),ADIAG(N),NOCP(NSOLV)
C
      PARAMETER (FOUR=4.0D+00)
C
C     ----- THIS ROUTINE COMPUTES AX = A * X -----
C     A IS SYMMETRIC, SO ITS COLUMNS ARE ITS ROWS, NEEDED FOR
C     THE MULTIPLY, BUT COLUMNS HAVE THE ADVANTAGE OF UNIT STRIDE.
C     TO EXPLOIT THIS, WE MUST ACCOUNT FOR A'S CONDITIONING AFTER
C     FORMING A*X, SINCE A PRECONDITIONED -A- IS NOT SYMMETRIC.
C
      IF(INCORE) THEN
         DO 150 I=1,N
            DO 140 ISOLV=1,NSOLV
               IF(NOCP(ISOLV).GT.0) GO TO 140
               AX(I,ISOLV) = DDOT(N,A(1,I),1,X(1,ISOLV),1)
  140       CONTINUE
  150    CONTINUE
      ELSE
         KOL2 = 0
  310    CONTINUE
            KOL0=KOL2
            KOL1=KOL2+1
            KOL2=KOL2+NWIDTH
            IF(KOL2.GT.N) KOL2=N
            NCOL = KOL2-KOL1+1
C
            LEN = N*NCOL
            IF(.NOT.OMEGA) THEN
              CALL SQREAD(NFT16,A,LEN)
            ELSE
              CALL SQREAD(NFTH21,A,LEN)
            END IF
C
            IF(OMEGA) THEN
               FREQI2=FREQI*FREQI
               MROT = 0
               DO 321 IVIR=1,NVIR
                  DO 311 IOCC=1,NOCC
                     MROT = MROT+1
                     IF(MROT.LT.KOL1) GO TO 310
                     IF(MROT.GT.KOL2) GO TO 310
                     A(MROT,MROT-KOL0) = A(MROT,MROT-KOL0) - FOUR*FREQI2
  311              CONTINUE
  321          CONTINUE
            END IF
C
            DO 350 I=1,NCOL
               DO 340 ISOLV=1,NSOLV
                  IF(NOCP(ISOLV).GT.0) GO TO 340
                  AX(I+KOL0,ISOLV) = DDOT(N,A(1,I),1,X(1,ISOLV),1)
  340          CONTINUE
  350       CONTINUE
         IF(KOL2.LT.N) GO TO 310
C
          IF(.NOT.OMEGA) THEN
            CALL SEQREW(NFT16)
          ELSE
            CALL SEQREW(NFTH21)
          END IF
         END IF
C
C        APPLY CONDITIONING FACTOR OF -A- MATRIX TO A*X PRODUCT.
C
      DO 420 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).GT.0) GO TO 420
         DO 410 I=1,N
            AX(I,ISOLV) = ADIAG(I) * AX(I,ISOLV)
  410    CONTINUE
  420 CONTINUE
C
      RETURN
      END
C*MODULE CPHF    *DECK SPARXA
      SUBROUTINE SPARXA(A,X,XA,ADIAG,NOCP,INCORE,NFT16,N,NWIDTH,NSOLV,
     *                  OMEGA,NFTH21,FREQI,NVIR,NOCC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL INCORE,OMEGA
C
      DIMENSION A(N,NWIDTH),X(N,NSOLV),XA(N,NSOLV),NOCP(NSOLV),ADIAG(N)
C
      PARAMETER (FOUR=4.0D+00)
C
C     ----- THIS ROUTINE COMPUTES XA = X-TRANSPOSE * A -----
C
C     APPLY CONDITIONING FACTOR OF -A- MATRIX TO X-TRANSPOSE.
C
      DO 120 ISOLV=1,NSOLV
         IF(NOCP(ISOLV).GT.0) GO TO 120
         DO 110 I=1,N
            X(I,ISOLV) = ADIAG(I) * X(I,ISOLV)
  110    CONTINUE
  120 CONTINUE
C
      IF(INCORE) THEN
         DO 250 I=1,N
            DO 240 ISOLV=1,NSOLV
               IF(NOCP(ISOLV).GT.0) GO TO 240
               XA(I,ISOLV) = DDOT(N,X(1,ISOLV),1,A(1,I),1)
  240       CONTINUE
  250    CONTINUE
      ELSE
         KOL2 = 0
  310    CONTINUE
            KOL0=KOL2
            KOL1=KOL2+1
            KOL2=KOL2+NWIDTH
            IF(KOL2.GT.N) KOL2=N
            NCOL = KOL2-KOL1+1
C
            LEN = N*NCOL
C
            IF(.NOT.OMEGA) THEN
               CALL SQREAD(NFT16,A,LEN)
            ELSE
               CALL SQREAD(NFTH21,A,LEN)
            END IF
C
            IF(OMEGA) THEN
                 FREQI2=FREQI*FREQI
                 MROT = 0
                 DO 321 IVIR=1,NVIR
                   DO 311 IOCC=1,NOCC
                   MROT = MROT+1
                   IF(MROT.LT.KOL1) GO TO 311
                   IF(MROT.GT.KOL2) GO TO 311
                   A(MROT,MROT-KOL0) =A(MROT,MROT-KOL0) -FOUR*FREQI2
  311    CONTINUE
  321 CONTINUE
            END IF
C
            DO 350 I=1,NCOL
               DO 340 ISOLV=1,NSOLV
                  IF(NOCP(ISOLV).GT.0) GO TO 340
                  XA(I+KOL0,ISOLV) = DDOT(N,X(1,ISOLV),1,A(1,I),1)
  340          CONTINUE
  350       CONTINUE
         IF(KOL2.LT.N) GO TO 310
C
         IF(.NOT.OMEGA) THEN
           CALL SEQREW(NFT16)
         ELSE
         CALL SEQREW(NFTH21)
         END IF
      END IF
C
         IF(OMEGA) THEN
         FREQI2=FREQI**2
         DO 440 J=1,N
            DO 430 ISOLV=1,NSOLV
C            IF(NOCP(ISOLV).GT.0) GO TO 430
            XA(J,ISOLV) = XA(J,ISOLV) - X(J,ISOLV)*FOUR*FREQI2
  430    CONTINUE
  440 CONTINUE
C
         END IF
C
      RETURN
      END
C*MODULE CPHF    *DECK GSUMCP
      SUBROUTINE GSUMCP(MSGID,A,LENA)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MAXMES=5*1024*1024)
      DIMENSION A(LENA)
C
C        DIVIDE LARGE GLOBAL SUM INTO BIGGEST MESSAGE TCGMSG SUPPORTS.
C        ITS BIG_MESSAGE PARAMETER IS 40 MBYTES, I.E. 5 MWORDS.
C
      IF(LENA.LE.MAXMES) THEN
         CALL DDI_GSUMF(MSGID,A,LENA)
      ELSE
         LOC = 1
         LEN = MAXMES
         NCHUNK = LENA/MAXMES + 1
         DO 100 I=1,NCHUNK
            IF(I.EQ.NCHUNK) LEN=LENA - MAXMES*(NCHUNK-1)
            CALL DDI_GSUMF(MSGID,A(LOC),LEN)
            LOC = LOC+MAXMES
  100    CONTINUE
      END IF
      RETURN
      END
C*MODULE CPHF    *DECK CPH2O
      SUBROUTINE CPH2O(H2,E,XX,IX,IROT,H2II,NROT,NWIDTH,L1,
     *                  NOCC,NVIR,NFTI,NINTMX,NFTH2,DBG)
C
C NEW SUBROUTINE FOR CALCULATION OF H2
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBG,GOPARR,DSKWRK,MASWRK,SVDSKW
      LOGICAL IIOCC,JJOCC,KKOCC,LLOCC
      LOGICAL IIVIRT,JJVIRT,KKVIRT,LLVIRT
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
C
      DIMENSION H2(NROT,NWIDTH),H2II(NROT),IROT(L1,L1),E(L1),
     *          XX(NINTMX),IX(*)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (HALF=0.5D+00)
C
C              ----- COMPUTE H2 MATRIX -----
C             USING AN OUT OF MEMORY ALGORITHM
       MROT = 0
      DO 50 I=1,NOCC+NVIR
         DO 40 J=1,I
            IF(I.GT.NOCC  .AND.  J.LE.NOCC) THEN
               MROT = MROT+1
               IROT(I,J) = MROT
               IROT(J,I) = MROT
            ELSE IF (I.LE.NOCC  .AND.  J.GT.NOCC) THEN
               MROT = MROT+1
               IROT(I,J) = MROT
               IROT(J,I) = MROT
            ELSE
              IROT(I,J) = 0
              IROT(J,I) = 0
            END IF
   40    CONTINUE
   50 CONTINUE
C
C   THIS PART IS FROM  ROCPHF
C
C
        VALN= ZERO
C
      IF(MROT.NE.NROT) THEN
         IF(MASWRK) WRITE(IW,9030) MROT,NROT,NOCC,L1
         CALL ABRT
      END IF
C
      IF(MASWRK) REWIND NFTH2
C
      KOL2 = 0
  100 CONTINUE
      KOL0 = KOL2
      KOL1 = KOL2 + 1
      KOL2 = KOL2 + NWIDTH
      IF(KOL2.GT.NROT) KOL2=NROT
      NCOL = KOL2 - KOL0
C
      CALL VCLR(H2,1,NROT*NCOL)
C
C     ----- READ IN MO INTEGRALS TO CREATE -H2- MATRIX -----
C     TRANSFORMED INTEGRALS ASSUMED IN REVERSE CANONICAL ORDER
C
      CALL SEQREW(NFTI)
      IF(MASWRK) READ(NFTI)
  170 CONTINUE
      CALL PREAD(NFTI,XX,IX,NX,NINTMX)
      IF(NX.EQ.0) GO TO 300
      MX=IABS(NX)
      IF(MX.GT.NINTMX) GO TO 9000
C
C     ----- UNPACK LABELS AND PROCESS INTEGRALS -----
C
      DO 200 M = 1,MX
         VAL   = XX(M)
C
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32        LABEL1 = IX( 2*NPACK - 1 )
*I32        LABEL2 = IX( 2*NPACK     )
*I32        IPACK = ISHFT( LABEL1, -16 )
*I32        JPACK = IAND( LABEL1, 65535 )
*I32        KPACK = ISHFT( LABEL2, -16 )
*I32        LPACK = IAND( LABEL2, 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
         K = IPACK
         L = JPACK
         I = KPACK
         J = LPACK
C
         IF(J.EQ.I           ) VAL=VAL*HALF
         IF(L.EQ.K           ) VAL=VAL*HALF
         IF(K.EQ.I.AND.L.EQ.J) VAL=VAL*HALF
C
         VALN = -ONE*VAL
C
         IIOCC = I.LE.NOCC
         JJOCC = J.LE.NOCC
         KKOCC = K.LE.NOCC
         LLOCC = L.LE.NOCC
C
         IIVIRT = .NOT.IIOCC
         JJVIRT = .NOT.JJOCC
         KKVIRT = .NOT.KKOCC
         LLVIRT = .NOT.LLOCC
C
C       FLIPPING SIGN FROM THE START
C
      IF(I.GT.NOCC .AND. J.GT.NOCC .AND. K.LE.NOCC .AND.
     *   L.LE.NOCC) THEN
          VAL=VALN
      END IF
C
         IF(IIOCC.AND.KKVIRT .AND. JJOCC.AND.LLVIRT) THEN
         IKROT=IROT(I,K)
         JLROT=IROT(J,L)
         IF(JLROT.GE.KOL1  .AND.  JLROT.LE.KOL2)
     *      H2(IKROT,JLROT-KOL0) = H2(IKROT,JLROT-KOL0) + VAL
         IF(IKROT.GE.KOL1  .AND.  IKROT.LE.KOL2)
     *      H2(JLROT,IKROT-KOL0) = H2(JLROT,IKROT-KOL0) + VAL
      END IF
C
         IF(IIVIRT.AND.KKOCC .AND. JJVIRT.AND.LLOCC) THEN
         IKROT=IROT(I,K)
         JLROT=IROT(J,L)
         IF(JLROT.GE.KOL1  .AND.  JLROT.LE.KOL2)
     *      H2(IKROT,JLROT-KOL0) = H2(IKROT,JLROT-KOL0) + VAL
         IF(IKROT.GE.KOL1  .AND.  IKROT.LE.KOL2)
     *      H2(JLROT,IKROT-KOL0) = H2(JLROT,IKROT-KOL0) + VAL
       END IF
C
         IF(IIOCC.AND.KKVIRT .AND. JJVIRT.AND.LLOCC) THEN
         IKROT=IROT(I,K)
         JLROT=IROT(J,L)
         IF(JLROT.GE.KOL1  .AND.  JLROT.LE.KOL2)
     *      H2(IKROT,JLROT-KOL0) = H2(IKROT,JLROT-KOL0) + VAL
         IF(IKROT.GE.KOL1  .AND.  IKROT.LE.KOL2)
     *      H2(JLROT,IKROT-KOL0) = H2(JLROT,IKROT-KOL0) + VAL
       END IF
C
         IF(IIVIRT.AND.KKOCC .AND. JJOCC.AND.LLVIRT) THEN
         IKROT=IROT(I,K)
         JLROT=IROT(J,L)
         IF(JLROT.GE.KOL1  .AND.  JLROT.LE.KOL2)
     *      H2(IKROT,JLROT-KOL0) = H2(IKROT,JLROT-KOL0) + VAL
         IF(IKROT.GE.KOL1  .AND.  IKROT.LE.KOL2)
     *      H2(JLROT,IKROT-KOL0) = H2(JLROT,IKROT-KOL0) + VAL
       END IF
C
C                                         (I,L//K,J) AND (I,K//L,J)
C      IF(ISH.NE.LSH  .AND.  JSH.NE.KSH) THEN
C             FIRST TIME FOR SECOND PART
         IF(IIOCC.AND.LLVIRT .AND. JJOCC.AND.KKVIRT) THEN
         ILROT=IROT(I,L)
         JKROT=IROT(J,K)
         IF(JKROT.GE.KOL1  .AND.  JKROT.LE.KOL2)
     *      H2(ILROT,JKROT-KOL0) = H2(ILROT,JKROT-KOL0) + VAL
         IF(ILROT.GE.KOL1  .AND.  ILROT.LE.KOL2)
     *      H2(JKROT,ILROT-KOL0) = H2(JKROT,ILROT-KOL0) + VAL
      END IF
C
         IF(IIVIRT.AND.LLOCC .AND. JJOCC.AND.KKVIRT) THEN
         ILROT=IROT(I,L)
         JKROT=IROT(J,K)
         IF(JKROT.GE.KOL1  .AND.  JKROT.LE.KOL2)
     *      H2(ILROT,JKROT-KOL0) = H2(ILROT,JKROT-KOL0) + VAL
         IF(ILROT.GE.KOL1  .AND.  ILROT.LE.KOL2)
     *      H2(JKROT,ILROT-KOL0) = H2(JKROT,ILROT-KOL0) + VAL
      END IF
C
         IF(IIOCC.AND.LLVIRT .AND. JJVIRT.AND.KKOCC) THEN
         ILROT=IROT(I,L)
         JKROT=IROT(J,K)
         IF(JKROT.GE.KOL1  .AND.  JKROT.LE.KOL2)
     *      H2(ILROT,JKROT-KOL0) = H2(ILROT,JKROT-KOL0) + VAL
         IF(ILROT.GE.KOL1  .AND.  ILROT.LE.KOL2)
     *      H2(JKROT,ILROT-KOL0) = H2(JKROT,ILROT-KOL0) + VAL
      END IF
C
         IF(IIVIRT.AND.LLOCC .AND. JJVIRT.AND.KKOCC) THEN
         ILROT=IROT(I,L)
         JKROT=IROT(J,K)
         IF(JKROT.GE.KOL1  .AND.  JKROT.LE.KOL2)
     *      H2(ILROT,JKROT-KOL0) = H2(ILROT,JKROT-KOL0) + VAL
         IF(ILROT.GE.KOL1  .AND.  ILROT.LE.KOL2)
     *      H2(JKROT,ILROT-KOL0) = H2(JKROT,ILROT-KOL0) + VAL
         END IF
C                  AND GO BACK FOR ANOTHER INTEGRAL BUFFER.
C
  200 CONTINUE
      IF(NX.GT.0) GO TO 170
C
C     ----- COMPLETE -H2- MATRIX CONSTRUCTION -----
C     HALVE DIAGONAL, ADD ORBITAL ENERGY TERM
C
  300 CONTINUE
      CALL SEQREW(NFTI)
C
      MROT = 0
      DO 320 IVIR=1,NVIR
         DO 310 IOCC=1,NOCC
            MROT = MROT+1
            IF(MROT.LT.KOL1) GO TO 310
            IF(MROT.GT.KOL2) GO TO 310
            H2(MROT,MROT-KOL0) = H2(MROT,MROT-KOL0)
     *                          + (E(IVIR+NOCC)-E(IOCC))
  310    CONTINUE
  320 CONTINUE
C
      IF(DBG) THEN
         WRITE(IW,9050) KOL1,KOL2
         CALL PRSQ(H2,NCOL,NROT,NROT)
      END IF
C
      SVDSKW = DSKWRK
      DSKWRK = .FALSE.
      CALL SQWRIT(NFTH2,H2,NROT*NCOL)
      DSKWRK = SVDSKW
C
C         STORE DIAGONAL ELEMENT FOR LATER USE BY SOLVER
C
      DO 410 JROT=KOL1,KOL2
         H2II(JROT) = H2(JROT,JROT-KOL1+1)
  410 CONTINUE
      IF(KOL2.LT.NROT) GO TO 100
C
      IF(MASWRK) REWIND NFTH2
      RETURN
C
 9000 IF (MASWRK) WRITE(IW,9999) MX,NINTMX
      CALL ABRT
      STOP
C
 9999 FORMAT(1X,'*** ERROR, MX=',I10,' EXCEEDS NINTMX=',I10)
 9050 FORMAT(1X,'SLICE OF -H2- MATRIX FOR ROTATIONS',I5,' TO',I5)
 9030 FORMAT(1X,'UNEXPECTED INTERNAL TRAP ENCOUNTERED IN CPH2O'/
     *       1X,'UNEXPECTEDLY, MROT.NE.NROT, MROT=',I10,' NROT=',I10/
     *       1X,'EXTRA INFO IS NOCC,L1=',2I10)
      END
C
C*MODULE CPHF    *DECK DD_CPFCK
      SUBROUTINE DD_CPFCK(WAX,AA,TA,C,Y,X,WORK,
     *                    HF,GHONDO,XINTS,DSH,DDIJ,IA,
     *                    NOCC,NVIR,NOCC2,NXYZ,NNXYZ,
     *                    NUM,NUM2,MAXG,NSH2,MXG2,ID_D,ID_F,
     *                    DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK,NAOMX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,POLAR,SCHWRZ
C
C        -DSHX-, -FSHX-, -C-, -Y-, -X-, -WORK- ARE USED FOR
C        CALCULATION OF RESPONSES FROM AO BASIS INTEGRALS.
C        -HF- IS USED FOR OPTIONAL POLARIZABILITY COMPUTATION.
C
      DIMENSION WAX(NOCC,NVIR,NNXYZ),AA(NOCC2,NXYZ),TA(NOCC2,NXYZ),
     *          C(NUM,NUM),Y(NUM,NUM),X(NUM,NUM),WORK(*),HF(NUM2,3),
     *          GHONDO(MAXG),XINTS(NSH2),DSH(NSH2),DDIJ(49*MXG2),
     *          IA(NUM),DSHI(*),DSHJ(*),DSHK(*),FSHI(*),FSHJ(*),FSHK(*)
C
      COMMON /CHFINF/ CHFSLV,CPTYPE,NWDCHF,POLAR
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ONE=1.0D+00, FOUR=4.0D+00, HALF=0.5D+00)
C
C     ----- FORM THE INTEGRAL CONTRIBUTIONS TO -AA- AND -WAX- -----
C     THIS ROUTINE IS CODED TO BE DIRECT IN THE AO INTEGRALS, ONLY
C
      L1=NUM
C
C           CREATE DISTRIBUTED DA AND FA MATRICES
C
      CALL DDI_CREATE(L1,L1*NXYZ,ID_D)
      CALL DDI_CREATE(L1,L1*NXYZ,ID_F)
C
C           READ EXCHANGE INTEGRALS FOR SCREENING
C
      SCHWRZ = ISCHWZ.EQ.1
      IF(SCHWRZ) THEN
         CALL DAREAD(IDAF,IODA,XINTS,NSH2,54,0)
         CALL VCLR(DSH,1,NSH2)
      END IF
C
C     TRANSFORM THE TA-S INTO THE AO BASIS,
C     THESE "DENSITY MATRICES" ARE STORED IN DISTRIBUTED MEMORY
C
      DO 290 IXYZ=1,NXYZ
         CALL EXPND(TA(1,IXYZ),WORK,NOCC,0)
         CALL MRARTR(WORK,NOCC,NOCC,NOCC,C,NUM,NUM,X,NUM)
         CALL MRARBR(C,NUM,NUM,NOCC,X,NUM,NUM,Y,NUM)
C
         IJ = 0
         DO 260 I=1,NUM
            DO 250 J=1,I
               IJ = IJ + 1
               IF (I.EQ.J) THEN
                  X(I,J) = Y(I,J) + Y(J,I)
               ELSE
                  X(I,J) = Y(I,J) + Y(J,I)
                  X(J,I) = X(I,J)
               END IF
  250       CONTINUE
  260    CONTINUE
C
C     SET UP THE SCREENING OF INTEGRALS
C
         IF(SCHWRZ) CALL DD_AOSHLD(X,DSH,L1,NSH2)
C
C     FILL OUT CHUNK OF THE DISTRIBUTED DENSITY-LIKE MATRICES
C
         IF(MASWRK) THEN
            DO J_T=1,NUM
               ISH_T=(J_T-1)*NXYZ+IXYZ
               CALL DDI_PUT(ID_D,1,L1,ISH_T,ISH_T,X(1,J_T))
            END DO
         END IF
  290 CONTINUE
C
C       WAIT TO BE SURE MASTER HAS FINISHED SETTING DISTRIBUTED DENSITY
C
      CALL DDI_SYNC(5060)
C
C     NOW BUILD THE "FOCK-LIKE MATRICES" IN -FTEMP-
C
      CALL DD_AOFLM2(GHONDO,XINTS,DSH,DDIJ,
     *               NUM,NXYZ,MAXG,NSH2,MXG2,NINT,NSCHWZ,ID_D,ID_F,
     *               DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK,NAOMX)
C
C     TRANSFORM THE RESULTS TO THE MO BASIS
C
      IPCOUNT = ME-1
      IF(GOPARR) THEN
         FAC = ONE/NPROC
         CALL DSCAL(NOCC*NVIR*NNXYZ,FAC,WAX,1)
         CALL DSCAL(NOCC2    * NXYZ,FAC,AA ,1)
      END IF
C
      DO 390 IXYZ = 1,NXYZ
          IPCOUNT = IPCOUNT + 1
          IF(MOD(IPCOUNT,NPROC).NE.0) GO TO 390
C
C     GET FOCK LIKE MATRIX
C
          DO J_T=1,L1
             ISH_T=(J_T-1)*NXYZ+IXYZ
             CALL DDI_GET(ID_F,1,L1,ISH_T,ISH_T,X(1,J_T))
          END DO
C
C     SUM UP UPPER AND LOWER TRIANGLES
C     AND HALVE ELEMENTS EXCEPT DIAGONAL
C
          IJ = 0
          DO II=1,L1
             DO JJ=1,II
                IJ=IJ+1
                IF (II.EQ.JJ) THEN
                   WORK(IJ) = X(II,JJ)
                ELSE
                   WORK(IJ) = (X(II,JJ)+X(JJ,II))*HALF
                END IF
             END DO
          END DO
C
C     SIMILARITY TRANSFORMATION
C
          CALL EXPND(WORK,Y,NUM,0)
          CALL MRARBR(Y,NUM,NUM,NUM,C,NUM,NOCC,X,NUM)
          CALL MRTRBT(C,NUM,NUM,NOCC,X,NUM,WORK,1,1)
C
C     FORM THE AIJ^A CONTRIBUTION OF EQUATION 13.
C     NOTE THAT THE FACTOR OF 4 IS THE 2 FROM EQUATION 13 AND
C     ANOTHER TWO TAKING INTO ACCOUNT THE SYMMETRY OF THE TRANSFORMATION
C     (HAVE TWO TERMS THAT ARE SYMMETRIC, I CALCULATED ONE
C      AND NEED TO MULTIPLY BY TWO WHICH I AM DOING HERE)
C
          DO 330 IJ=1,NOCC2
             AA(IJ,IXYZ) = AA(IJ,IXYZ) + 4.0D+00*WORK(IJ)
  330     CONTINUE
C
C     DO LAST PART OF SECOND TRANSFORMATION INTO THE MO BASIS
C     (FIRST PART IS THE SAME AS THE PREVIOUS TRANSFORMATION)
C     THIS IS FOR EQUATION 14 TO FORM WAX
C
          CALL MRTRBR(C(1,NOCC+1),NUM,NUM,NVIR,X,NUM,NOCC,WORK,NVIR)
C
C     NOW FORM WAX
C     NOTE THAT THE FACTOR OF 8 IS THE 4 FROM EQUATION 14 AND
C     ANOTHER TWO TAKING INTO ACCOUNT THE SYMMETRY OF THE TRANSFORMATION
C     (HAVE TWO TERMS THAT ARE SYMMETRIC, I CALCULATED ONE
C      AND NEED TO MULTIPLY BY TWO WHICH I AM DOING HERE)
C
          I = 1
          DO 360 IOCC=1,NOCC
             DO 350 IVIR=1,NVIR
                WAX(IOCC,IVIR,IXYZ) = WAX(IOCC,IVIR,IXYZ)
     *                              + 8.0D+00*WORK(I)
                I = I + 1
  350       CONTINUE
  360    CONTINUE
  390 CONTINUE
C
C       WAIT TO BE SURE WE HAVE FINISHED USING DISTRIBUTED FOCKS
C
      CALL DDI_SYNC(5061)
      CALL DDI_DESTROY(ID_F)
      CALL DDI_DESTROY(ID_D)
      IF(GOPARR) THEN
         CALL DDI_GSUMF(5062,WAX,NOCC*NVIR*NNXYZ)
         CALL DDI_GSUMF(5063,AA ,NOCC2    * NXYZ)
      END IF
C
C     ---- IF POLARIZABILITY GET TRANSFORMED DIPOLE INTEGRALS ----
C                      ---- ADD TO -WAX- ----
C     ---- NOTE THAT MULTIPLICATION BY FOUR NEEDED TO RECONCILE ----
C     ---- SCHAEFER'S AND KOMORNIKI'S FORMULATIONS              ----
C
      IF(POLAR) THEN
         CALL DAREAD(IDAF,IODA,HF(1,1),NUM2,252,0)
         CALL DAREAD(IDAF,IODA,HF(1,2),NUM2,253,0)
         CALL DAREAD(IDAF,IODA,HF(1,3),NUM2,254,0)
C
         DO 950 IVIR=1,NVIR
            DO 960 IOCC=1,NOCC
               IJ=IA(IVIR+NOCC)+IOCC
               WAX(IOCC,IVIR,NXYZ+1)=FOUR*HF(IJ,1)
               WAX(IOCC,IVIR,NXYZ+2)=FOUR*HF(IJ,2)
               WAX(IOCC,IVIR,NXYZ+3)=FOUR*HF(IJ,3)
  960       CONTINUE
  950    CONTINUE
      END IF
C
      RETURN
      END
C*MODULE CPHF    *DECK DD_AOFLM2
      SUBROUTINE DD_AOFLM2(GHONDO,XINTS,DSH,DDIJ,NBF,NXYZ,
     *                     MAXG,NSH2,MXG2,NINT,NSCHWZ,ID_D,ID_F,
     *                     DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK,NAOMX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL PACK2E,SCHWRZ,DIRSCF,FDIFF
C
      DIMENSION GHONDO(MAXG), XINTS(NSH2), DSH(NSH2), DDIJ(49*MXG2),
     *          DSHI(*),DSHJ(*),DSHK(*),FSHI(*),FSHJ(*),FSHK(*)
C
      PARAMETER (MXAO=8192)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /OPTSCF/ DIRSCF,FDIFF
C
C         CODE COMMENTED OUT LETS US TIME JUST THE FOCK BUILD STEP
C---  LOGICAL GOPARR,DSKWRK,MASWRK
C---  COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C---  COMMON /TIMING/ CPU,WALL
C
      DATA RHF/8HRHF     /
C
C---  CALL TSECND(TCPU1)
C---  TWALL1=WALL
C
C           NOW FORM FOCK-LIKE MATRIX
C           DIRECT METHOD = RECOMPUTE 2E- AO INTEGRALS
C
      L1     = NBF
      NINT   = 0
      NSCHWZ = 0
      SCHWRZ = ISCHWZ.EQ.1
C
C           THE AO INTEGRAL LIST MUST BE IN C1 SYMMETRY
C
      CALL SYMOFF
C
      CALL DD_TWOEI(RHF,DIRSCF,INTTYP,SCHWRZ,NINT,NSCHWZ,L1,
     *              XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *              IA,DSH,NXYZ,ID_D,ID_F,NAOMX,
     *              DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK)
C
      CALL DDI_GSUMI(5062,NINT  ,1)
      CALL DDI_GSUMI(5063,NSCHWZ,1)
C
C        RESTORE THE USE OF POINT GROUP SYMMETRY
C
      CALL SYMON
C
C---  CALL TSECND(TCPU2)
C---  TWALL2=WALL
C---  IF(MASWRK) WRITE(6,8) TCPU2-TCPU1,TWALL2-TWALL1
C---8 FORMAT(1X,'DD_TWOEI: CPU=',F10.2,' WALL=',F10.2)
C
      RETURN
      END
C
C*MODULE CPHF    *DECK DD_AOSHLD
      SUBROUTINE DD_AOSHLD(D,DSH,L1,NSH2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION D(L1,L1),DSH(NSH2)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
C
C     ----- COMPRESS DENSITY OVER AOS TO DENSITY OVER SHELLS -----
C     BE SURE TO ZERO -DSH- BEFORE CALLING THIS ROUTINE, SO THAT WE
C     REALLY FIND THE MAXIMUM VALUES FROM EACH DENSITY-LIKE MATRIX,
C     THIS ROUTINE IS EXPECTED TO BE CALLED IN A LOOP OVER EACH SUCH.
C
      IJSH=0
      DO 240 ISH=1,NSHELL
         MINI = KLOC(ISH)
         MAXI = MINI + KMAX(ISH) - KMIN(ISH)
         DO 230 JSH=1,ISH
            MINJ = KLOC(JSH)
            MAXJ = MINJ + KMAX(JSH) - KMIN(JSH)
            IJSH = IJSH+1
            DMAX = DSH(IJSH)
            DO 130 I=MINI,MAXI
               IF(ISH.EQ.JSH) MAXJ=I
               DO 120 J=MINJ,MAXJ
                  IF(ABS(D(I,J)).GT.DMAX) DMAX = ABS(D(I,J))
  120          CONTINUE
  130       CONTINUE
            DSH(IJSH) = DMAX
  230    CONTINUE
  240 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK DD_AOCPCG
      SUBROUTINE DD_AOCPCG(WAX,YA,RESID,ZRES,PDIR,
     *                     PRECND,BNORM,BKNUM,BKDEN,
     *                     VEC,EIG,WRK1,WRK2,DMYX,WRK2MY,
     *                     NOCP,GHONDO,XINTS,DSH,DDIJ,
     *                     NNXYZ,NUNIQ,NFOCK,NROT,NOCC,NVIR,
     *                     L1,L3,NSH2,MAXG,MXG2,NAOMX,
     *                     DSH1,DSH2,DSH3,FSH1,FSH2,FSH3)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION WAX(NROT,NNXYZ),YA(NROT,NNXYZ),RESID(NROT,NUNIQ),
     *          ZRES(NROT,NUNIQ),PDIR(NROT,NUNIQ),PRECND(NROT),
     *          BNORM(NNXYZ),BKNUM(NNXYZ),BKDEN(NNXYZ),
     *          VEC(L1,L1),EIG(L1),WRK1(L1,L1),WRK2(L1,L1),
     *          DMYX(L1,L1),WRK2MY(L1,L1),NOCP(NNXYZ),
     *          GHONDO(MAXG),XINTS(NSH2),DSH(NSH2),DDIJ(49*MXG2),
     *          DSH1(L1,NNXYZ,NAOMX),DSH2(L1,NNXYZ,NAOMX),
     *          DSH3(L1,NNXYZ,NAOMX),
     *          FSH1(L1,NNXYZ,NAOMX),FSH2(L1,NNXYZ,NAOMX),
     *          FSH3(L1,NNXYZ,NAOMX)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,DIRSCF,FDIFF
C
      PARAMETER (ZERO=0.0D+00, TOL=5.0D-05)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA MAXIT/50/
C
C        --- SOLVE MULTIPLE SETS OF LINEAR EQUATIONS A*YA+WAX=0 ---
C        THIS ROUTINE USES THE ORDINARY PRECONDITIONED CONJUGATE
C        GRADIENT PROCEDURE.  NOTE THAT "ORDINARY" MEANS -A- IS A
C        POSITIVE DEFINITE SYMMETRIC MATRIX, I.E. THE ORBITAL HESSIAN.
C        THE DIMENSION OF -A- IS -NROT-, AND THERE ARE -NNXYZ- COLUMNS
C        IN BOTH THE INHOMOGENEITY (WHICH IS THE NEGATIVE OF -WAX-)
C        AND IN THE -YA- RESPONSE VECTORS BEING SOLVED FOR.  ONLY
C        -NUNIQ- RESPONSES ARE REQUIRED, DEPENDING ON SYMMETRY, WITH
C        THE LIST -NOCP- NAMING WHICH RESPONSES ARE ACTUALLY NEEDED.
C
C        WRITTEN BY MIKE SCHMIDT, AT TOKYO TORITSU DAIGAKU, JAN 2001.
C        THIS ROUTINE WAS INSPIRED BY -DCG- WRITTEN BY ANNE GREENBAUM
C        AND MARK SEEGER, IN THE SPARSE LINEAR ALGEBRA PACKAGE -SLAP-
C        WHICH WAS DOWNLOADED FROM NETLIB.
C        EXTENSIVE MODIFICATIONS HAVE BEEN MADE, EXCEPT TO THE ACTUAL
C        SOLVING TECHNIQUE, TO SUPPORT THE NEEDS OF QUANTUM CHEMISTRY.
C        MULTIPLE SOLUTIONS ARE SOUGHT, WITH THE A*YA MULTIPLICATIONS
C        DONE SIMULTANEOUSLY, ALTHOUGH EACH SOLVING REMAINS SEPARATE.
C        THE PRECONDITIONER CHOSEN IS THE RECIPROCAL OF THE DIAGONAL
C        ELEMENTS, APPROXIMATED IN THE SAME WAY AS GALINA CHABAN'S
C        SECOND ORDER SCF CONVERGER, SEE EQUATION 1.17 IN G.CHABAN,
C        M.W.SCHMIDT, M.S.GORDON, THEORET.CHIM.ACTA 97, 88-95(1997).
C        NOTE THAT AN APPROXIMATION IS NEEDED SINCE THE MATRIX A IS
C        NEVER GENERATED, INSTEAD PRODUCTS A*YA ARE FORMED DIRECTLY.
C        THE INITIAL GUESS WAS SUGGESTED BY JAN JENSEN, IT AMOUNTS
C        TO ASSUMING THE INITIAL RESPONSES ARE ZERO SO THAT THE
C        INTEGRAL CONTRIBUTIONS TO THE A MATRIX VANISH, LEAVING A
C        SIMPLE REARRANGEMENT TO PRODUCE THE INITIAL GUESS USED HERE.
C        CONVERGENCE CRITERION WAS SELECTED BY NUMERICAL EXPERIMENT.
C        FOR FURTHER INFORMATION, SEE THE COMMENTS IN THE ORIGINAL
C        SLAP LIBRARY ROUTINES, AND THE "NUMERICAL RECIPES" BOOK.
C        ANOTHER INTERESTING REFERENCE IS P.E.S.WORMER, F.VISSER,
C        J.PALDUS, J.COMPUT.PHYS. 48, 23-44(1982).
C
C        SET UP PRECONDITIONER AND INITIAL GUESS OF RESPONSES
C
      IROT = 0
      DO 130 IVIR = NOCC+1,NOCC+NVIR
         DO 120 IOCC= 1,NOCC
            IROT = IROT + 1
            PRECND(IROT) = 1.0D+00/(4.0D+00*(EIG(IVIR) - EIG(IOCC)))
            FACTOR = -PRECND(IROT)
            DO 110 IXYZ = 1,NNXYZ
               YA(IROT,IXYZ) = FACTOR * WAX(IROT,IXYZ)
  110       CONTINUE
  120    CONTINUE
  130 CONTINUE
C
C         THE INITIAL ITERATION IS DONE BEFORE THE MAIN LOOP,
C         CALCULATE INITIAL ITERATION'S RESIDUAL -RESID-
C
      NFOCK = 0
      DUMMY = ZERO
      ITER  = 1
      MODE  = 1
C
      CALL DD_AOCPCL(WAX,VEC,YA,DUMMY,RESID,EIG,WRK1,WRK2,
     *               GHONDO,XINTS,DSH,DDIJ,NOCP,MODE,
     *               NNXYZ,NUNIQ,NXYZF,NFOCK,NINT,NSCHWZ,
     *               NROT,NOCC,NVIR,L1,L3,NSH2,MAXG,MXG2,
     *               ID_D,ID_F,DMYX,WRK2MY,
     *               DSH1,DSH2,DSH3,FSH1,FSH2,FSH3,NAOMX)
C
      IUNIQ=0
      DO 160 IXYZ=1,NNXYZ
         IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
         IF(NOCP(IXYZ).NE.0) GO TO 160
         DO 150 IROT=1,NROT
            RESID(IROT,IUNIQ) =  -WAX(IROT,IXYZ) - RESID(IROT,IUNIQ)
  150    CONTINUE
  160 CONTINUE
C
C        CALCULATE INITIAL PSEUDORESIDUAL -ZRES-, CHECK CONVERGENCE
C
      ERR = ZERO
      IUNIQ=0
      DO 210 IXYZ=1,NNXYZ
         IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
         IF(NOCP(IXYZ).NE.0) GO TO 210
         DO IROT=1,NROT
            ZRES(IROT,IUNIQ) = PRECND(IROT)*RESID(IROT,IUNIQ)
         ENDDO
         BNORM(IXYZ)=SQRT(DDOT(NROT,  WAX(1, IXYZ),1,  WAX(1, IXYZ),1))
         RNORM      =SQRT(DDOT(NROT,RESID(1,IUNIQ),1,RESID(1,IUNIQ),1))
         TEST = RNORM/BNORM(IXYZ)
         IF(TEST.LT.TOL) NOCP(IXYZ)=2
         ERR = MAX(ERR,TEST)
  210 CONTINUE
      IF(MASWRK) THEN
         WRITE(IW,9000) TOL
         IF(DIRSCF) THEN
            WRITE(IW,9010)
            WRITE(IW,9020) ITER,ERR,NXYZF,NINT,NSCHWZ
         ELSE
            WRITE(IW,9030)
            WRITE(IW,9020) ITER,ERR,NXYZF
         END IF
         CALL FLSHBF(IW)
      END IF
      IF(ERR.LT.TOL) GO TO 800
C
C        THE REMAINING CG ITERATIONS START NOW...
C
      MODE=2
      DO 400 ITER=2,MAXIT
C
C           CALCULATE COEFFICIENT -BK- AND DIRECTION VECTOR -PDIR-
C
         IUNIQ=0
         DO 320 IXYZ=1,NNXYZ
            IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
            IF(NOCP(IXYZ).NE.0) GO TO 320
            BKNUM(IXYZ) = DDOT(NROT,ZRES(1,IUNIQ),1,RESID(1,IUNIQ),1)
            IF(BKNUM(IXYZ).LE.-TOL) THEN
               IF(MASWRK) WRITE(IW,9040)
               CALL ABRT
            END IF
            IF(ITER.EQ.2) THEN
               CALL DCOPY(NROT,ZRES(1,IUNIQ),1,PDIR(1,IUNIQ),1)
            ELSE
               BK = BKNUM(IXYZ)/BKDEN(IXYZ)
               DO IROT=1,NROT
                  PDIR(IROT,IUNIQ) =    ZRES(IROT,IUNIQ)
     *                             + BK*PDIR(IROT,IUNIQ)
               ENDDO
            END IF
            BKDEN(IXYZ) = BKNUM(IXYZ)
  320    CONTINUE
C
C           CALCULATE COEFFICIENT -AK-, NEW ITERATE -YA-,
C           NEW RESIDUAL -RESID-, AND NEW PSEUDO-RESIDUAL -ZRES-.
C
         CALL DD_AOCPCL(WAX,VEC,PDIR,DUMMY,ZRES,EIG,WRK1,WRK2,
     *                  GHONDO,XINTS,DSH,DDIJ,NOCP,MODE,
     *                  NNXYZ,NUNIQ,NXYZF,NFOCK,NINT,NSCHWZ,
     *                  NROT,NOCC,NVIR,L1,L3,NSH2,MAXG,MXG2,
     *                  ID_D,ID_F,DMYX,WRK2MY,
     *                  DSH1,DSH2,DSH3,FSH1,FSH2,FSH3,NAOMX)
C
         ERR = ZERO
         IUNIQ=0
         DO 340 IXYZ=1,NNXYZ
            IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
            IF(NOCP(IXYZ).NE.0) GO TO 340
            AKDEN = DDOT(NROT,PDIR(1,IUNIQ),1,ZRES(1,IUNIQ),1)
C
C              THIS TERMINATION IS SUPPOSED TO BE DUE TO THE
C              MATRIX -A-'S NOT BEING POSITIVE DEFINITE.  A TEST
C              CALCULATION SHOWED THAT A CASE WITH UHF INSTABILITY
C              DID NOT GET INTO THIS ERROR TERMINATION SECTION,
C              SO AN INSTABILITY IN THE ORBITAL HESSIAN MAY BE A
C              NECESSARY BUT NOT SUFFICIENT CONDITION TO GET HERE.
C
            IF(AKDEN.LE.-TOL) THEN
               IF(MASWRK) WRITE(IW,9050)
               IF(MASWRK) WRITE(IW,9060)
               CALL ABRT
            END IF
            AK = BKNUM(IXYZ)/AKDEN
            CALL DAXPY(NROT, AK,PDIR(1,IUNIQ),1,   YA(1, IXYZ),1)
            CALL DAXPY(NROT,-AK,ZRES(1,IUNIQ),1,RESID(1,IUNIQ),1)
            DO IROT=1,NROT
               ZRES(IROT,IUNIQ) = PRECND(IROT)*RESID(IROT,IUNIQ)
            ENDDO
C
C              CHECK CONVERGENCE
C
            RNORM = SQRT(DDOT(NROT,RESID(1,IUNIQ),1,RESID(1,IUNIQ),1))
            TEST = RNORM/BNORM(IXYZ)
            IF(TEST.LT.TOL) NOCP(IXYZ)=2
            ERR = MAX(ERR,TEST)
  340    CONTINUE
         IF(MASWRK) THEN
            IF(DIRSCF) THEN
               WRITE(IW,9020) ITER,ERR,NXYZF,NINT,NSCHWZ
            ELSE
               WRITE(IW,9020) ITER,ERR,NXYZF
            END IF
            CALL FLSHBF(IW)
         END IF
         IF(ERR.LT.TOL) GO TO 800
  400 CONTINUE
C
C        CALCULATION DID NOT CONVERGE AFTER TOO MANY CYCLES.
C
      IF(MASWRK) WRITE(IW,9070) MAXIT
      IF(MASWRK) WRITE(IW,9060)
      CALL ABRT
      STOP
C
C        PRINT CONVERGENCE MESSAGE, RESTORE ORIGINAL -NOCP- ARRAY
C
  800 CONTINUE
      IF(MASWRK) WRITE(IW,9080) ITER,NFOCK,NUNIQ
      DO IXYZ=1,NNXYZ
         IF(NOCP(IXYZ).EQ.2) NOCP(IXYZ)=0
      ENDDO
      RETURN
C
 9000 FORMAT(1X,'PRECONDITIONED CONJUGATE GRADIENT SOLVER',5X,
     *          'CONV. TOLERANCE=',1P,E8.2)
 9010 FORMAT(1X,12X,'MAXIMUM',10X,'RESPONSES',8X,'NONZERO',4X,'BLOCKS'/
     *       1X,'ITER',4X,'RESPONSE ERROR',8X,'IMPROVED',3X,
     *          'AO INTEGRALS',3X,'SKIPPED')
 9020 FORMAT(1X,I3,5X,1P,E13.5,0P,8X,I6,3X,I15,I10)
 9030 FORMAT(1X,'ITER',4X,'RESPONSE ERROR',8X,'IMPROVED')
 9040 FORMAT(1X,'THE PRECONDITIONER IS NOT POSITIVE DEFINITE.'/
     *       1X,'THIS MAY BE DUE TO PECULIAR ORBITAL ENERGIES.')
 9050 FORMAT(//1X,'THE ORBITAL HESSIAN IS NOT POSITIVE DEFINITE.'//)
 9060 FORMAT(1X,'MOST OFTEN THIS IS',
     *          ' CAUSED BY USE OF AN INAPPROPRIATE WAVEFUNCTION.'/
     *       1X,'CHANGE SCFTYP, OR CHECK HOMO/LUMO FILLING ORDER.'//)
 9070 FORMAT(//1X,'*** TOO MANY ITERATIONS IN AOCPCG *** MAXIT=',I5/
     *       1X,'THIS VALUE CANNOT BE RAISED BY THE INPUT BECAUSE'/
     *       1X,'MORE CPHF ITERATIONS ARE UNLIKELY TO HELP.'//)
 9080 FORMAT(1X,'THE CPHF HAS CONVERGED AFTER',I3,' ITERATIONS.'/
     *       1X,'IT REQUIRED',I6,' FOCK-LIKE BUILDS TO FIND THE',I4,
     *          ' SYMMETRY UNIQUE RESPONSES.')
      END
C*MODULE CPHF    *DECK DD_AOCPCL
      SUBROUTINE DD_AOCPCL(WAX,C,YA,YNEW,RHS,EIG,WRK1,WRK2,
     *                     GHONDO,XINTS,DSH,DDIJ,NOCP,MODE,
     *                     NNXYZ,NUNIQ,NXYZF,NFOCK,NINT,NSCHWZ,
     *                     NROT,NOCC,NVIR,L1,L3,NSH2,MAXG,MXG2,
     *                     ID_D,ID_F,DMYX,WRK2MY,
     *                     DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK,NAOMX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION WAX(NROT,NNXYZ),C(L1,L1),YA(NROT,NNXYZ),
     *          YNEW(NROT,NNXYZ),RHS(NROT,NUNIQ),EIG(L1),
     *          WRK1(L1,L1),WRK2(L3),GHONDO(MAXG),
     *          XINTS(NSH2),DSH(NSH2),DDIJ(49*MXG2),NOCP(NNXYZ),
     *          DMYX(L1,L1),WRK2MY(L1*L1),
     *          DSHI(*),DSHJ(*),DSHK(*),FSHI(*),FSHJ(*),FSHK(*)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,SCHWRZ
C
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (HALF=0.5D+00)
C
C        --- CLOSED SHELL FOCK-LIKE MATRICES FOR CPHF EQUATIONS ---
C        WE CAN COMPUTE EITHER THE RIGHT HAND SIDE A*YA IN -RHS-
C        OR THE IMPROVED SOLUTION -YNEW- DEPENDING ON THE CALL -MODE-.
C        ONLY ONE OF -YNEW- OR -RHS- SHOULD BE ALLOCATED STORAGE.
C        THE VALUE -MODE- EQUALS 0 IS FOR THE DIIS SOLVER, WHILE
C        THE PCG SOLVER USES 1 AND 2 FOR ITS CALLS.
C        NOTE THAT AT PRESENT THE DISTRIBUTED DATA PROGRAM ALWAYS
C        CALLS THE PCG SOLVER, SO MODE=0 IS UNTESTED.
C
C     COUNT HOW MANY FOCK-LIKE MATRICES ARE NEEDED ON THIS ITERATION
C     -NXYZF- SHOULD BE LESS OR EQUAL TO -NUNIQ-
C     -NFOCK- IS TOTAL FOCK-LIKE BUILDS DURING ALL CPHF ITERATIONS.
C
      NXYZF = 0
      DO IXYZ = 1,NNXYZ
         IF (NOCP(IXYZ).EQ.0) NXYZF = NXYZF+1
      END DO
      NFOCK = NFOCK+NXYZF
C
C     CREATE DISTRIBUTED DA AND FA MATRICES
C
      CALL DDI_CREATE(L1,L1*NXYZF,ID_D)
      CALL DDI_CREATE(L1,L1*NXYZF,ID_F)
C
C           READ EXCHANGE INTEGRALS FOR SCREENING
C
      SCHWRZ = ISCHWZ.EQ.1
      IF(SCHWRZ) THEN
         CALL DAREAD(IDAF,IODA,XINTS,NSH2,54,0)
         CALL VCLR(DSH,1,NSH2)
      END IF
C
C        TRANSFORM CURRENT GUESS AT SOLUTION -YA- TO THE AO BASIS
C        THESE "DENSITY MATRICES" ARE STORED IN DISTRIBUTED MEMORY
C
      IXYZF = 0
      IUNIQ = 0
      DO 270 IXYZ = 1,NNXYZ
         IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
         IF(NOCP(IXYZ).NE.0) GO TO 270
         IXYZF = IXYZF+1
C
                       IKOL = IXYZ
         IF(MODE.EQ.2) IKOL = IUNIQ
         CALL MRARTR(YA(1,IKOL),NOCC,NOCC,NVIR,C(1,NOCC+1),
     *               L1,L1,WRK2,L1)
         CALL MRARBR(C,L1,L1,NOCC,WRK2,L1,L1,WRK1,L1)
C
         DO 260 I=1,L1
            DO 250 J=1,I
               IF (I.EQ.J) THEN
                  DMYX(I,J) = WRK1(I,J) + WRK1(J,I)
               ELSE
                  DMYX(I,J) = WRK1(I,J) + WRK1(J,I)
                  DMYX(J,I) = DMYX(I,J)
               END IF
  250       CONTINUE
  260    CONTINUE
C
C     SET UP THE SCREENING OF INTEGRALS
C
         IF(SCHWRZ) CALL DD_AOSHLD(DMYX,DSH,L1,NSH2)
C
C     FILL OUT CHUNK OF THE DISTRIBUTED DENSITY-LIKE MATRICES
C
         IF(MASWRK) THEN
            DO J_T=1,L1
               ISH_T=(J_T-1)*NXYZF+IXYZF
               CALL DDI_PUT(ID_D,1,L1,ISH_T,ISH_T,DMYX(1,J_T))
            END DO
         END IF
C
  270 CONTINUE
C
C       WAIT TO BE SURE MASTER HAS FINISHED SETTING DISTRIBUTED DENSITY
C
      CALL DDI_SYNC(5064)
C
C  BUILD THE CORRESPONDING "FOCK-LIKE MATRICES" IN DISTRIBUTED MEMORY
C
      CALL DD_AOFLM2(GHONDO,XINTS,DSH,DDIJ,
     *               L1,NXYZF,MAXG,NSH2,MXG2,NINT,NSCHWZ,ID_D,ID_F,
     *               DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK,NAOMX)
C
C  TRANSFORM BACK INTO THE MO BASIS
C
      IXYZF = 0
      IUNIQ = 0
      IPCOUNT = ME-1
      IF(GOPARR) THEN
         IF(MODE.EQ.0) THEN
            CALL VCLR(YNEW,1,NROT*NNXYZ)
         ELSE
            CALL VCLR(RHS ,1,NROT*NUNIQ)
         END IF
      END IF
C
      DO 390 IXYZ = 1,NNXYZ
         IF(NOCP(IXYZ).NE.1) IUNIQ=IUNIQ+1
         IF(NOCP(IXYZ).NE.0) GO TO 390
         IXYZF = IXYZF+1
C
         IPCOUNT=IPCOUNT+1
         IF(MOD(IPCOUNT,NPROC).NE.0) GO TO 390
C
C     GET FOCK LIKE MATRIX
C
         DO J_T=1,L1
            ISH_T=(J_T-1)*NXYZF+IXYZF
            CALL DDI_GET(ID_F,1,L1,ISH_T,ISH_T,DMYX(1,J_T))
         END DO
C
C     SUM UP UPPER AND LOWER TRIANGLES
C     AND HALVE ELEMENTS EXCEPT DIAGONAL
C
         IJ = 0
         DO II=1,L1
            DO JJ=1,II
               IJ=IJ+1
               IF (II.EQ.JJ) THEN
                  WRK2MY(IJ) = DMYX(II,JJ)
               ELSE
                  WRK2MY(IJ) = (DMYX(II,JJ)+DMYX(JJ,II))*HALF
               END IF
            END DO
         END DO
C
         CALL EXPND(WRK2MY,WRK2,L1,0)
         CALL MRARBR(WRK2,L1,L1,L1,C(1,NOCC+1),L1,NVIR,WRK1,L1)
         CALL MRTRBR(C,L1,L1,NOCC,WRK1,L1,NVIR,WRK2,NOCC)
C
C     FORM THE NEW RESPONSE VECTOR.
C     NOTE THAT THE FACTOR OF 8 IS THE 2 FROM EQUATION 13 AND
C     ANOTHER TWO TAKING INTO ACCOUNT THE SYMMETRY OF THE TRANSFORMATION
C     (HAVE TWO TERMS THAT ARE SYMMETRIC, I CALCULATED ONE
C      AND NEED TO MULTIPLY BY TWO WHICH I AM DOING HERE)
C
          IF(MODE.EQ.0) THEN
            IJ = 0
            DO 320 IVIR = NOCC+1,NOCC+NVIR
               DO 310 IOCC= 1,NOCC
                  IJ = IJ + 1
                  YNEW(IJ,IXYZ) = (-WAX(IJ,IXYZ) - 8.0D+00*WRK2(IJ)) /
     *                            (4.0D+00*(EIG(IVIR) - EIG(IOCC)))
  310          CONTINUE
  320       CONTINUE
         ELSE
            IJ = 0
                          IKOL = IXYZ
            IF(MODE.EQ.2) IKOL = IUNIQ
            DO 360 IVIR = NOCC+1,NOCC+NVIR
               DO 350 IOCC= 1,NOCC
                  IJ = IJ + 1
                  RHS(IJ,IUNIQ) = 8.0D+00*WRK2(IJ)
     *                  + (4.0D+00*(EIG(IVIR) - EIG(IOCC)))*YA(IJ,IKOL)
  350          CONTINUE
  360       CONTINUE
         END IF
  390 CONTINUE
C
C       WAIT TO BE SURE WE HAVE FINISHED USING DISTRIBUTED FOCKS
C
      CALL DDI_SYNC(5065)
      CALL DDI_DESTROY(ID_F)
      CALL DDI_DESTROY(ID_D)
      IF(GOPARR) THEN
         IF(MODE.EQ.0) THEN
            CALL DDI_GSUMF(5066,YNEW,NROT*NNXYZ)
         ELSE
            CALL DDI_GSUMF(5067,RHS ,NROT*NUNIQ)
         END IF
      END IF
C
      RETURN
      END
C*MODULE CPHF    *DECK DD_TWOEI
      SUBROUTINE DD_TWOEI(SCFTYP,DIRSCF,
     *                    INTTYP,SCHWRZ,NINT,NSCHWZ,L1,
     *                    XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *                    IA,DSH,NXYZ,
     *                    ID_D,ID_F,NAOMX,
     *                    DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DIRSCF,GOPARR,DSKWRK,MASWRK,OUT
      LOGICAL SCHWRZ
      LOGICAL SCHSKP,SLB,DLB,POPLE,NONCANON,PERM_II,
     *        ABBC,SKIP_SECONDINT,COMP_SECONDINT
C
      DIMENSION XINTS(NSH2),GHONDO(MAXG),DDIJ(*),IA(L1),DSH(NSH2),
     *          DSHI(L1,NXYZ,NAOMX),DSHJ(L1,NXYZ,NAOMX),
     *          DSHK(L1,NXYZ,NAOMX),
     *          FSHI(L1,NXYZ,NAOMX),FSHJ(L1,NXYZ,NAOMX),
     *          FSHK(L1,NXYZ,NAOMX)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /GOUT  / GPOPLE(768),NORG
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /SHLG70/ ISH,JSH,KSH,LSH,IJKLXX(4)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      PARAMETER (ZERO=0.0D+00)
C
C        BOTH IBM'S XL FORTRAN AND LINUX' G77 NEEDED THESE SAVES,
C        OF WHICH THE MOST IMPORTANT SEEM TO BE THE ARGS TO GET/ACC
C
      SAVE ISHOLD,JSHOLD,KSHOLD
      SAVE ABBC,NONCANON,PERM_II,SKIP_SECONDINT,COMP_SECONDINT
      SAVE IBF_L,IBF_H,IBF_LO,IBF_HO
      SAVE JBF_L,JBF_H,JBF_LO,JBF_HO
      SAVE KBF_L,KBF_H,KBF_LO,KBF_HO
      SAVE IP_Y,IL_Y,IP_YO,IL_YO
      SAVE JP_Y,JL_Y,JP_YO,JL_YO
      SAVE KP_Y,KL_Y,KP_YO,KL_YO
C
C     ----- BUILD DISTRIBUTED FOCK-LIKE MATRICES FOR CPHF -----
C     THE DISTRIBUTED DENSITY-LIKE MATRICES MUST EXIST ON ENTRY.
C     THIS CODE IMPLEMENTS ONLY THE 2ND ALGORITHM IN YURI'S PAPER.
C
      ICOUNT_1ST=0
      ICOUNT_2ND=0
      ICOUNT_NCN=0
C
      ISHOLD=0
      JSHOLD=0
      KSHOLD=0
C
      CALL VCLR(FSHI,1,L1*NXYZ*NAOMX)
      CALL VCLR(FSHJ,1,L1*NXYZ*NAOMX)
      CALL VCLR(FSHK,1,L1*NXYZ*NAOMX)
C
C     BOTH STATIC AND DYNAMIC LOAD BALANCING ARE IMPLEMENTED BELOW
C
      SLB = GOPARR  .AND.  IBTYP.EQ.0
      IPCOUNT = ME - 1
      DLB = GOPARR  .AND.  IBTYP.EQ.1
      NEXT = -1
      MINE = -1
C
      NORG   = 0
      IEXCH  = 1
      NINT   = 0
      NSCHWZ = 0
      SCHSKP =.FALSE.
      DENMAX = ZERO
      QQ4 = 1.0D+00
C
C     ----- I SHELL -----
C
      DO 920 II = 1,NSHELL
C
C     ----- CHECK CPU TIME -----
C
      CALL TSECND(TIM)
      IF(TIM.GE.TIMLIM) THEN
         IF(MASWRK) WRITE(IW,9030)
         CALL ABRT
         STOP
      END IF
C
C     ----- J SHELL -----
C
      DO 900 JJ = 1,II
C
C     ----- GO PARALLEL! -----
C
      IF(SLB) THEN
         IPCOUNT = IPCOUNT + 1
         IF (MOD(IPCOUNT,NPROC).NE.0) GO TO 900
      END IF
      IF(DLB) THEN
         MINE = MINE + 1
         IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
         IF (NEXT.NE.MINE) GO TO 900
      END IF
C
C     ----- K SHELL -----
C
      DO 880 KK = 1,II
C
C     ----- L SHELL ----
C
      LL_H=KK
      IF (KK.EQ.II) LL_H=JJ
      DO 860 LL = 1,LL_H
C
      ISH = II
      JSH = JJ
      KSH = KK
      LSH = LL
C
      NONCANON=.FALSE.
      PERM_II=.FALSE.
      ABBC=.FALSE.
      SKIP_SECONDINT=.FALSE.
      COMP_SECONDINT=.FALSE.
C
C RULES TO PERMUTATE ABBC TYPE INTEGRALS, A>B<C
C
      IF ((JSH.EQ.KSH) .AND. (ISH.GT.JSH) .AND.  (JSH.GT.LSH)) THEN
         PERM_II=.TRUE.
         ABBC=.TRUE.
      END IF
C
      IF (LSH.GT.JSH) THEN
         IF ((KSH.EQ.LSH) .AND. (ISH.GT.KSH) .AND.  (JSH.LT.KSH)) THEN
            ABBC=.TRUE.
         END IF
      END IF
C
C RULES TO PERMUTATE ABCD TYPE INTEGRALS, A>B>C>D
C
      IF ((JSH.LT.LSH) .AND. (KSH.GT.LSH) .AND.  (ISH.GT.KSH)) THEN
         SKIP_SECONDINT=.TRUE.
      END IF
C
      IF ((ISH.GT.JSH) .AND. (JSH.GT.KSH) .AND.  (KSH.GT.LSH)) THEN
         COMP_SECONDINT=.TRUE.
      END IF
C
C     GET/ACC REMOTE ISH
C
      IF (ISH.NE.ISHOLD) THEN
         IP_Y=KLOC(ISH)
         IL_Y=KMAX(ISH)-KMIN(ISH)+1
         IBF_L=(IP_Y-1)*NXYZ+1
         IBF_H=IBF_L+NXYZ*IL_Y-1
         CALL DDI_GET(ID_D,1,L1,IBF_L,IBF_H,DSHI)
      END IF
      IF (ISH.NE.ISHOLD) THEN
         IF (ISHOLD.NE.0) THEN
            IP_YO=KLOC(ISHOLD)
            IL_YO=KMAX(ISHOLD)-KMIN(ISHOLD)+1
            IBF_LO=(IP_YO-1)*NXYZ+1
            IBF_HO=IBF_LO+NXYZ*IL_YO-1
            CALL DDI_ACC(ID_F,1,L1,IBF_LO,IBF_HO,FSHI)
            CALL VCLR(FSHI,1,L1*NXYZ*NAOMX)
          END IF
          ISHOLD=ISH
      END IF
C
C     GET/ACC REMOTE JSH
C
      IF (JSH.NE.JSHOLD) THEN
         JP_Y=KLOC(JSH)
         JL_Y=KMAX(JSH)-KMIN(JSH)+1
         JBF_L=(JP_Y-1)*NXYZ+1
         JBF_H=JBF_L+NXYZ*JL_Y-1
         CALL DDI_GET(ID_D,1,L1,JBF_L,JBF_H,DSHJ)
      END IF
      IF (JSH.NE.JSHOLD) THEN
         IF (JSHOLD.NE.0) THEN
            JP_YO=KLOC(JSHOLD)
            JL_YO=KMAX(JSHOLD)-KMIN(JSHOLD)+1
            JBF_LO=(JP_YO-1)*NXYZ+1
            JBF_HO=JBF_LO+NXYZ*JL_YO-1
            CALL DDI_ACC(ID_F,1,L1,JBF_LO,JBF_HO,FSHJ)
            CALL VCLR(FSHJ,1,L1*NXYZ*NAOMX)
         END IF
         JSHOLD=JSH
      END IF
C
C     GET/ACC KSH ONLY FOR NON-CANONICAL INTEGRALS
C
      IF (NONCANON) THEN
C     GET/ACC LOCAL KSH
         IF (KSH.NE.KSHOLD) THEN
            KP_Y=KLOC(KSH)
            KL_Y=KMAX(KSH)-KMIN(KSH)+1
            KBF_L=(KP_Y-1)*NXYZ+1
            KBF_H=KBF_L+NXYZ*KL_Y-1
            CALL DDI_GET(ID_D,1,L1,KBF_L,KBF_H,DSHK)
         END IF
         IF (KSH.NE.KSHOLD) THEN
            IF (KSHOLD.NE.0) THEN
               KP_YO=KLOC(KSHOLD)
               KL_YO=KMAX(KSHOLD)-KMIN(KSHOLD)+1
               KBF_LO=(KP_YO-1)*NXYZ+1
               KBF_HO=KBF_LO+NXYZ*KL_YO-1
               CALL DDI_ACC(ID_F,1,L1,KBF_LO,KBF_HO,FSHK)
               CALL VCLR(FSHK,1,L1*NXYZ*NAOMX)
            END IF
            KSHOLD=KSH
         END IF
      END IF
C
C        ***** FIRST BATCH *****
C
C     MAKE KSH AND LSH IN CORRECT OREDER
C
C        ----- COMPUTE TWO-ELECTRON INTEGRALS ----
C
C     APPLY THE SCHWARZ INEQUALITY, WHICH IS
C     (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C     SEE, FOR EXAMPLE, J.L.WHITTEN, J.CHEM.PHYS. 58,4496-4501(1973)
C
      IF(SCHWRZ) THEN
         IJIJ = (ISH*ISH-ISH)/2 + JSH
         KLKL = (KSH*KSH-KSH)/2 + LSH
         TEST = XINTS(IJIJ)*XINTS(KLKL)
         IF(DIRSCF) THEN
            DENMAX = SCHWDN(DSH,ISH,JSH,KSH,LSH,IA)
            TEST = TEST*DENMAX
         END IF
         SCHSKP = TEST.LT.CUTOFF
         IF(SCHSKP) NSCHWZ = NSCHWZ + 1
      END IF
      POPLE=.TRUE.
      IF(INTTYP.GT.2) POPLE=.FALSE.
      IF(KTYPE(ISH).GT.2) POPLE=.FALSE.
      IF(KTYPE(JSH).GT.2) POPLE=.FALSE.
      IF(KTYPE(KSH).GT.2) POPLE=.FALSE.
      IF(KTYPE(LSH).GT.2) POPLE=.FALSE.
C
      IF (SCHWRZ .AND. SCHSKP) GO TO 840
C
      IF(POPLE) THEN
         CALL GENR70(IEXCH,SCHSKP)
      ELSE
C
C        ----- GET INFORMATION ABOUT ISH AND JSH -----
C        ----- FORM PAIRS OF PRIMITIVES FROM ISH AND JSH -----
C        ----- GET INFORMATION ABOUT KSH AND LSH -----
C
         CALL DD_SHELLS(1,ISH,JSH,KSH,LSH)
         CALL IJPRIM(DDIJ)
         IF(NIJ.EQ.0) GO TO 840
         CALL DD_SHELLS(2,ISH,JSH,KSH,LSH)
         CALL ZQOUT(GHONDO)
C
C        ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
         IF(IJKL.EQ.1) THEN
            CALL S0000(GHONDO,DDIJ)
         ELSE
            CALL GENRAL(GHONDO,DDIJ)
         END IF
      END IF
C
      IF (NONCANON) THEN
         CALL DD_DIRFCK3(SCFTYP,IEXCH,POPLE,GHONDO,
     *                   L1,NINT,NXYZ,NAOMX,
     *                   DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK)
         ICOUNT_NCN=ICOUNT_NCN+1
      ELSE
         CALL DD_DIRFCK1(SCFTYP,IEXCH,POPLE,GHONDO,
     *                   L1,NINT,NXYZ,NAOMX,
     *                   DSHI,DSHJ,FSHI,FSHJ,ABBC)
         ICOUNT_1ST=ICOUNT_1ST+1
      END IF
C
  840 CONTINUE
      IF (NONCANON .OR. SKIP_SECONDINT) GO TO 860
C
C        ***** SECOND BATCH *****
C
C      PERMUTATE (J AND K) OR (J AND L)
C
      IF (PERM_II) THEN
         ITMP_Y=JSH
         JSH=LSH
         LSH=ITMP_Y
      ELSE
         ITMP_Y=JSH
         JSH=KSH
         KSH=ITMP_Y
      END IF
C
C     MAKE KSH AND LSH IN CORRECT OREDER
C
      IF (LSH.GT.KSH) THEN
         ITMP_Y=KSH
         KSH=LSH
         LSH=ITMP_Y
      END IF
C
C        ----- COMPUTE TWO-ELECTRON INTEGRALS ----
C
C     APPLY THE SCHWARZ INEQUALITY, WHICH IS
C     (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C     SEE, FOR EXAMPLE, J.L.WHITTEN, J.CHEM.PHYS. 58,4496-4501(1973)
C
      IF(SCHWRZ) THEN
         IJIJ = (ISH*ISH-ISH)/2 + JSH
         KLKL = (KSH*KSH-KSH)/2 + LSH
         TEST = XINTS(IJIJ)*XINTS(KLKL)
         IF(DIRSCF) THEN
            DENMAX = SCHWDN(DSH,ISH,JSH,KSH,LSH,IA)
            TEST = TEST*DENMAX
         END IF
         SCHSKP = TEST.LT.CUTOFF
         IF(SCHSKP) NSCHWZ = NSCHWZ + 1
      END IF
      POPLE=.TRUE.
      IF(INTTYP.GT.2) POPLE=.FALSE.
      IF(KTYPE(ISH).GT.2) POPLE=.FALSE.
      IF(KTYPE(JSH).GT.2) POPLE=.FALSE.
      IF(KTYPE(KSH).GT.2) POPLE=.FALSE.
      IF(KTYPE(LSH).GT.2) POPLE=.FALSE.
C
      IF (SCHWRZ .AND. SCHSKP) GO TO 820
C
      IF(POPLE) THEN
         CALL GENR70(IEXCH,SCHSKP)
      ELSE
C
C        ----- GET INFORMATION ABOUT ISH AND JSH -----
C        ----- FORM PAIRS OF PRIMITIVES FROM ISH AND JSH -----
C        ----- GET INFORMATION ABOUT KSH AND LSH -----
C
         CALL DD_SHELLS(1,ISH,JSH,KSH,LSH)
         CALL IJPRIM(DDIJ)
         IF(NIJ.EQ.0) GO TO 820
         CALL DD_SHELLS(2,ISH,JSH,KSH,LSH)
         CALL ZQOUT(GHONDO)
C
C        ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
         IF(IJKL.EQ.1) THEN
            CALL S0000(GHONDO,DDIJ)
         ELSE
            CALL GENRAL(GHONDO,DDIJ)
         END IF
      END IF
C
      CALL DD_DIRFCK2(SCFTYP,IEXCH,POPLE,GHONDO,
     *                L1,NINT,NXYZ,NAOMX,
     *                DSHI,DSHJ,FSHI,FSHJ,ABBC)
      ICOUNT_2ND=ICOUNT_2ND+1
C
  820 CONTINUE
      IF(COMP_SECONDINT) THEN
C
C        ***** THIRD BATCH *****
C
C      PERMUTATE (J AND L)
C
      ITMP_Y=JSH
      JSH=LSH
      LSH=ITMP_Y
C
C     MAKE KSH AND LSH IN CORRECT OREDER
C
      IF (LSH.GT.KSH) THEN
        ITMP_Y=KSH
        KSH=LSH
        LSH=ITMP_Y
      END IF
C
C        ----- COMPUTE TWO-ELECTRON INTEGRALS ----
C
C     APPLY THE SCHWARZ INEQUALITY, WHICH IS
C     (II,JJ//KK,LL) .LE.  SQRT( (II,JJ//II,JJ)*(KK,LL//KK,LL) )
C     SEE, FOR EXAMPLE, J.L.WHITTEN, J.CHEM.PHYS. 58,4496-4501(1973)
C
      IF(SCHWRZ) THEN
         IJIJ = (ISH*ISH-ISH)/2 + JSH
         KLKL = (KSH*KSH-KSH)/2 + LSH
         TEST = XINTS(IJIJ)*XINTS(KLKL)
         IF(DIRSCF) THEN
            DENMAX = SCHWDN(DSH,ISH,JSH,KSH,LSH,IA)
            TEST = TEST*DENMAX
         END IF
         SCHSKP = TEST.LT.CUTOFF
         IF(SCHSKP) NSCHWZ = NSCHWZ + 1
      END IF
      POPLE=.TRUE.
      IF(INTTYP.GE.2) POPLE=.FALSE.
      IF(KTYPE(ISH).GT.2) POPLE=.FALSE.
      IF(KTYPE(JSH).GT.2) POPLE=.FALSE.
      IF(KTYPE(KSH).GT.2) POPLE=.FALSE.
      IF(KTYPE(LSH).GT.2) POPLE=.FALSE.
C
      IF (SCHWRZ .AND. SCHSKP) GO TO 860
C
      IF(POPLE) THEN
         CALL GENR70(IEXCH,SCHSKP)
      ELSE
C
C        ----- GET INFORMATION ABOUT ISH AND JSH -----
C        ----- FORM PAIRS OF PRIMITIVES FROM ISH AND JSH -----
C        ----- GET INFORMATION ABOUT KSH AND LSH -----
C
         CALL DD_SHELLS(1,ISH,JSH,KSH,LSH)
         CALL IJPRIM(DDIJ)
         IF(NIJ.EQ.0) GO TO 860
         CALL DD_SHELLS(2,ISH,JSH,KSH,LSH)
         CALL ZQOUT(GHONDO)
C
C        ----- DO INTEGRAL BATCH, SSSS IS A SPECIAL CASE -----
C
         IF(IJKL.EQ.1) THEN
            CALL S0000(GHONDO,DDIJ)
         ELSE
            CALL GENRAL(GHONDO,DDIJ)
         END IF
      END IF
C
      CALL DD_DIRFCK2(SCFTYP,IEXCH,POPLE,GHONDO,
     *                L1,NINT,NXYZ,NAOMX,
     *                DSHI,DSHJ,FSHI,FSHJ,.FALSE.)
      ICOUNT_2ND=ICOUNT_2ND+1
      END IF
C
  860 CONTINUE
  880 CONTINUE
  900 CONTINUE
  920 CONTINUE
C
C     ----- END OF SHELL LOOPS -----
C
C   ACC LAST CHUNKS, WAIT TO BE SURE THESE FINISH
C
      CALL DDI_ACC(ID_F,1,L1,KBF_L,KBF_H,FSHK)
      CALL DDI_ACC(ID_F,1,L1,JBF_L,JBF_H,FSHJ)
      CALL DDI_ACC(ID_F,1,L1,IBF_L,IBF_H,FSHI)
      CALL DDI_SYNC(5068)
C
      IF(DLB) CALL DDI_DLBRESET
      RETURN
C
 9030 FORMAT(//1X,'*** THIS JOB HAS EXHAUSTED ITS CPU TIME ***'/
     *         1X,'     (WHILE COMPUTING 2E- INTEGRALS)'///)
      END
C*MODULE CPHF    *DECK DD_DIRFCK1
      SUBROUTINE DD_DIRFCK1(SCFTYP,IEXCH,POPLE,GHONDO,
     *                      L1,NINT,NXYZ,NAOMX,
     *                      DSHI,DSHJ,FSHI,FSHJ,ABBC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,POPLE,ABBC
C
      DIMENSION DSHI(L1,NXYZ,NAOMX),DSHJ(L1,NXYZ,NAOMX),
     *          FSHI(L1,NXYZ,NAOMX),FSHJ(L1,NXYZ,NAOMX),GHONDO(*)
      DIMENSION IBPOP(4,4)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /FLIPS / IB(4,3)
      COMMON /GOUT  / GPOPLE(768),NORG
      COMMON /INTDEX/ IJGT(784),IJX(784),IJY(784),IJZ(784),IK(784),
     *                KLGT(784),KLX(784),KLY(784),KLZ(784)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SHLG70/ ISH,JSH,KSH,LSH,IJKLXX(4)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJX,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      DATA IBPOP/0,0,0,0,64,16,4,1,128,32,8,2,192,48,12,3/
      DATA HALF /0.5D+00/
      DATA RHF/8HRHF     /
C
C-NEXT STATEMENT IS FOR VARIOUS IBM XLF 3.X AND 5.X COMPILERS-
C
      SAVE IJN,KLN,IBB,JBB,KBB,LBB
C
C     ----- FORM FOCK OPERATOR DIRECTLY FROM INTEGRALS -----
C
      IF(SCFTYP.NE.RHF) THEN
         WRITE(6,*) 'DD_DIRFCK1 IS CODED ONLY FOR RHF'
         CALL ABRT
      END IF
C
C     NOTE THAT OFF-DIAGONAL ELEMENTS WILL NEED TO BE HALVED LATER.
C
      CUTINT = CUTOFF
C
      IF(POPLE) THEN
         SAME = ISH .EQ. KSH .AND. JSH .EQ. LSH
         IBB  = IB(1,IEXCH)
         JBB  = IB(2,IEXCH)
         KBB  = IB(3,IEXCH)
         LBB  = IB(4,IEXCH)
         MINI = KMIN(ISH)
         MINJ = KMIN(JSH)
         MINK = KMIN(KSH)
         MINL = KMIN(LSH)
         MAXI = KMAX(ISH)
         MAXJ = KMAX(JSH)
         MAXK = KMAX(KSH)
         MAXL = KMAX(LSH)
         IANDJ = ISH .EQ. JSH
         KANDL = KSH .EQ. LSH
         LOCI = KLOC(ISH)-MINI
         LOCJ = KLOC(JSH)-MINJ
         LOCK = KLOC(KSH)-MINK
         LOCL = KLOC(LSH)-MINL
      END IF
C
      IJN = 0
      JMAX = MAXJ
      DO 360 I = MINI,MAXI
         IF (IANDJ) JMAX = I
         DO 340 J = MINJ,JMAX
            IJN = IJN+1
            IF(POPLE) THEN
               N1 = IBPOP(IBB,I)+IBPOP(JBB,J)+1+NORG
            ELSE
               N1 = IJGT(IJN)
            END IF
            LMAX = MAXL
            KLN = 0
            DO 320 K =  MINK,MAXK
               IF (KANDL) LMAX = K
               DO 300 L = MINL,LMAX
                  KLN = KLN+1
                  IF(SAME .AND. KLN.GT.IJN) GO TO 340
                  IF(POPLE) THEN
                     NN = N1+IBPOP(KBB,K)+IBPOP(LBB,L)
                     VAL = GPOPLE(NN)
                  ELSE
                     NN = N1+KLGT(KLN)
                     VAL = GHONDO(NN)
                  END IF
C
                  IF(ABS(VAL).LT.CUTINT) GO TO 300
                  NINT = NINT + 1
C
                  II = LOCI+I
                  JJ = LOCJ+J
                  KK = LOCK+K
                  LL = LOCL+L
C
                  IF(II.EQ.JJ) VAL = VAL*HALF
                  IF(KK.EQ.LL) VAL = VAL*HALF
                  IF(II.EQ.KK  .AND.  JJ.EQ.LL) VAL = VAL*HALF
C
C      WE NOW HAVE EVERYTHING READY, PUT INTEGRALS INTO FOCK MATRIX
C
                  IF(SCFTYP.EQ.RHF) THEN
         IF (ABBC) THEN
                DO IXYZ=1, NXYZ
C        ACCESS VIA SEPARATE COLUMNS
C        FIK<-DJL
          FSHI(LL,IXYZ,I-MINI+1)=
     *    FSHI(LL,IXYZ,I-MINI+1)-
     *    VAL*DSHJ(KK,IXYZ,J-MINJ+1)
C        FIL<-DJK
          FSHI(KK,IXYZ,I-MINI+1)=
     *    FSHI(KK,IXYZ,I-MINI+1)-
     *    VAL*DSHJ(LL,IXYZ,J-MINJ+1)
C        FJK<-DIL
          FSHJ(LL,IXYZ,J-MINJ+1)=
     *    FSHJ(LL,IXYZ,J-MINJ+1)-
     *    VAL*DSHI(KK,IXYZ,I-MINI+1)
C        FJL<-DIK
          FSHJ(KK,IXYZ,J-MINJ+1)=
     *    FSHJ(KK,IXYZ,J-MINJ+1)-
     *    VAL*DSHI(LL,IXYZ,I-MINI+1)
                END DO
         ELSE
                DO IXYZ=1, NXYZ
C        ACCESS VIA SEPARATE COLUMNS
C        FIK<-DJL
          FSHI(KK,IXYZ,I-MINI+1)=
     *    FSHI(KK,IXYZ,I-MINI+1)-
     *    VAL*DSHJ(LL,IXYZ,J-MINJ+1)
C        FIL<-DJK
          FSHI(LL,IXYZ,I-MINI+1)=
     *    FSHI(LL,IXYZ,I-MINI+1)-
     *    VAL*DSHJ(KK,IXYZ,J-MINJ+1)
C        FJK<-DIL
          FSHJ(KK,IXYZ,J-MINJ+1)=
     *    FSHJ(KK,IXYZ,J-MINJ+1)-
     *    VAL*DSHI(LL,IXYZ,I-MINI+1)
C        FJL<-DIK
          FSHJ(LL,IXYZ,J-MINJ+1)=
     *    FSHJ(LL,IXYZ,J-MINJ+1)-
     *    VAL*DSHI(KK,IXYZ,I-MINI+1)
                END DO
         END IF
                  END IF
  300          CONTINUE
  320       CONTINUE
  340    CONTINUE
  360 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK DD_DIRFCK2
      SUBROUTINE DD_DIRFCK2(SCFTYP,IEXCH,POPLE,GHONDO,
     *                      L1,NINT,NXYZ,NAOMX,
     *                      DSHI,DSHJ,FSHI,FSHJ,ABBC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,POPLE,ABBC
C
      DIMENSION DSHI(L1,NXYZ,NAOMX),DSHJ(L1,NXYZ,NAOMX),
     *          FSHI(L1,NXYZ,NAOMX),FSHJ(L1,NXYZ,NAOMX),GHONDO(*)
      DIMENSION IBPOP(4,4)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /FLIPS / IB(4,3)
      COMMON /GOUT  / GPOPLE(768),NORG
      COMMON /INTDEX/ IJGT(784),IJX(784),IJY(784),IJZ(784),IK(784),
     *                KLGT(784),KLX(784),KLY(784),KLZ(784)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SHLG70/ ISH,JSH,KSH,LSH,IJKLXX(4)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJX,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      DATA IBPOP/0,0,0,0,64,16,4,1,128,32,8,2,192,48,12,3/
      DATA HALF /0.5D+00/
      DATA RHF/8HRHF     /
C
C-NEXT STATEMENT IS FOR VARIOUS IBM XLF 3.X AND 5.X COMPILERS-
C
      SAVE IJN,KLN,IBB,JBB,KBB,LBB
C
C     ----- FORM FOCK OPERATOR DIRECTLY FROM INTEGRALS -----
C
      IF(SCFTYP.NE.RHF) THEN
         WRITE(6,*) 'DD_DIRFCK1 IS CODED ONLY FOR RHF'
         CALL ABRT
      END IF
C
C     NOTE THAT OFF-DIAGONAL ELEMENTS WILL NEED TO BE HALVED LATER.
C
      CUTINT = CUTOFF
C
      IF(POPLE) THEN
         SAME = ISH .EQ. KSH .AND. JSH .EQ. LSH
         IBB  = IB(1,IEXCH)
         JBB  = IB(2,IEXCH)
         KBB  = IB(3,IEXCH)
         LBB  = IB(4,IEXCH)
         MINI = KMIN(ISH)
         MINJ = KMIN(JSH)
         MINK = KMIN(KSH)
         MINL = KMIN(LSH)
         MAXI = KMAX(ISH)
         MAXJ = KMAX(JSH)
         MAXK = KMAX(KSH)
         MAXL = KMAX(LSH)
         IANDJ = ISH .EQ. JSH
         KANDL = KSH .EQ. LSH
         LOCI = KLOC(ISH)-MINI
         LOCJ = KLOC(JSH)-MINJ
         LOCK = KLOC(KSH)-MINK
         LOCL = KLOC(LSH)-MINL
      END IF
C
      IJN = 0
      JMAX = MAXJ
      DO 360 I = MINI,MAXI
         IF (IANDJ) JMAX = I
         DO 340 J = MINJ,JMAX
            IJN = IJN+1
            IF(POPLE) THEN
               N1 = IBPOP(IBB,I)+IBPOP(JBB,J)+1+NORG
            ELSE
               N1 = IJGT(IJN)
            END IF
            LMAX = MAXL
            KLN = 0
            DO 320 K =  MINK,MAXK
               IF (KANDL) LMAX = K
               DO 300 L = MINL,LMAX
                  KLN = KLN+1
                  IF(SAME .AND. KLN.GT.IJN) GO TO 340
                  IF(POPLE) THEN
                     NN = N1+IBPOP(KBB,K)+IBPOP(LBB,L)
                     VAL = GPOPLE(NN)
                  ELSE
                     NN = N1+KLGT(KLN)
                     VAL = GHONDO(NN)
                  END IF
C
                  IF(ABS(VAL).LT.CUTINT) GO TO 300
                  NINT = NINT + 1
C
                  II = LOCI+I
                  JJ = LOCJ+J
                  KK = LOCK+K
                  LL = LOCL+L
C
                  IF(II.EQ.JJ) VAL = VAL*HALF
                  IF(KK.EQ.LL) VAL = VAL*HALF
                  IF(II.EQ.KK  .AND.  JJ.EQ.LL) VAL = VAL*HALF
C
C      WE NOW HAVE EVERYTHING READY, PUT INTEGRALS INTO FOCK MATRIX
C
                  VAL2 = VAL+VAL
                  VAL4 = VAL2+VAL2
C
                  IF(SCFTYP.EQ.RHF) THEN
         IF (ABBC) THEN
                DO IXYZ=1, NXYZ
C        ACCESS VIA SEPARATE COLUMNS
C        FIJ<-DKL
          FSHI(JJ,IXYZ,I-MINI+1)=
     *    FSHI(JJ,IXYZ,I-MINI+1)+
     *    VAL4*DSHJ(KK,IXYZ,L-MINL+1)
C        FKL<-DIJ
          FSHJ(KK,IXYZ,L-MINL+1)=
     *    FSHJ(KK,IXYZ,L-MINL+1)+
     *    VAL4*DSHI(JJ,IXYZ,I-MINI+1)
                END DO
          ELSE
                DO IXYZ=1, NXYZ
C        ACCESS VIA SEPARATE COLUMNS
C        FIJ<-DKL
          FSHI(JJ,IXYZ,I-MINI+1)=
     *    FSHI(JJ,IXYZ,I-MINI+1)+
     *    VAL4*DSHJ(LL,IXYZ,K-MINK+1)
C        FKL<-DIJ
          FSHJ(LL,IXYZ,K-MINK+1)=
     *    FSHJ(LL,IXYZ,K-MINK+1)+
     *    VAL4*DSHI(JJ,IXYZ,I-MINI+1)
                END DO
          END IF
                  END IF
  300          CONTINUE
  320       CONTINUE
  340    CONTINUE
  360 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK DD_DIRFCK3
      SUBROUTINE DD_DIRFCK3(SCFTYP,IEXCH,POPLE,GHONDO,
     *                      L1,NINT,NXYZ,NAOMX,
     *                      DSHI,DSHJ,DSHK,FSHI,FSHJ,FSHK)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,OUT,POPLE
C
      DIMENSION DSHI(L1,NXYZ,NAOMX),DSHJ(L1,NXYZ,NAOMX),
     *          DSHK(L1,NXYZ,NAOMX),
     *          FSHI(L1,NXYZ,NAOMX),FSHJ(L1,NXYZ,NAOMX),
     *          FSHK(L1,NXYZ,NAOMX),
     *          GHONDO(*)
      DIMENSION IBPOP(4,4)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      COMMON /FLIPS / IB(4,3)
      COMMON /GOUT  / GPOPLE(768),NORG
      COMMON /INTDEX/ IJGT(784),IJX(784),IJY(784),IJZ(784),IK(784),
     *                KLGT(784),KLX(784),KLY(784),KLZ(784)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SHLG70/ ISH,JSH,KSH,LSH,IJKLXX(4)
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJX,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      DATA IBPOP/0,0,0,0,64,16,4,1,128,32,8,2,192,48,12,3/
      DATA HALF /0.5D+00/
      DATA RHF/8HRHF     /
C
C-NEXT STATEMENT IS FOR VARIOUS IBM XLF 3.X AND 5.X COMPILERS-
C
      SAVE IJN,KLN,IBB,JBB,KBB,LBB
C
C     ----- FORM FOCK OPERATOR DIRECTLY FROM INTEGRALS -----
C
      IF(SCFTYP.NE.RHF) THEN
         WRITE(6,*) 'DD_DIRFCK1 IS CODED ONLY FOR RHF'
         CALL ABRT
      END IF
C
C     NOTE THAT OFF-DIAGONAL ELEMENTS WILL NEED TO BE HALVED LATER.
C
      CUTINT = CUTOFF
C
      IF(POPLE) THEN
         SAME = ISH .EQ. KSH .AND. JSH .EQ. LSH
         IBB  = IB(1,IEXCH)
         JBB  = IB(2,IEXCH)
         KBB  = IB(3,IEXCH)
         LBB  = IB(4,IEXCH)
         MINI = KMIN(ISH)
         MINJ = KMIN(JSH)
         MINK = KMIN(KSH)
         MINL = KMIN(LSH)
         MAXI = KMAX(ISH)
         MAXJ = KMAX(JSH)
         MAXK = KMAX(KSH)
         MAXL = KMAX(LSH)
         IANDJ = ISH .EQ. JSH
         KANDL = KSH .EQ. LSH
         LOCI = KLOC(ISH)-MINI
         LOCJ = KLOC(JSH)-MINJ
         LOCK = KLOC(KSH)-MINK
         LOCL = KLOC(LSH)-MINL
      END IF
C
      IJN = 0
      JMAX = MAXJ
      DO 360 I = MINI,MAXI
         IF (IANDJ) JMAX = I
         DO 340 J = MINJ,JMAX
            IJN = IJN+1
            IF(POPLE) THEN
               N1 = IBPOP(IBB,I)+IBPOP(JBB,J)+1+NORG
            ELSE
               N1 = IJGT(IJN)
            END IF
            LMAX = MAXL
            KLN = 0
            DO 320 K =  MINK,MAXK
               IF (KANDL) LMAX = K
               DO 300 L = MINL,LMAX
                  KLN = KLN+1
                  IF(SAME .AND. KLN.GT.IJN) GO TO 340
                  IF(POPLE) THEN
                     NN = N1+IBPOP(KBB,K)+IBPOP(LBB,L)
                     VAL = GPOPLE(NN)
                  ELSE
                     NN = N1+KLGT(KLN)
                     VAL = GHONDO(NN)
                  END IF
C
                  IF(ABS(VAL).LT.CUTINT) GO TO 300
                  NINT = NINT + 1
C
                  II = LOCI+I
                  JJ = LOCJ+J
                  KK = LOCK+K
                  LL = LOCL+L
C
                  IF(II.EQ.JJ) VAL = VAL*HALF
                  IF(KK.EQ.LL) VAL = VAL*HALF
                  IF(II.EQ.KK  .AND.  JJ.EQ.LL) VAL = VAL*HALF
C
C      WE NOW HAVE EVERYTHING READY, PUT INTEGRALS INTO FOCK MATRIX
C
                  VAL2 = VAL+VAL
                  VAL4 = VAL2+VAL2
C
                  IF(SCFTYP.EQ.RHF) THEN
                DO IXYZ=1, NXYZ
C        ACCESS VIA SEPARATE COLUMNS
C        FIJ<-DKL
          FSHI(JJ,IXYZ,I-MINI+1)=
     *    FSHI(JJ,IXYZ,I-MINI+1)+
     *    VAL4*DSHK(LL,IXYZ,K-MINK+1)
C        FKL<-DIJ
          FSHK(LL,IXYZ,K-MINK+1)=
     *    FSHK(LL,IXYZ,K-MINK+1)+
     *    VAL4*DSHI(JJ,IXYZ,I-MINI+1)
C        FIK<-DJL
          FSHI(KK,IXYZ,I-MINI+1)=
     *    FSHI(KK,IXYZ,I-MINI+1)-
     *    VAL*DSHJ(LL,IXYZ,J-MINJ+1)
C        FIL<-DJK
          FSHI(LL,IXYZ,I-MINI+1)=
     *    FSHI(LL,IXYZ,I-MINI+1)-
     *    VAL*DSHJ(KK,IXYZ,J-MINJ+1)
C        FJK<-DIL
          FSHJ(KK,IXYZ,J-MINJ+1)=
     *    FSHJ(KK,IXYZ,J-MINJ+1)-
     *    VAL*DSHI(LL,IXYZ,I-MINI+1)
C        FJL<-DIK
          FSHJ(LL,IXYZ,J-MINJ+1)=
     *    FSHJ(LL,IXYZ,J-MINJ+1)-
     *    VAL*DSHI(KK,IXYZ,I-MINI+1)
                END DO
                  END IF
  300          CONTINUE
  320       CONTINUE
  340    CONTINUE
  360 CONTINUE
      RETURN
      END
C*MODULE CPHF    *DECK DD_SHELLS
      SUBROUTINE DD_SHELLS(NELEC,ISH,JSH,KSH,LSH)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL IANDJ,KANDL,SAME,FIRST
C
      DIMENSION IX(84),IY(84),IZ(84),
     *          JX(84),JY(84),JZ(84),
     *          KX(84),KY(84),KZ(84),
     *          LX(84),LY(84),LZ(84)
C
      PARAMETER (MXSH=5000, MXGSH=30, MXGTOT=20000, MXATM=2000)
C
      COMMON /GOUT  / GPOPLE(768),NORG
      COMMON /INTDEX/ IJGT(784),IJX(784),IJY(784),IJZ(784),IK(784),
     *                KLGT(784),KLX(784),KLY(784),KLZ(784)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     +                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     +                NIJ,IJ,KL,IJKL
      COMMON /SHLINF/  GA(MXGSH),CSA(MXGSH),CPA(MXGSH),CDA(MXGSH),
     *                CFA(MXGSH),CGA(MXGSH),CHA(MXGSH),CIA(MXGSH),
     *                 GB(MXGSH),CSB(MXGSH),CPB(MXGSH),CDB(MXGSH),
     *                CFB(MXGSH),CGB(MXGSH),CHB(MXGSH),CIB(MXGSH),
     *                 GC(MXGSH),CSC(MXGSH),CPC(MXGSH),CDC(MXGSH),
     *                CFC(MXGSH),CGC(MXGSH),CHC(MXGSH),CIC(MXGSH),
     *                 GD(MXGSH),CSD(MXGSH),CPD(MXGSH),CDD(MXGSH),
     *                CFD(MXGSH),CGD(MXGSH),CHD(MXGSH),CID(MXGSH),
     *                AX,AY,AZ,BX,BY,BZ,RAB,CX,CY,CZ,DX,DY,DZ,RCD,
     *                NGA,NGB,NGC,NGD
C
      SAVE FIRST,IGT,JGT,KGT,LGT
C
      DATA LX /   0,   1,   0,   0,   2,   0,   0,   1,   1,   0,
     *            3,   0,   0,   2,   2,   1,   0,   1,   0,   1,
     *            4,   0,   0,   3,   3,   1,   0,   1,   0,   2,
     *            2,   0,   2,   1,   1,
     *            5,   0,   0,   4,   4,   1,   0,   1,   0,   3,
     *            3,   2,   0,   2,   0,   3,   1,   1,   2,   2,
     *            1,
     *            6,   0,   0,   5,   5,   1,   0,   1,   0,   4,
     *            4,   2,   0,   2,   0,   4,   1,   1,   3,   3,
     *            0,   3,   3,   2,   1,   2,   1,   2/
      DATA KX /   0,   7,   0,   0,  14,   0,   0,   7,   7,   0,
     *           21,   0,   0,  14,  14,   7,   0,   7,   0,   7,
     *           28,   0,   0,  21,  21,   7,   0,   7,   0,  14,
     *           14,   0,  14,   7,   7,
     *           35,   0,   0,  28,  28,   7,   0,   7,   0,  21,
     *           21,  14,   0,  14,   0,  21,   7,   7,  14,  14,
     *            7,
     *           42,   0,   0,  35,  35,   7,   0,   7,   0,  28,
     *           28,  14,   0,  14,   0,  28,   7,   7,  21,  21,
     *            0,  21,  21,  14,   7,  14,   7,  14/
      DATA JX /   0,  49,   0,   0,  98,   0,   0,  49,  49,   0,
     *          147,   0,   0,  98,  98,  49,   0,  49,   0,  49,
     *          196,   0,   0, 147, 147,  49,   0,  49,   0,  98,
     *           98,   0,  98,  49,  49,
     *          245,   0,   0, 196, 196,  49,   0,  49,   0, 147,
     *          147,  98,   0,  98,   0, 147,  49,  49,  98,  98,
     *           49,
     *          294,   0,   0, 245, 245,  49,   0,  49,   0, 196,
     *          196,  98,   0,  98,   0, 196,  49,  49, 147, 147,
     *            0, 147, 147,  98,  49,  98,  49,  98/
      DATA IX /   1, 344,   1,   1, 687,   1,   1, 344, 344,   1,
     *         1030,   1,   1, 687, 687, 344,   1, 344,   1, 344,
     *         1373,   1,   1,1030,1030, 344,   1, 344,   1, 687,
     *          687,   1, 687, 344, 344,
     *         1716,   1,   1,1373,1373, 344,   1, 344,   1,1030,
     *         1030, 687,   1, 687,   1,1030, 344, 344, 687, 687,
     *          344,
     *         2059,   1,   1,1716,1716, 344,   1, 344,   1,1373,
     *         1373, 687,   1, 687,   1,1373, 344, 344,1030,1030,
     *            1,1030,1030, 687, 344, 687, 344, 687/
      DATA LY /   0,   0,   1,   0,   0,   2,   0,   1,   0,   1,
     *            0,   3,   0,   1,   0,   2,   2,   0,   1,   1,
     *            0,   4,   0,   1,   0,   3,   3,   0,   1,   2,
     *            0,   2,   1,   2,   1,
     *            0,   5,   0,   1,   0,   4,   4,   0,   1,   2,
     *            0,   3,   3,   0,   2,   1,   3,   1,   2,   1,
     *            2,
     *            0,   6,   0,   1,   0,   5,   5,   0,   1,   2,
     *            0,   4,   4,   0,   2,   1,   4,   1,   3,   0,
     *            3,   2,   1,   3,   3,   1,   2,   2/
      DATA KY /   0,   0,   7,   0,   0,  14,   0,   7,   0,   7,
     *            0,  21,   0,   7,   0,  14,  14,   0,   7,   7,
     *            0,  28,   0,   7,   0,  21,  21,   0,   7,  14,
     *            0,  14,   7,  14,   7,
     *            0,  35,   0,   7,   0,  28,  28,   0,   7,  14,
     *            0,  21,  21,   0,  14,   7,  21,   7,  14,   7,
     *           14,
     *            0,  42,   0,   7,   0,  35,  35,   0,   7,  14,
     *            0,  28,  28,   0,  14,   7,  28,   7,  21,   0,
     *           21,  14,   7,  21,  21,   7,  14,  14/
      DATA JY /   0,   0,  49,   0,   0,  98,   0,  49,   0,  49,
     *            0, 147,   0,  49,   0,  98,  98,   0,  49,  49,
     *            0, 196,   0,  49,   0, 147, 147,   0,  49,  98,
     *            0,  98,  49,  98,  49,
     *            0, 245,   0,  49,   0, 196, 196,   0,  49,  98,
     *            0, 147, 147,   0,  98,  49, 147,  49,  98,  49,
     *           98,
     *            0, 294,   0,  49,   0, 245, 245,   0,  49,  98,
     *            0, 196, 196,   0,  98,  49, 196,  49, 147,   0,
     *          147,  98,  49, 147, 147,  49,  98,  98/
      DATA IY /   1,   1, 344,   1,   1, 687,   1, 344,   1, 344,
     *            1,1030,   1, 344,   1, 687, 687,   1, 344, 344,
     *            1,1373,   1, 344,   1,1030,1030,   1, 344, 687,
     *            1, 687, 344, 687, 344,
     *            1,1716,   1, 344,   1,1373,1373,   1, 344, 687,
     *            1,1030,1030,   1, 687, 344,1030, 344, 687, 344,
     *          687,
     *            1,2059,   1, 344,   1,1716,1716,   1, 344, 687,
     *            1,1373,1373,   1, 687, 344,1373, 344,1030,   1,
     *         1030, 687, 344,1030,1030, 344, 687, 687/
      DATA LZ /   0,   0,   0,   1,   0,   0,   2,   0,   1,   1,
     *            0,   0,   3,   0,   1,   0,   1,   2,   2,   1,
     *            0,   0,   4,   0,   1,   0,   1,   3,   3,   0,
     *            2,   2,   1,   1,   2,
     *            0,   0,   5,   0,   1,   0,   1,   4,   4,   0,
     *            2,   0,   2,   3,   3,   1,   1,   3,   1,   2,
     *            2,
     *            0,   0,   6,   0,   1,   0,   1,   5,   5,   0,
     *            2,   0,   2,   4,   4,   1,   1,   4,   0,   3,
     *            3,   1,   2,   1,   2,   3,   3,   2/
      DATA KZ /   0,   0,   0,   7,   0,   0,  14,   0,   7,   7,
     *            0,   0,  21,   0,   7,   0,   7,  14,  14,   7,
     *            0,   0,  28,   0,   7,   0,   7,  21,  21,   0,
     *           14,  14,   7,   7,  14,
     *            0,   0,  35,   0,   7,   0,   7,  28,  28,   0,
     *           14,   0,  14,  21,  21,   7,   7,  21,   7,  14,
     *           14,
     *            0,   0,  42,   0,   7,   0,   7,  35,  35,   0,
     *           14,   0,  14,  28,  28,   7,   7,  28,   0,  21,
     *           21,   7,  14,   7,  14,  21,  21,  14/
      DATA JZ /   0,   0,   0,  49,   0,   0,  98,   0,  49,  49,
     *            0,   0, 147,   0,  49,   0,  49,  98,  98,  49,
     *            0,   0, 196,   0,  49,   0,  49, 147, 147,   0,
     *           98,  98,  49,  49,  98,
     *            0,   0, 245,   0,  49,   0,  49, 196, 196,   0,
     *           98,   0,  98, 147, 147,  49,  49, 147,  49,  98,
     *           98,
     *            0,   0, 294,   0,  49,   0,  49, 245, 245,   0,
     *           98,   0,  98, 196, 196,  49,  49, 196,   0, 147,
     *          147,  49,  98,  49,  98, 147, 147,  98/
      DATA IZ /   1,   1,   1, 344,   1,   1, 687,   1, 344, 344,
     *            1,   1,1030,   1, 344,   1, 344, 687, 687, 344,
     *            1,   1,1373,   1, 344,   1, 344,1030,1030,   1,
     *          687, 687, 344, 344, 687,
     *            1,   1,1716,   1, 344,   1, 344,1373,1373,   1,
     *          687,   1, 687,1030,1030, 344, 344,1030, 344, 687,
     *          687,
     *            1,   1,2059,   1, 344,   1, 344,1716,1716,   1,
     *          687,   1, 687,1373,1373, 344, 344,1373,   1,1030,
     *         1030, 344, 687, 344, 687,1030,1030, 687/
C
      DATA FIRST/.TRUE./
C
      IF(FIRST) THEN
         FIRST=.FALSE.
         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
         LGT = 1
         KGT = LGT * NANGM
         JGT = KGT * NANGM
         IGT = JGT * NANGM
      END IF
C
C     PREPARE SHELL INFORMATION/FOR HONDO INTEGRATION
C
      IF(NELEC.EQ.2) GO TO 200
C
C     ----- PERMUTE ISH AND JSH SHELLS, FOR THEIR TYPE
C
      IANDJ = ISH .EQ. JSH
      INU = ISH
      JNU = JSH
      NGTI = IGT
      NGTJ = JGT
C
C     ----- ISHELL
C
      I = KATOM(INU)
      AX = C(1,I)
      AY = C(2,I)
      AZ = C(3,I)
      I1 = KSTART(INU)
      I2 = I1+KNG(INU)-1
      LIT = KTYPE(INU)
      MINI = KMIN(INU)
      MAXI = KMAX(INU)
      LOCI = KLOC(INU)-MINI
      NGA = 0
      DO 140 I = I1,I2
         NGA = NGA+1
         GA(NGA) = EX(I)
         CSA(NGA) = CS(I)
         CPA(NGA) = CP(I)
         CDA(NGA) = CD(I)
         CFA(NGA) = CF(I)
         CGA(NGA) = CG(I)
         CHA(NGA) = CH(I)
         CIA(NGA) = CI(I)
  140 CONTINUE
C
C     ----- JSHELL
C
      J = KATOM(JNU)
      BX = C(1,J)
      BY = C(2,J)
      BZ = C(3,J)
      J1 = KSTART(JNU)
      J2 = J1+KNG(JNU)-1
      LJT = KTYPE(JNU)
      MINJ = KMIN(JNU)
      MAXJ = KMAX(JNU)
      LOCJ = KLOC(JNU)-MINJ
      NGB = 0
      DO 160 J = J1,J2
         NGB = NGB+1
         GB(NGB) = EX(J)
         CSB(NGB) = CS(J)
         CPB(NGB) = CP(J)
         CDB(NGB) = CD(J)
         CFB(NGB) = CF(J)
         CGB(NGB) = CG(J)
         CHB(NGB) = CH(J)
         CIB(NGB) = CI(J)
  160 CONTINUE
      RAB = ((AX-BX)*(AX-BX) + (AY-BY)*(AY-BY) + (AZ-BZ)*(AZ-BZ))
C
C     ----- PREPARE INDICES FOR PAIRS OF (I,J) FUNCTIONS
C
      IJ = 0
      JMAX = MAXJ
      DO 190 I = MINI,MAXI
         NX = IX(I)
         NY = IY(I)
         NZ = IZ(I)
         IF (IANDJ) JMAX = I
         DO 180 J = MINJ,JMAX
            IJ = IJ+1
            IJX(IJ) = NX+JX(J)
            IJY(IJ) = NY+JY(J)
            IJZ(IJ) = NZ+JZ(J)
            IJGT(IJ) = NGTI*(I-MINI)+NGTJ*(J-MINJ)+1+NORG
  180    CONTINUE
  190 CONTINUE
      RETURN
C     ******
C
C        K AND L SHELL
C
  200 CONTINUE
      KANDL = KSH .EQ. LSH
      SAME = ISH .EQ. KSH .AND. JSH .EQ. LSH
C
C     ----- PERMUTE KSH AND LSH SHELLS, FOR THEIR TYPE
C
      KNU = KSH
      LNU = LSH
      NGTK = KGT
      NGTL = LGT
C
C     ----- K SHELL
C
      K = KATOM(KNU)
      CX = C(1,K)
      CY = C(2,K)
      CZ = C(3,K)
      K1 = KSTART(KNU)
      K2 = K1+KNG(KNU)-1
      LKT = KTYPE(KNU)
      MINK = KMIN(KNU)
      MAXK = KMAX(KNU)
      LOCK = KLOC(KNU)-MINK
      NGC = 0
      DO 260 K = K1,K2
         NGC = NGC+1
         GC(NGC) = EX(K)
         CSC(NGC) = CS(K)
         CPC(NGC) = CP(K)
         CDC(NGC) = CD(K)
         CFC(NGC) = CF(K)
         CGC(NGC) = CG(K)
         CHC(NGC) = CH(K)
         CIC(NGC) = CI(K)
  260 CONTINUE
C
C     ----- LSHELL
C
      L = KATOM(LNU)
      DX = C(1,L)
      DY = C(2,L)
      DZ = C(3,L)
      L1 = KSTART(LNU)
      L2 = L1+KNG(LNU)-1
      LLT = KTYPE(LNU)
      MINL = KMIN(LNU)
      MAXL = KMAX(LNU)
      LOCL = KLOC(LNU)-MINL
      NGD = 0
      DO 280 L = L1,L2
         NGD = NGD+1
         GD(NGD) = EX(L)
         CSD(NGD) = CS(L)
         CPD(NGD) = CP(L)
         CDD(NGD) = CD(L)
         CFD(NGD) = CF(L)
         CGD(NGD) = CG(L)
         CHD(NGD) = CH(L)
         CID(NGD) = CI(L)
  280 CONTINUE
      NROOTS = (LIT+LJT+LKT+LLT-2)/2
      RCD = ((CX-DX)*(CX-DX) + (CY-DY)*(CY-DY) + (CZ-DZ)*(CZ-DZ))
C
C     ----- PREPARE INDICES FOR PAIRS OF (K,L) FUNCTIONS
C
      KL = 0
      LMAX = MAXL
      DO 310 K = MINK,MAXK
         NX = KX(K)
         NY = KY(K)
         NZ = KZ(K)
         IF (KANDL) LMAX = K
         DO 300 L = MINL,LMAX
            KL = KL+1
            KLX(KL) = NX+LX(L)
            KLY(KL) = NY+LY(L)
            KLZ(KL) = NZ+LZ(L)
            KLGT(KL) = NGTK*(K-MINK)+NGTL*(L-MINL)
  300    CONTINUE
  310 CONTINUE
      MAX = KL
      DO 320 I = 1,IJ
      IF (SAME) MAX = I
  320 IK(I) = MAX
      IJKL = IJ*KL
      IF (SAME) IJKL = IJ*(IJ+1)/2
      RETURN
      END
