C 11 APR 08 - MWS - ALLOW PARALLEL MP2 DURING G3(MP2) COMPUTATION
C  7 DEC 07 - MWS - PMP2CHK: FORCE PARALLEL EXECUTION AFTER SYSINP
C 21 MAY 07 - MWS - PMP2CHK: IMPROVE BOTH CHECK AND REAL RUN'S OUTPUT
C 22 DEC 06 - DGF - SYNCHRONISE MP2PAR
C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C  7 SEP 06 - JLB,RMO  - TRAN34: FIX BUG IN VVVO INTEGRAL CLASS
C 22 FEB 06 - MWS - IMPLEMENT OPTION FOR NO SYMMETRY IN MP2 STEP
C 17 JAN 06 - RMO - TRAN2,TRAN3,TRAN34: ALLOW FOR CORES AND VVVO CLASS
C 14 NOV 05 - DGF - PAD COMMON BLOCK ENRGYS
C 19 SEP 05 - GDF - ADJUST COMMON BLOCKS FOR H AND I FUNCTIONS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  1 JUN 05 - CMA - CHANGES FOR ZAPT2 GRADIENTS
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL, ROOT
C 10 NOV 04 - MWS - PJKDMP2: NO NEED TO USE GAMGEN ANYMORE
C  7 SEP 04 - MWS - PARTRAN,MKVVVO,PJKDMP2: TWEAK POPLE/HONDO CALLING
C  3 JUN 04 - MWS - MP2DDI: CORRECT THE UMP DM DELETIONS
C  7 APR 04 - MWS - PJKDMP2: INTRODUCE COARSE/FINE SCREENING LOGIC
C 22 DEC 03 - MWS - MP2DDI: NGLEVL=1 SHOULD FORCE ENERGY ONLY CALC
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  3 SEP 03 - CMA - ALLOW CPHF ITERATION LIMIT, GROUNDWORK FOR ZAPT
C 15 MAY 03 - CMA - CHANGES TO ALLOW DISTRIBUTED UMP2 ENERGY AND GRADS
C 12 DEC 02 - MWS - PARTRAN,MKVVVO: DO IJPRIM IFF HONDO INTEGRAL BLOCK,
C           - DGF - PARTRAN,MKVVVO,PJKDMP2: RESET DLB COUNTER AFTER USE
C  7 AUG 02 - JMS - PAR2PDM: CHANGES RELATED TO NEW SP GRADIENT PACKAGE
C 22 MAY 02 - GDF - TRAN34: ACCOUNT FOR CASE OF NOT DOING VOVO CLASS
C 24 JAN 02 - MWS - PJKDMP2: ALTER CUTOFFS FOR VERY BIG EXPONENTS
C 16 NOV 01 - MWS - MP2DDI: IMPLEMENT MP2PRP KEYWORD, PSETUP: FROM JOSE
C  6 SEP 01 - JAB - FIX LCAO SIZE WARNING
C  1 AUG 01 - MWS - TRAN1,TRAN1_P,TRANO,TRANO_P: REMOVE CUTOFF TEST
C 25 JUN 01 - MWS - PARTRAN,MKVVVO:SMALL ZETA INTS BY RYS, PJKDMP2:TIMIT
C  1 NOV 00 - CMC,MWS - PARTRAN: NSCHWZ/GSUMI TYPO, PSETUP: TRFSYM ARGS
C 11 OCT 00 - GDF - ALLOW USE OF SPHERICAL HARMONICS, NEW PMP2CHK
C 15 SEP 00 - GDF - ENABLE SELECTION OF TRANSFORMED INTEGRALS
C 15 AUG 00 - MWS - PMP2CHK: DISTRIBUTED MEMORY NEED COMPUTED IN MWORDS
C 28 JUL 00 - MWS - FIX CHECK PRINT, RESTORE FULL SYM BEFORE SYMEG CALL
C 11 JUN 00 - MWS - MP2DDI,PMP2CHK: KILL ISPHER=1, CHECK IF MEM LACKING
C 25 MAR 00 - CC,GDF - ZVECTR: FIXED 0 LENGTH SUM. FLSHBF/PRINT CHANGES
C 29 DEC 99 - MWS - CHANGE INTEGRAL SYMMETRY TEST
C 25 SEP 99 - GDF - WP: REWRITTEN TO GREATLY REDUCE DDI TRAFFIC
C  6 JUN 99 - MWS - REWRITE TO AVOID HP OPTIMIZATION PROBLEMS
C  9 APR 99 - GDF - ADD MODULE OF DISTRIBUTED DATA PARALLEL MP2 GRADIENT
C
C  <><><><><><>  PARALLEL MP2 ENERGY AND GRADIENT MODULE  <><><><><><><>
C  <><><><><><>          WRITTEN BY G. FLETCHER           <><><><><><><>
C  G. D. FLETCHER, A. P. RENDELL, AND P. SHERWOOD,
C  MOL. PHYS., VOL. 91, P431 (1997).
C
C        -         -         -         -         -         -         - C
C*MODULE MP2DDI  *DECK MP2DDI
      SUBROUTINE MP2DDI
C
C -----------------------------------------------------------------
C  DRIVING ROUTINE FOR PARALLEL MP2 GRADIENT
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,UMPENG,UMP2GD,ZAPTGD
      LOGICAL MPGRUN,EONLY,DIRTRF
      CHARACTER*8 CXBASIS
C
      COMMON /CXTHRM/ CXTHERM(11),CXZPE,METHCX,ICXBAS,CXBASIS
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /FMCOM / XX(1)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWORD,MEMPRI,MPPROP,
     *                NACORE_MP2PAR,NBCORE_MP2PAR,NOA,NOB,NO,NBF_MP2PAR,
     *                NOMIT,MOCPHF,MAXITC
      COMMON /MP2PTR/ IWMAT,IPMAT,IVECS,IPSCF,IVALS,ILABS,ISCHW,INEED
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /UMPPTR/ IWMATB,IPMATB,IVECSB,IPSCFB,IVALSB,ILABSB
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /ZAPTGR/ NOCD,NOCD1,NOCS,NOCSTR,IXYEXC,ICHIX,ITIA,IZVEC
     *,               ZAPTGD
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      DATA CHECK/8HCHECK   /
      DATA ZAPT/8HZAPT    /
      DATA UHF/8HUHF     /
      DATA RHF/8HRHF     /
      DATA G3MP2/8HG3MP2   /
C
      OUTPUT = MASWRK
      ICHANL = 6
      MPGRUN = .FALSE.
      UMPENG = .FALSE.
      UMP2GD = .FALSE.
      ZAPTGD = .FALSE.
C
C  CHOOSE THE DESIRED COMBINATION OF VIRTUAL AND OCCUPIED INDICES
C     IN THE TRANSFORMED INTEGRALS...
C  NDVOVO, NDVVOO, NDVOOO, NDOOOO ETC. SWITCH THE TYPES DONE
C     BY THE PARTRAN ROUTINE(S)
C  MP2ENG/UMPENG CAUSES AN ENERGY RUN, ONLY, W/O DENSITY OR GRADIENT
C
C  FIRST, CHOOSE THE APPROPRIATE TYPE(S) OF RUN
C
      CALL DERCHK(NDER)
      IF(RUNTYP.EQ.G3MP2) THEN
         IF(ICXBAS.EQ.1) NDER=1
         IF(ICXBAS.EQ.2) NDER=0
      END IF
      EONLY = NGLEVL.EQ.1  .OR.  NHLEVL.EQ.2
      IF((NDER.EQ.0  .AND.  MPPROP.EQ.0) .OR. EONLY) THEN
        MP2ENG = .TRUE.
        IF (SCFTYP.EQ.UHF) UMPENG = .TRUE.
        IF (OSPT.EQ.ZAPT) THEN
           MP2ENG = .FALSE.
           MPGRUN = .TRUE.
        END IF
      ELSE
        MPGRUN = .TRUE.
        IF (SCFTYP.EQ.UHF) UMP2GD = .TRUE.
        IF (OSPT.EQ.ZAPT)  ZAPTGD = .TRUE.
      END IF
C
C NOW FIGURE OUT WHICH DISTRIBUTED ARRAYS WE NEED
C (INITIALIZE ALL TO FALSE)
C
      NDVOVO   = .FALSE.
      NDVVOO   = .FALSE.
      NDVOOO   = .FALSE.
      NDOOOO   = .FALSE.
      NDVVVO   = .FALSE.
      NDVVVV   = .FALSE.
      NDVVOOBA = .FALSE.
      NDVVOOAB = .FALSE.
      NDVVOOBB = .FALSE.
      NDVOVOAB = .FALSE.
      NDVOVOBB = .FALSE.
      NDVOOOBA = .FALSE.
      NDVOOOAB = .FALSE.
      NDVOOOBB = .FALSE.
      NDOOOOAB = .FALSE.
      NDOOOOBB = .FALSE.
C
                 NDCORE = .TRUE.
      IF(MP2ENG) NDCORE = .FALSE.
C
      IF (MP2ENG) THEN
        NDVOVO   = .TRUE.
      END IF
      IF (UMPENG) THEN
        NDVOVOAB = .TRUE.
        NDVOVOBB = .TRUE.
      END IF
      IF (MPGRUN) THEN
        NDVOVO   = .TRUE.
        NDVVOO   = .TRUE.
        NDVOOO   = .TRUE.
        NDOOOO   = .TRUE.
      END IF
      IF (UMP2GD) THEN
        NDVVOOBA = .TRUE.
        NDVVOOAB = .TRUE.
        NDVVOOBB = .TRUE.
        NDVOVOAB = .TRUE.
        NDVOVOBB = .TRUE.
        NDVOOOBA = .TRUE.
        NDVOOOAB = .TRUE.
        NDVOOOBB = .TRUE.
        NDOOOOAB = .TRUE.
        NDOOOOBB = .TRUE.
      END IF
C
C  TITLE
C
      IF (OUTPUT) THEN
        CALL DERCHK(NDER)
        IF(RUNTYP.EQ.G3MP2) THEN
          IF(ICXBAS.EQ.1) NDER=1
          IF(ICXBAS.EQ.2) NDER=0
        END IF
        IF (NDER.EQ.0 .AND. MPPROP.EQ.0) THEN
          IF (SCFTYP.EQ.RHF) WRITE(ICHANL,2)
          IF (SCFTYP.EQ.UHF) WRITE(ICHANL,5)
          IF (OSPT.EQ.ZAPT)  WRITE(ICHANL,3)
        ELSE
          IF (SCFTYP.EQ.RHF) WRITE(ICHANL,1)
          IF (SCFTYP.EQ.UHF) WRITE(ICHANL,4)
          IF (OSPT.EQ.ZAPT)  WRITE(ICHANL,6)
        END IF
        CALL FLSHBF(ICHANL)
      END IF
C
C  MAIN PARAMETERS
C
      NACORE= NACORE_MP2PAR  ! SIMPLEST TO COPY
      NBF   = NBF_MP2PAR     !  DIRECT FROM COMMON MP2PAR
      NMOS  = NQMT           !          AND COMMON INFOA
      NOCC  = NOA            ! FOR CLOSED-SHELL MP2
      NVIR  = NMOS-NOCC
      NACT  = NOCC-NACORE
C
C  USEFUL LENGTHS AND OFFSETS
C
      NBSQ = NBF*NBF
      NBTR = (NBF*NBF+NBF)/2
      NSTR = (NSHELL*NSHELL+NSHELL)/2
      NOV  = NOCC*NVIR
      NOSQ = NOCC*NOCC
      NOP1 = NOCC+1
      NOTR = (NOCC*NOCC+NOCC)/2
      NVSQ = NVIR*NVIR
      NVTR = (NVIR*NVIR+NVIR)/2
      NCP1 = NACORE+1
      NATR = (NACT*NACT+NACT)/2
C
C  RELATED BETA PARAMETERS IF WE ARE DOING UMP2 GRADIENTS
C
      IF (UMPENG.OR.UMP2GD) THEN
        NBCORE = NBCORE_MP2PAR  ! SIMPLEST TO COPY
        NOCCB  = NOB
        NOCCBLD= NOCCB
        IF (NOCCB.EQ.0) NOCCBLD=1
        NVIRB  = NMOS-NOCCB
        NACTB  = NOCCB-NBCORE
        NOVB  = NOCCB*NVIRB
        NOSB  = NOCCB*NOCCB
        NOP1B = NOCCB+1
        NOTB  = (NOCCB*NOCCB+NOCCB)/2
        NVSB  = NVIRB*NVIRB
        NVTB  = (NVIRB*NVIRB+NVIRB)/2
        NCP1B = NBCORE+1
        NATB  = (NACTB*NACTB+NACTB)/2
      END IF
C
C  A FEW PARAMETERS FOR ZAPT GRADIENTS
C
      IF (ZAPTGD) THEN
        NOCD  = NOB
        NOCD1 = NOCD + 1
        NOCS  = NOA - NOB
        NOCSTR= (NOCS*NOCS+NOCS)/2
      END IF
C
C  THIS PARAMETER, USED IN THE TRANSFORMATION ROUTINES,
C  STORES THE START OF THE 'ACTIVE' MO INDICES
C
      IF (MP2ENG) THEN
        IOST = NCP1
      ELSE
        IOST = 1
      END IF
C
      IF (UMPENG) THEN
        IOSTB= NCP1B
      ELSE
        IOSTB= 1
      END IF
C
C  POPLE INTEGRALS NEED SUFFICIENT WORKSPACE FOR SP SHELLS
C
      MXSHL = 4
      DO I = 1, NSHELL
        MXSHL = MAX0(MXSHL,KMAX(I)-KMIN(I)+1)
      END DO
C
C  BOTH CHECK OR REAL RUNS NOW COMPUTE AND PRINT THE MEMORY USAGE
C
      CALL PMP2CHK
      IF (EXETYP.EQ.CHECK) RETURN
C
C  ALLOCATE PRINCIPAL REPLICATED ARRAYS
C
      CALL VALFM(LOADFM)
      IF (MP2ENG.OR.(OSPT.EQ.ZAPT .AND. .NOT.ZAPTGD)) THEN
        IVECS = LOADFM + 1        !  MO COEFFICIENTS
        IVALS = IVECS  + NBSQ     !  ORBITAL ENERGIES
        ILABS = IVALS  + NBF      !  MO LABELS
        ISCHW = ILABS  + NMOS     !  SCHWARZ INTS
        LAST  = ISCHW  + NSTR
        IWMAT = 1
        IPMAT = 1
        IPSCF = 1
        IF (UMPENG) THEN
           IVECSB = LAST          !  BETA MO COEFFICIENTS
           IVALSB = IVECSB + NBSQ !  BETA ORBITAL ENERGIES
           ILABSB = IVALSB + NBF  !  BETA MO LABELS
           LAST   = ILABSB + NMOS
        END IF
        INEED = LAST   - LOADFM
      ELSE IF (UMP2GD) THEN
        IWMAT = LOADFM + 1        !  W(2) MATRIX
        IWMATB= IWMAT  + NBSQ
        IPMAT = IWMATB + NBSQ     !  P(2) MATRIX
        IPMATB= IPMAT  + NBSQ
        IPSCF = IPMATB + NBSQ     !  SCF DENSITY
        IPSCFB= IPSCF  + NBSQ
        IVECS = IPSCFB + NBSQ     !  MO COEFFICIENTS
        IVECSB= IVECS  + NBSQ
        IVALS = IVECSB + NBSQ     !  ORBITAL ENERGIES
        IVALSB= IVALS  + NBF
        ILABS = IVALSB + NBF      !  MO LABELS
        ILABSB= ILABS  + NMOS
        ISCHW = ILABSB + NMOS     !  SCHWARZ INTS
        LAST  = ISCHW  + NSTR
        INEED = LAST   - LOADFM
      ELSE
        IWMAT = LOADFM + 1        !  W(2) MATRIX
        IPMAT = IWMAT  + NBSQ     !  P(2) MATRIX
        IPSCF = IPMAT  + NBSQ     !  SCF DENSITY
        IVECS = IPSCF  + NBSQ     !  MO COEFFICIENTS
        IVALS = IVECS  + NBSQ     !  ORBITAL ENERGIES
        ILABS = IVALS  + NBF      !  MO LABELS
        ISCHW = ILABS  + NMOS     !  SCHWARZ INTS
        LAST  = ISCHW  + NSTR
        IF (ZAPTGD) THEN
          NACD = NACT - NOCS
          NDS = NOCD * NOCS
          NDV = NOCD * NVIR
          NSV = NOCS * NVIR
          IXYEXC = LAST
          ICHIX  = IXYEXC + NOCS           !  ORBITAL ENERGY COMPONENT
          ITIA   = ICHIX  + NOCS           !  CHI X
          IZVEC  = ITIA + NACD*NVIR        !  TIA MATRIX
          LAST   = IZVEC + NDS + NDV + NSV !  Z-VECTOR
        END IF
        INEED = LAST   - LOADFM
      END IF
      CALL GETFM(INEED)
C
C  CREATE THE DISTRIBUTED DATA STRUCTURES
C
      IF (MP2ENG) THEN
C
C  [VO|VO] CLASS - FOR JUST THE ENERGY WE ONLY NEED VOVO CLASS
C                  SPANNING VALENCE/ACTIVE MOS ONLY (NOT CORE)
C  FOR UMP2, WE ALSO NEED THE AABB AND BBBB [VO|VO] INTEGRALS
C
        IF(NDVOVO  ) CALL DDI_CREATE(NBSQ,NATR,D_VOVO)
        IF(NDVOVOAB) CALL DDI_CREATE(NBSQ,NACT*NACTB,D_VOVOAB)
        IF(NDVOVOBB) CALL DDI_CREATE(NBSQ,NATB,D_VOVOBB)
C
      ELSE
C
C  [VO|VO] CLASS - HERE INDEX -O- IS RUNNING OVER -ALL- OCCUPIED MOS
C
        IF(NDVOVO)   CALL DDI_CREATE(NBSQ,NOTR,D_VOVO)
        IF(NDVOVOAB) CALL DDI_CREATE(NBSQ,NOCC*NOCCB,D_VOVOAB)
        IF(NDVOVOBB) CALL DDI_CREATE(NBSQ,NOTB,D_VOVOBB)
C
C  [VO|OO] CLASS
C
        IF(NDVOOO)   CALL DDI_CREATE(NVIR, NOTR*NOCC, D_VOOO)
        IF(NDVOOOAB) CALL DDI_CREATE(NVIR, NOCC*NOTB, D_VOOOAB)
        IF(NDVOOOAB) CALL DDI_CREATE(NVIRB,NOCCB*NOTR,D_VOOOBA)
        IF(NDVOOOAB) CALL DDI_CREATE(NVIRB,NOCCB*NOTB,D_VOOOBB)
C
C  [VV|OO] CLASS
C  FOR ZAPT, CREATE THIS CLASS AFTER [OO|OO] INTEGRALS
C
        IF(.NOT.ZAPTGD .AND. NDVVOO) CALL DDI_CREATE(NBTR,NOTR,D_VVOO)
        IF(NDVVOOAB) CALL DDI_CREATE(NBTR,NOTB,D_VVOOAB)
        IF(NDVVOOBA) CALL DDI_CREATE(NBTR,NOTR,D_VVOOBA)
        IF(NDVVOOBB) CALL DDI_CREATE(NBTR,NOTB,D_VVOOBB)
C
C  [OO|OO] CLASS
C
        IF(NDOOOO)   CALL DDI_CREATE(NOTR,NOTR,D_OOOO)
        IF(NDOOOOAB) CALL DDI_CREATE(NOTB,NOTR,D_OOOOAB)
        IF(NDOOOOBB) CALL DDI_CREATE(NOTB,NOTB,D_OOOOBB)
C
C  [VV|OO] CLASS FOR ZAPT
C
        IF(ZAPTGD .AND. NDVVOO) CALL DDI_CREATE(NBTR,NOTR,D_VVOO)
C
      END IF
C
C  SET UMP2GD = TRUE EVEN IF WE ARE ONLY DOING UMP2 ENERGY
C
      IF (UMPENG) UMP2GD = .TRUE.
C
      IF(NOSYMT.EQ.1) CALL SYMOFF
C
C  GET DATA FOR INTEGRALS
C
      CALL PSETUP(XX(IVECS)
     *,           XX(IVECSB)
     *,           XX(IVALS)
     *,           XX(IVALSB)
     *,           XX(ISCHW)
     *,           XX(ILABS)
     *,           XX(ILABSB))
C
C  COMPUTE MO INTEGRALS AND MP2 ENERGY CORRECTION
C
      CALL MOINTS(XX(IVECS)
     *,           XX(IVECSB)
     *,           XX(IVALS)
     *,           XX(IVALSB)
     *,           XX(ISCHW)
     *,           XX(ILABS)
     *,           XX(ILABSB))
C
C  FINISHED WITH VOVO INTEGRALS, RETURN V,E,L,S WORKSPACES
C
      IF (MP2ENG) THEN
         IF(NDVOVOBB) CALL DDI_DESTROY( D_VOVOBB)
         IF(NDVOVOAB) CALL DDI_DESTROY( D_VOVOAB)
         IF(NDVOVO)   CALL DDI_DESTROY( D_VOVO )
         CALL RETFM(INEED)
         RETURN
      END IF
C
C  FORM MP2 1-PARTICLE DENSITY MATRICES
C
      CALL DERCHK(NDER)
      IF(RUNTYP.EQ.G3MP2) THEN
         IF(ICXBAS.EQ.1) NDER=1
         IF(ICXBAS.EQ.2) NDER=0
      END IF
      IF((NDER.GT.0  .OR.  MPPROP.EQ.1)  .AND.  .NOT.EONLY) THEN
         IF(UMP2GD) THEN
           CALL UPAR1PDM(XX(IVECS),XX(IVECSB),XX(IVALS),XX(IVALSB),
     *                   XX(IPMAT),XX(IPMATB),XX(IPSCF),XX(IPSCFB),
     *                   XX(IWMAT),XX(IWMATB),XX(ISCHW),XX(ILABS),
     *                   XX(ILABSB))
         ELSE IF(ZAPTGD) THEN
           CALL ZPAR1PDM(XX(IVECS),XX(IVALS),XX(IPMAT),XX(IPSCF),
     *                   XX(IWMAT),XX(ISCHW),XX(ILABS),XX(IXYEXC),
     *                   XX(ITIA))
         ELSE
           CALL PAR1PDM(XX(IVECS),XX(IVALS),XX(IPMAT),XX(IPSCF),
     *                  XX(IWMAT),XX(ISCHW),XX(ILABS))
         END IF
         IF(NPRINT.NE.-5) CALL MP2NOS
         IF(MPPROP.EQ.1) THEN
            IF(NDVOVOBB) CALL DDI_DESTROY( D_VOVOBB)
            IF(NDVOVOAB) CALL DDI_DESTROY( D_VOVOAB)
            IF(ZAPTGD)   CALL DDI_DESTROY( D_OOOO  )
            IF(ZAPTGD)   CALL DDI_DESTROY( D_VOOO  )
            IF(NDVOVO)   CALL DDI_DESTROY( D_VOVO  )
            CALL RETFM(INEED)
         END IF
      ELSE
       IF (ZAPTGD) THEN
         IF(NDVVOO)   CALL DDI_DESTROY( D_VVOO)
         IF(NDOOOO)   CALL DDI_DESTROY( D_OOOO)
         IF(NDVOOO)   CALL DDI_DESTROY( D_VOOO)
         IF(NDVOVO)   CALL DDI_DESTROY( D_VOVO)
       ELSE
         IF(NDOOOOBB) CALL DDI_DESTROY( D_OOOOBB)
         IF(NDOOOOAB) CALL DDI_DESTROY( D_OOOOAB)
         IF(NDOOOO)   CALL DDI_DESTROY( D_OOOO)
         IF(NDVVOOBB) CALL DDI_DESTROY( D_VVOOBB)
         IF(NDVVOOBA) CALL DDI_DESTROY( D_VVOOBA)
         IF(NDVVOOAB) CALL DDI_DESTROY( D_VVOOAB)
         IF(NDVVOO)   CALL DDI_DESTROY( D_VVOO)
         IF(NDVOOOBB) CALL DDI_DESTROY( D_VOOOBB)
         IF(NDVOOOBA) CALL DDI_DESTROY( D_VOOOBA)
         IF(NDVOOOAB) CALL DDI_DESTROY( D_VOOOAB)
         IF(NDVOOO)   CALL DDI_DESTROY( D_VOOO)
         IF(NDVOVOBB) CALL DDI_DESTROY( D_VOVOBB)
         IF(NDVOVOAB) CALL DDI_DESTROY( D_VOVOAB)
         IF(NDVOVO)   CALL DDI_DESTROY( D_VOVO)
       END IF
       CALL RETFM(INEED)
      END IF
C
      IF(NOSYMT.EQ.1) CALL SYMON
      RETURN
C
    1 FORMAT(///1X,29('-'),5X,30('-')/
     *          1X,'DISTRIBUTED DATA MP2 GRADIENT',
     *          5X,'PROGRAM WRITTEN BY G. FLETCHER'/
     *          1X,29('-'),5X,30('-')/)
    2 FORMAT(///1X,27('-'),5X,30('-')/
     *          1X,'DISTRIBUTED DATA MP2 ENERGY',
     *          5X,'PROGRAM WRITTEN BY G. FLETCHER'/
     *          1X,27('-'),5X,30('-')/)
    3 FORMAT(///1X,29('-'),5X,30('-')/
     *          1X,'DISTRIBUTED DATA ZAPT2 ENERGY',
     *          5X,'PROGRAM WRITTEN BY G. FLETCHER'/
     *          1X,29('-'),5X,30('-')/)
    4 FORMAT(///1X,30('-'),5X,28('-')/
     *          1X,'DISTRIBUTED DATA UMP2 GRADIENT',
     *          5X,'PROGRAM WRITTEN BY C. AIKENS'/
     *          1X,30('-'),5X,28('-')/)
    5 FORMAT(///1X,28('-'),5X,28('-')/
     *          1X,'DISTRIBUTED DATA UMP2 ENERGY',
     *          5X,'PROGRAM WRITTEN BY C. AIKENS'/
     *          1X,28('-'),5X,28('-')/)
    6 FORMAT(///1X,31('-'),5X,28('-')/
     *          1X,'DISTRIBUTED DATA ZAPT2 GRADIENT',
     *          5X,'PROGRAM WRITTEN BY C. AIKENS'/
     *          1X,31('-'),5X,28('-')/)
      END
C*MODULE MP2DDI  *DECK PSETUP
      SUBROUTINE PSETUP(CMO,CMOB,EORB,EORBB,SCHWA,MOLABS,MOLABSB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000, MXAO=8192)
C
      LOGICAL OUT,OUTPUT,MP2ENG,UMP2GD,GOPARR,DSKWRK,MASWRK
C
      DIMENSION CMO(*),EORB(*),SCHWA(*),MOLABS(*)
      DIMENSION CMOB(*),EORBB(*),MOLABSB(*)
C
      COMMON /B     / CO(MXSH,3)
      COMMON /FMCOM / XX(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
C
      PARAMETER (ONE=1.0D+00, TEN=10.0D+00, RLN10=2.30258D+00)
C
      DATA CHECK/8HCHECK   /
C
C -----------------------------------------------------------------
C  SET UP FOR INTEGRAL CODES, SCREENING
C -----------------------------------------------------------------
C
C  INITIALISE ERI COMPUTATION (= RELEVENT PARTS OF DEBUT)
C
      TOL = RLN10*ITOL
      CUTOFF = ONE/(TEN**ICUT)
C
      DO I = 1, NBF
        IA(I) = (I*I-I)/2
      END DO
C
C  INITIALIZATIONS FOR POPLE INTEGRALS
C
      DO I = 1, NSHELL
        ICC = KATOM(I)
        CO(I,1) = C(1,ICC)
        CO(I,2) = C(2,ICC)
        CO(I,3) = C(3,ICC)
      END DO
C
C  READ MO COEFFICIENTS
C
      CALL DAREAD(IDAF,IODA,CMO,NBSQ,15,0)
      MAXC = IDAMAX(NUM*NQMT,CMO,1)
      IF(ABS(CMO(MAXC)).GT.1.0D+02) THEN
         MAXM = 1 + MAXC/NUM
         MAXA = MAXC - NUM*(MAXM-1)
         IF(MASWRK) WRITE(IW,9010) ABS(CMO(MAXC)),MAXA,MAXM
      END IF
      IF(UMP2GD) THEN
        CALL DAREAD(IDAF,IODA,CMOB,NBSQ,19,0)
        MAXC = IDAMAX(NUM*NQMT,CMOB,1)
        IF(ABS(CMOB(MAXC)).GT.1.0D+02) THEN
           MAXM = 1 + MAXC/NUM
           MAXA = MAXC - NUM*(MAXM-1)
           IF(MASWRK) WRITE(IW,9020) ABS(CMOB(MAXC)),MAXA,MAXM
        END IF
      END IF
C
C
C  READ ORBITAL ENERGIES
C
      CALL DAREAD(IDAF,IODA,EORB,NBF,17,0)
      IF(UMP2GD) CALL DAREAD(IDAF,IODA,EORBB,NBF,21,0)
C
C  READ EXCHANGE INTEGRALS (OVER SHELLS) FOR SCREENING
C
      IF(ISCHWZ.GT.0) THEN
         CALL DAREAD(IDAF,IODA,SCHWA,NSTR,54,0)
      ELSE
         CALL DCOPY(NSTR,ONE,0,SCHWA,1)
      END IF
C
C  GET IRREP NUMBER ASSIGNMENTS
C
      CALL VALFM(LOADFM)
      LS     = LOADFM + 1
      LQ     = LS     + NBTR
      LWRK   = LQ     + NBSQ
      LMOSYM = LWRK   + NBF
      LMODEG = LMOSYM + NBF
      LAST   = LMODEG + NBF
      NEED   = LAST   - LOADFM
      CALL GETFM(NEED)
      IF(EXETYP.EQ.CHECK) GO TO 300
C
      CALL DAREAD(IDAF,IODA,XX(LS),NBTR,12,0)
      CALL DAREAD(IDAF,IODA,XX(LQ),NBSQ,45,0)
      CALL TRFSYM(XX(LMOSYM),MOLABS,XX(LMODEG),XX(LQ),
     *            XX(LS),CMO,XX(LWRK),IA,NQMT,NBF,NQMT,NBF)
      IF(UMP2GD) THEN
        CALL DAREAD(IDAF,IODA,XX(LQ),NBSQ,45,0)
        CALL TRFSYM(XX(LMOSYM),MOLABSB,XX(LMODEG),XX(LQ),
     *              XX(LS),CMOB,XX(LWRK),IA,NQMT,NBF,NQMT,NBF)
      END IF
C
  300 CONTINUE
      CALL RETFM(NEED)
      RETURN
 9010 FORMAT(/1X,'*** WARNING: THE MAXIMUM LCAO COEF=',F15.6,
     *           ', FOR AO',I6,' IN MO=',I6,','/
     *        1X,'EXCEEDS 100.  ADDITIONAL INPUTS MAY BE REQUIRED TO',
     *           ' OBTAIN GOOD MP2 ACCURACY:'/
     *        1X,' $CONTRL ICUT=10 OR 11'/
     *        1X,' $SCF    CONV=2.5D-07 FDIFF=.FALSE.'/)
 9020 FORMAT(/1X,'*** WARNING: THE MAXIMUM LCAO COEF=',F15.6,
     *           ', FOR AO',I6,' IN BETA MO=',I6,','/
     *        1X,'EXCEEDS 100.  ADDITIONAL INPUTS MAY BE REQUIRED TO',
     *           ' OBTAIN GOOD MP2 ACCURACY:'/
     *        1X,' $CONTRL ICUT=10 OR 11'/
     *        1X,' $SCF    CONV=2.5D-07 FDIFF=.FALSE.'/)
      END
C*MODULE MP2DDI  *DECK MOINTS
      SUBROUTINE MOINTS(CMO,CMOB,EORB,EORBB,SCHWA,MOLABS,MOLABSB)
C
C -----------------------------------------------------------------
C  DRIVER FOR PARALLEL 4-INDEX TRANSFORMATION USING DDI
C  (PSETUP,MOINTS,PARTRAN,SYMIJ,SYMIJKL,PARSHEL,TRAN1,TRAN1_P,
C   TRAN2,TRAN3,TRAN34,PEMP2,ZAPTE)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER ( MXSH=5000, MXGSH=30, MXG2=MXGSH*MXGSH, MXATM=2000 )
      LOGICAL OUTPUT,MP2ENG,UMP2GD,ZAPTGD,ABELPT
      INTEGER MOLABS(*),MOLABSB(*)
      DOUBLE PRECISION CMO(NBF,*),EORB(*),SCHWA(*)
      DOUBLE PRECISION CMOB(NBF,*),EORBB(*)
C
      COMMON /FMCOM / XX(1)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWORD,MEMPRI,MPPROP,
     *                NACORE_MP2PAR,NBCORE_MP2PAR,NOA,NOB,NO,NBF_MP2PAR,
     *                NOMIT,MOCPHF,MAXITC
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TSYM(432),INVT(48),NT
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /ZAPTGR/ NOCD,NOCD1,NOCS,NOCSTR,IXYEXC,ICHIX,ITIA,IZVEC
     *,               ZAPTGD
C
      DATA ZAPT/8HZAPT    /
C
      CALL VALFM(LOADFM)
      IGOUT = 1     + LOADFM
      ITRAN = IGOUT + MXSHL**4
      CALL DDI_DISTRIB( D_VOVO, 0, ILO, IHI, JLO, JHI )
      IF (MP2ENG) THEN
        ITMP1 = ITRAN + MXSHL*MXSHL*NBF*NACT
        ITMP2 = ITMP1 + MAX0(NBSQ,JHI*MXSHL*NVIR)
        IDDIJ = ITMP2 + MAX0(NBSQ,JHI*MXSHL*NVIR)
      ELSE
        ITMP1 = ITRAN + MXSHL*MXSHL*NBF*NOCC
        ITMP2 = ITMP1 + MAX0(JHI*MXSHL*NVIR,
     *                  MAX0(NBSQ,MAX0(NOTR,NOTB)*MXSHL*MXSHL))
        IDDIJ = ITMP2 + MAX0(NBSQ,JHI*MXSHL*NVIR)
      END IF
      ITRANB  = IDDIJ + 49*MXG2
      ITMP1B  = ITRANB
      ITMP2B  = ITRANB
      IF (UMP2GD) THEN
        CALL DDI_DISTRIB( D_VOVOAB, 0, ILO, IHI, JLO, JHI )
        IF (MP2ENG) THEN
          ITRANB= IDDIJ + 49*MXG2
          ITMP1B= ITRANB+ MXSHL*MXSHL*NBF*NACTB
          ITMP2B= ITMP1B+ MAX0(NBSQ,JHI*MXSHL*NVIRB)
          LAST  = ITMP2B+ JHI*MXSHL*NVIRB
        ELSE
          ITRANB= IDDIJ + 49*MXG2
          ITMP1B= ITRANB+ MXSHL*MXSHL*NBF*NOCCB
          ITMP2B= ITMP1B+ MAX0(NBSQ,JHI*MXSHL*NVIRB)
          LAST  = ITMP2B+ JHI*MXSHL*NVIRB
        END IF
      ELSE
        ITRANB= IDDIJ + 49*MXG2
        ITMP1B= ITRANB
        ITMP2B= ITRANB
        LAST  = ITRANB
      END IF
      NEED  = LAST  - LOADFM
      CALL GETFM(NEED)
C
C  IN CASE OF NON-ABELIAN POINT GROUPS
C
      NTSAVE = NT
      IF (.NOT.ABELPT()) NT = 1
      CALL PARTRAN(SCHWA
     P,            CMO,CMOB
     A,            XX(IGOUT)
     R,            XX(ITRAN),XX(ITRANB)
     T,            XX(ITMP1),XX(ITMP1B)
     R,            XX(ITMP2),XX(ITMP2B)
     A,            XX(IDDIJ)
     N,            MOLABS,MOLABSB)
      NT = NTSAVE
C
C  COMPUTE MP2 ENERGY CORRECTION
C  (FOR ZAPT GRADIENTS, ENERGY WILL BE CALCULATED LATER)
C
      IF (OSPT.EQ.ZAPT) THEN
        IF (.NOT.ZAPTGD) THEN
          CALL ZAPTE(EORB,XX(ITMP1),XX(ITMP2),XX(ITRAN))
        END IF
      ELSE IF (UMP2GD) THEN
        CALL PEUMP2(EORB,EORBB,XX(ITMP1),XX(ITMP2))
      ELSE
        CALL PEMP2(EORB,XX(ITMP1))
      END IF
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE MP2DDI  *DECK PARTRAN
      SUBROUTINE PARTRAN(SCHWA,CMO,CMOB,GOUT,TRAN,TRANB,TMP1,TMP1B,
     *                   TMP2,TMP2B,DDIJ,MOLABS,MOLABSB)
C
C -----------------------------------------------------------------
C  PARALLEL TRANSFORMATION ROUTINE
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000, MXAO=8192)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      LOGICAL POPLE,PACK2E,IANDJ,KANDL,SAME,OUT,GOPARR,DSKWRK
     *,       MASWRK,OUTPUT,MP2ENG,UMP2GD,DLB,DOTASK
      DOUBLE PRECISION GOUT(*),SCHWA(*),CMO(NBF,*),CMOB(NBF,*)
     *,                TRAN(NBF,MXSHL*MXSHL,*),TMP1(*),TMP2(*),DDIJ(*)
     *,                TRANB(NBF,MXSHL*MXSHL,*),TMP1B(*),TMP2B(*)
      INTEGER MOLABS(*),MOLABSB(*)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /GOUT  / GPOPLE(768),NORG
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      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 /SHLG70/ ISHELL,JSHELL,KSHELL,LSHELL,INEW,JNEW,KNEW,LNEW
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
C
      IF (OUTPUT) THEN
        WRITE(ICHANL,1)
        CALL FLSHBF(ICHANL)
      END IF
C
C  INITIALIZE PARAMETERS
C
      IF (MP2ENG) THEN
        LTRAN = NACT*NBF*MXSHL*MXSHL
      ELSE
        LTRAN = NOCC*NBF*MXSHL*MXSHL
      END IF
      IF (UMP2GD) THEN
        IF (MP2ENG) THEN
          LTRANB = NACTB*NBF*MXSHL*MXSHL
        ELSE
          LTRANB = NOCCB*NBF*MXSHL*MXSHL
        END IF
      END IF
      MXSHL4  = MXSHL**4
      IANDJ   = .FALSE.
      KANDL   = .FALSE.
      SAME    = .FALSE.
      Q4      = ONE
      QQ4     = Q4
      NORG    = 0
      NSCHWZ  = 0
      NOFFIJ  = 0
      LOCTSK  = 0
C
C  DYNAMIC LOAD BALANCING
C
      DLB = IBTYP.EQ.1
      IF (DLB) THEN
        CALL DDI_DLBRESET()
        CALL DDI_DLBNEXT( MYTASK )
      END IF
C
C  I-SHELL,J-SHELL
C
      DO II = 1, NSHELL
       DO JJ = 1, II
         ISHL  = KMAX(II) - KMIN(II) + 1
         JSHL  = KMAX(JJ) - KMIN(JJ) + 1
         IJSHL = ISHL*JSHL
         IF (II.EQ.JJ) IJSHL = (ISHL*ISHL+ISHL)/2
C
C  SYMMETRY (IJ|
C
         CALL SYMIJ(II,JJ,Q2)
         IF ( Q2 .GT. ZERO ) THEN
C
C  LOAD BALANCER
C
         IF (DLB) THEN
           DOTASK = LOCTSK.EQ.MYTASK
         ELSE
           DOTASK = MOD(LOCTSK,NPROC).EQ.ME
         END IF
C
         IF (DOTASK) THEN
         IANDJ = II.EQ.JJ
                    CALL DCOPY(LTRAN ,ZERO,0,TRAN ,1)
         IF(UMP2GD) CALL DCOPY(LTRANB,ZERO,0,TRANB,1)
C
C  K-SHELL,L-SHELL
C
         DO KK = 1, NSHELL
          DO LL = 1, KK
C
C  SYMMETRY (IJ|KL)
C
           CALL SYMIJKL(II,JJ,KK,LL,Q4)
           IF ( Q4 .GT. ZERO ) THEN
            QQ4 = Q4
C
C  SCHWARZ INEQUALITY TEST
C
            IIJJ = IA(MAX0(II,JJ)) + MIN0(JJ,II)
            KKLL = IA(MAX0(LL,KK)) + MIN0(LL,KK)
            TEST = Q4*SCHWA(IIJJ)*SCHWA(KKLL)
            IF (TEST.LT.CUTOFF) THEN
              NSCHWZ = NSCHWZ + 1
            ELSE
C
C  COMPUTE (IJ|KL) AND FIRST TRANSFORMATION
C
C     USE POPLE CODE FOR ANY PURE SP INTEGRAL BLOCKS,
C     USE HONDO RYS POLYNOMIAL CODE FOR OTHER BLOCKS
C
             POPLE=.TRUE.
             IF(INTTYP.GE.2)    POPLE=.FALSE.
             IF(KTYPE(II).GT.2) POPLE=.FALSE.
             IF(KTYPE(JJ).GT.2) POPLE=.FALSE.
             IF(KTYPE(KK).GT.2) POPLE=.FALSE.
             IF(KTYPE(LL).GT.2) POPLE=.FALSE.
C
             ISHELL = II
             JSHELL = JJ
             KSHELL = KK
             LSHELL = LL
C
             IF (POPLE) THEN
              CALL DCOPY(256,ZERO,0,GPOPLE,1)
              CALL GENR70(1,.FALSE.)
              CALL DCOPY(256,GPOPLE,1,GOUT,1)
              CALL TRAN1_P(GOUT,CMO,TRAN,CMOB,TRANB)
             ELSE
              CALL DCOPY(MXSHL4,ZERO,0,GOUT,1)
              KANDL = KK.EQ.LL
              CALL PARSHEL(1,II,JJ,II,JJ)
              CALL IJPRIM(DDIJ)
              IF (NIJ.EQ.0) GO TO 170
              CALL PARSHEL(2,II,JJ,KK,LL)
              IF(IJKL.EQ.1) THEN
                CALL S0000(GOUT,DDIJ)
              ELSE
                CALL GENRAL(GOUT,DDIJ)
              END IF
              CALL TRAN1(GOUT,CMO,TRAN,CMOB,TRANB)
             END IF   ! POPLE
             END IF   ! SCHWARZ
           END IF     ! SYM IJKL
C
C  END OF INNER LOOPS
C
          END DO      !  LL-SHELL
         END DO       !  KK-SHELL
         ISHELL = II
         JSHELL = JJ
         IF(UMP2GD) THEN
            CALL UTRAN2(CMO,CMOB,TRAN,TRANB,TMP1,IJSHL,NOFFIJ)
         ELSE
            CALL TRAN2(CMO,TRAN,TMP1,IJSHL,NOFFIJ)
         END IF
         IF(UMP2GD) THEN
            CALL UTRAN3(CMO,CMOB,TRAN,TRANB,TMP1,TMP2,TMP1B,TMP2B,
     *                  ISHL,JSHL)
         ELSE
            CALL TRAN3(CMO,TRAN,TMP1,TMP2,ISHL,JSHL)
         END IF
 170     CONTINUE
         IF (DLB) CALL DDI_DLBNEXT( MYTASK )
         END IF       !  LOAD BALANCER
         LOCTSK = LOCTSK + 1
         END IF       !  SYM IJ
         NOFFIJ = NOFFIJ + IJSHL
C
C  END OF OUTER LOOPS
C
       END DO         ! JJ-SHELL
      END DO          ! II-SHELL
      CALL DDI_SYNC(9001)
C
C  (THIRD &) FOURTH TRANSFORMATIONS
C
      IF(UMP2GD) THEN
        CALL UTRAN34(CMO,CMOB,TMP1,TMP2,TMP1B,MOLABS,MOLABSB)
      ELSE
        CALL TRAN34(CMO,TMP1,TMP2,MOLABS)
      END IF
      CALL DDI_GSUMI(1199,NSCHWZ,1)
      IF (DLB) CALL DDI_DLBRESET
      IF (OUTPUT) THEN
        WRITE(ICHANL,3) NSCHWZ
        CALL FLSHBF(ICHANL)
      END IF
      RETURN
1     FORMAT(/,6X,'DIRECT 4-INDEX TRANSFORMATION ')
3     FORMAT(6X,'SCHWARZ INEQUALITY TEST SKIPPED ',I10,
     * ' INTEGRAL BLOCKS')
      END
C*MODULE MP2DDI  *DECK SYMIJ
      SUBROUTINE SYMIJ(II,JJ,Q2)
C
C -----------------------------------------------------------------
C  DETERMINE SYMMETRY-UNIQUE SHELL PAIRS
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXSH=5000,MXATM=2000, MXAO=8192)
      INTEGER II, JJ, II_NEW, JJ_NEW, OP, IJ, IJ_NEW
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48)
     *,               TSYM(432),INVT(48),NT
C
      Q2 = 0.0D+00
      IJ = IA(MAX0(II,JJ)) + MIN0(II,JJ)
C
C  LOOP THRU OPERATIONS IN THE GROUP AND MAP TO NEW PAIRS
C
      N = 1
      DO OP = 2, NT
C
C  MAP CENTERS
C
         II_NEW = MAPSHL(II,OP)
         JJ_NEW = MAPSHL(JJ,OP)
C
C  COMPARE CANONICAL PAIR INDICES
C
         IJ_NEW = IA(MAX0(II_NEW,JJ_NEW))
     *             + MIN0(II_NEW,JJ_NEW)
         IF (IJ.LT.IJ_NEW) RETURN
         IF (IJ.EQ.IJ_NEW) N = N + 1
      END DO
      Q2 = NT
      Q2 = Q2/N
      IF (ABS(Q2-NINT(Q2)).GT.1D-12) CALL ABRT
      END
C*MODULE MP2DDI  *DECK SYMIJKL
      SUBROUTINE SYMIJKL(II,JJ,KK,LL,Q4)
C
C -----------------------------------------------------------------
C  DETERMINE SYMMETRY-UNIQUE QUARTETS
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXSH=5000,MXATM=2000, MXAO=8192)
      LOGICAL OUTPUT,MP2ENG,UMP2GD
      INTEGER II,JJ,KK,LL, II_NEW,JJ_NEW,KK_NEW,LL_NEW
     *,       OP, IJ,KL, IJ_NEW,KL_NEW, N
      DOUBLE PRECISION Q4
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48)
     *,               TSYM(432),INVT(48),NT
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
      Q4 = 0.0D+00
C
C  ORIGINAL 4-INDEX IN SQUARE-CANONICAL LIST
C
      IJ = IA(MAX0(II,JJ)) + MIN0(II,JJ)
      KL = IA(MAX0(KK,LL)) + MIN0(KK,LL)
      IJKL = (IJ-1)*NSTR + KL
C
C  LOOP THRU OPERATIONS IN THE GROUP AND MAP TO NEW PAIRS
C
      N = 1
      DO OP = 2, NT
C
C  MAP CENTERS
C
         II_NEW = MAPSHL(II,OP)
         JJ_NEW = MAPSHL(JJ,OP)
         KK_NEW = MAPSHL(KK,OP)
         LL_NEW = MAPSHL(LL,OP)
C
C  MAPPED 4-INDEX IN SQUARE-CANONICAL LIST
C
         IJ_NEW = IA(MAX0(II_NEW,JJ_NEW))
     *+              MIN0(II_NEW,JJ_NEW)
         KL_NEW = IA(MAX0(KK_NEW,LL_NEW))
     *+              MIN0(KK_NEW,LL_NEW)
         IJKL_NEW = (IJ_NEW-1)*NSTR + KL_NEW
C
C  COMPARE INDICES
C
         IF (IJKL_NEW.GT.IJKL) RETURN
         IF (IJKL_NEW.EQ.IJKL) N = N + 1
      END DO
      Q4 = NT
      Q4 = Q4/N
      IF (ABS(Q4-NINT(Q4)).GT.1D-12) CALL ABRT
      END
C*MODULE MP2DDI  *DECK PARSHEL
      SUBROUTINE PARSHEL(NELEC,ISH,JSH,KSH,LSH)
C
C -----------------------------------------------------------------
C  THIS ROUTINE DEPARTS FROM SHELLS (INT2A.SRC) WHERE THERE ARE
C  DIFFERENCES IN THE EXPLOITATION OF INTEGRAL INDEX PERMUTATIONAL
C  SYMMETRIES AND MEMORY ALLOCATIONS IN THE PARALLEL CODE:
C       1)  SAME IS ALWAYS .FALSE.
C       2)  IANDJ AND KANDL ARE .FALSE. FOR THE VVVO INTEGRALS STEP
C       3)  IEXCH IS IRRELEVANT TO THE PARALLEL TRANSFORMATION CODE
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL IANDJ,KANDL,SAME, OUTPUT,MP2ENG,UMP2GD
      PARAMETER (MXSH=5000, MXGSH=30, MXGTOT=20000, MXATM=2000)
      COMMON /MISC  / IANDJ,KANDL,SAME
      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 /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
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
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
      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
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
      IF (KTYPE(ISH) .LT. KTYPE(JSH)) THEN
         INU = JSH
         JNU = ISH
         NGTI = MXSHL**2
         NGTJ = MXSHL**3
      ELSE
         INU = ISH
         JNU = JSH
         NGTI = MXSHL**3
         NGTJ = MXSHL**2
      END IF
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
  180    CONTINUE
  190 CONTINUE
      RETURN
C     ******
C
C        K AND L SHELL
C
  200 CONTINUE
C
C     ----- PERMUTE KSH AND LSH SHELLS, FOR THEIR TYPE
C
      IF (KTYPE(KSH) .LT. KTYPE(LSH)) THEN
         KNU = LSH
         LNU = KSH
         NGTK = 1
         NGTL = MXSHL
      ELSE
         KNU = KSH
         LNU = LSH
         NGTK = MXSHL
         NGTL = 1
      END IF
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
  320 IK(I) = MAX
      IJKL = IJ*KL
      RETURN
      END
C*MODULE MP2DDI  *DECK TRAN1
      SUBROUTINE TRAN1(GOUT,CMO,TRAN,CMOB,TRANB)
C
C -----------------------------------------------------------------
C  FIRST TRANSFORMATION - HONDO INTEGRAL INDEXING
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      LOGICAL IANDJ,KANDL,SAME,OUTPUT,MP2ENG,UMP2GD
      DOUBLE PRECISION GOUT(*),CMO(NBF,*),TRAN(NBF,MXSHL*MXSHL,*)
      DOUBLE PRECISION CMOB(NBF,*),TRANB(NBF,MXSHL*MXSHL,*)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /SHLG70/ ISHELL,JSHELL,KSHELL,LSHELL,INEW,JNEW,KNEW,LNEW
      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 /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
C
      MINI = KMIN(ISHELL)
      MAXI = KMAX(ISHELL)
      MINJ = KMIN(JSHELL)
      MAXJ = KMAX(JSHELL)
      MINK = KMIN(KSHELL)
      MAXK = KMAX(KSHELL)
      LOCK = KLOC(KSHELL) - MINK
      MINL = KMIN(LSHELL)
      MAXL = KMAX(LSHELL)
      LOCL = KLOC(LSHELL) - MINL
      LEN1 = MXSHL**3
      LEN2 = MXSHL**2
      LEN3 = MXSHL
      IJN = 0
      LIMJ = MAXJ
      DO I = MINI, MAXI
        IF (IANDJ) LIMJ = I
        DO J = MINJ, LIMJ
          IJN = IJN + 1
          IJP = LEN1*(I-MINI) + LEN2*(J-MINJ) + 1
          LIML = MAXL
          DO K = MINK, MAXK
            I3 = LOCK + K
            IF (KANDL) LIML = K
            DO L = MINL, LIML
              I4 = LOCL + L
              KLP = LEN3*(K-MINK) + L-MINL
              VAL = GOUT( IJP + KLP )
              IF (I3.EQ.I4) VAL = VAL*0.5D+00
              ICNT = 0
              DO IOCC = IOST, NOCC
                 ICNT = ICNT + 1
                 TRAN(I3,IJN,ICNT) = TRAN(I3,IJN,ICNT)
     *                             + VAL*CMO(I4,IOCC)
                 TRAN(I4,IJN,ICNT) = TRAN(I4,IJN,ICNT)
     *                             + VAL*CMO(I3,IOCC)
              END DO
              IF(UMP2GD) THEN
                ICNT = 0
                DO IOCC = IOSTB, NOCCB
                 ICNT = ICNT + 1
                 TRANB(I3,IJN,ICNT) = TRANB(I3,IJN,ICNT)
     *                             + VAL*CMOB(I4,IOCC)
                 TRANB(I4,IJN,ICNT) = TRANB(I4,IJN,ICNT)
     *                             + VAL*CMOB(I3,IOCC)
                END DO
              END IF
            END DO
          END DO
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK TRAN1_P
      SUBROUTINE TRAN1_P(GOUT,CMO,TRAN,CMOB,TRANB)
C
C -----------------------------------------------------------------
C  FIRST TRANSFORMATION - POPLE VERSION
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      LOGICAL IANDJ,KANDL,OUTPUT,MP2ENG,UMP2GD
      DOUBLE PRECISION GOUT(*),CMO(NBF,*),TRAN(NBF,MXSHL*MXSHL,*)
      DOUBLE PRECISION CMOB(NBF,*),TRANB(NBF,MXSHL*MXSHL,*)
      COMMON /SHLG70/ ISHELL,JSHELL,KSHELL,LSHELL,INEW,JNEW,KNEW,LNEW
      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 /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
      COMMON/FLIPS /IB1,JB1,KB1,LB1,IB2,JB2,KB2,LB2,IB3,JB3,KB3,LB3
      INTEGER IB(4,4)
      DATA IB/0,0,0,0,64,16,4,1,128,32,8,2,192,48,12,3/
C
      MINI = KMIN(ISHELL)
      MAXI = KMAX(ISHELL)
      MINJ = KMIN(JSHELL)
      MAXJ = KMAX(JSHELL)
      MINK = KMIN(KSHELL)
      MAXK = KMAX(KSHELL)
      LOCK = KLOC(KSHELL) - MINK
      MINL = KMIN(LSHELL)
      MAXL = KMAX(LSHELL)
      LOCL = KLOC(LSHELL) - MINL
      IANDJ = ISHELL.EQ.JSHELL
      KANDL = KSHELL.EQ.LSHELL
      IJN = 0
      JMAX = MAXJ
      DO I = MINI, MAXI
        IF (IANDJ) JMAX = I
        DO J = MINJ, JMAX
          IJN = IJN + 1
          N1 = IB(IB1,I) + IB(JB1,J)+1
          DO K = MINK, MAXK
            LIML = MAXL
            IF (KANDL) LIML = K
            I3 = LOCK + K
            DO L = MINL, LIML
              NN = N1 + IB(KB1,K) + IB(LB1,L)
              I4 = LOCL + L
              VAL = GOUT(NN)
              IF (I3.EQ.I4) VAL = VAL*0.5D+00
              ICNT = 0
              DO IOCC = IOST, NOCC
                 ICNT = ICNT + 1
                 TRAN(I3,IJN,ICNT) = TRAN(I3,IJN,ICNT)
     *                             + VAL*CMO(I4,IOCC)
                 TRAN(I4,IJN,ICNT) = TRAN(I4,IJN,ICNT)
     *                             + VAL*CMO(I3,IOCC)
              END DO
              IF(UMP2GD) THEN
                ICNT = 0
                DO IOCC = IOSTB, NOCCB
                 ICNT = ICNT + 1
                 TRANB(I3,IJN,ICNT) = TRANB(I3,IJN,ICNT)
     *                             + VAL*CMOB(I4,IOCC)
                 TRANB(I4,IJN,ICNT) = TRANB(I4,IJN,ICNT)
     *                             + VAL*CMOB(I3,IOCC)
                END DO
              END IF
            END DO
          END DO
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK TRAN2
      SUBROUTINE TRAN2(CMO,TRAN,TMP1,IJSHL,NOFFIJ)
C
C -----------------------------------------------------------------
C  SECOND TRANSFORMATION
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      LOGICAL OUTPUT,MP2ENG,NDCOUL,UMP2GD
      DOUBLE PRECISION CMO(NBF,*),TRAN(NBF,MXSHL*MXSHL,*),TMP1(IJSHL,*)
C
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C  AT THIS POINT THE DECISION IS ABOUT WHETHER WE ARE AIMING FOR
C  ONE OF THE 'COULOMB'-TYPE CLASSES (OOOO,VOOO, OR VVOO), OR JUST
C  THE 'EXCHANGE'-TYPE VOVO CLASS, OR BOTH.
C
      NDCOUL = NDOOOO.OR.NDVOOO.OR.NDVVOO.OR.NDVVVO
      IF (NDCOUL) THEN              ! TRAN HAS BOTH OCC AND VIR ORBS
        IF (NDVOVO.OR.NDVVVO) THEN  ! MUST INCLUDE THE VIRTUALS
          IF(NDCORE) THEN
             KSTT = 1
             KRNG = NMOS
          ELSE
             KSTT = NCP1
             KRNG = NACT+NVIR
          END IF
        ELSE
          IF(NDCORE) THEN
             KSTT = 1
             KRNG = NOCC
          ELSE
             KSTT = NCP1            ! FIRST ACTIVE OCC
             KRNG = NACT
          END IF
        END IF
      ELSE IF (NDVOVO) THEN         ! NO OCCS ==> IGNORE NDCORE
         KSTT = NOP1                ! FIRST VIR
         KRNG = NVIR
      END IF
C
      ICNT = 0
      DO IOCC = IOST, NOCC          ! IOST IS THE FIRST SAVED OCC
        ICNT = ICNT + 1
        CALL DGEMM('T','N',IJSHL,KRNG,NBF
     *,            ONE,TRAN(1,1,ICNT),NBF
     *,            CMO(1,KSTT),NBF
     *,            ZERO,TMP1,IJSHL)
        DO IUV = 1, IJSHL
          CALL DCOPY(KRNG,TMP1(IUV,1),IJSHL,TRAN(1,IUV,ICNT),1)
        END DO
      END DO
C
C  PACK SEND BUFFER AND PUT HALF-TRANSFORMED [**|OO) INTEGRALS
C
      IF (NDCOUL) THEN
        IBEG = NOFFIJ + 1
        IEND = NOFFIJ + IJSHL
        IF(NDCORE) THEN
           IRNG = NOCC
        ELSE
           IRNG = NACT
        END IF
        IJ = 0
        DO IOCC = 1, IRNG
          DO JOCC = 1, IOCC
            IJ = IJ + 1
            DO IUV = 1, IJSHL
              TMP1(IUV,IJ) = TRAN(JOCC,IUV,IOCC)
            END DO
          END DO
        END DO
        CALL DDI_PUT(D_VVOO,IBEG,IEND,1,NOTR,TMP1)
      END IF
C
C  PACK SEND BUFFER AND PUT HALF-TRANSFORMED [**|VO) INTEGRALS
C
      IF(NDVVVO) THEN
        IBEG = NOFFIJ + 1
        IEND = NOFFIJ + IJSHL
        IJ = 0
        DO IOCC = 1, IRNG
          DO JVIR = 1, NVIR
            IJ = IJ + 1
            DO IUV = 1, IJSHL
              TMP1(IUV,IJ) = TRAN(JVIR+IRNG,IUV,IOCC)
            END DO
          END DO
        END DO
        CALL DDI_PUT(D_VVVO,IBEG,IEND,1,NOV,TMP1)
      END IF
C
      RETURN
      END
C*MODULE MP2DDI  *DECK TRAN3
      SUBROUTINE TRAN3(CMO,TRAN,TMP1,TMP2,ISHL,JSHL)
C
C -----------------------------------------------------------------
C  THIRD TRANSFORMATION FOR (VO|VO) INTEGRALS
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000, ZERO=0.0D+00)
      LOGICAL OUTPUT,MP2ENG,IANJ,UMP2GD
C
      DOUBLE PRECISION CMO(NBF,*),TRAN(NBF,MXSHL*MXSHL,*)
     *,      TMP1(NVIR,ISHL,*),TMP2(NVIR,JSHL,*)
C
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /SHLG70/ ISHELL,JSHELL,KSHELL,LSHELL,INEW,JNEW,KNEW,LNEW
      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
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      IF (.NOT.NDVOVO) RETURN
C
      IANJ = ISHELL.EQ.JSHELL
      MINI = KMIN(ISHELL)
      MAXI = KMAX(ISHELL)
      LOCI = KLOC(ISHELL) - MINI
      MINJ = KMIN(JSHELL)
      MAXJ = KMAX(JSHELL)
      LOCJ = KLOC(JSHELL) - MINJ
C          SOME NUMBER OF OCCUPIED ORBS EXIST
      IF(NDOOOO.OR.NDVOOO.OR.NDVVOO.OR.NDVVVO) THEN
         IF(NDCORE) THEN
            NOFF = NOCC
         ELSE
            NOFF = NACT
         END IF
      ELSE             ! ONLY VIRS IN FIRST INDEX OF TRAN
         NOFF = 0
      END IF
C
C  LOOP OVER NODE PARTITIONS TO SCALE THE ACC BUFFER SIZE
C
      CALL DDI_NPROC( NPROC, ME )
      DO IP = 0, NPROC-1
        CALL DDI_DISTRIB( D_VOVO, IP, ILO, IHI, JLO, JHI )
        CALL DCOPY(NVIR*(JHI-JLO+1)*ISHL,ZERO,0,TMP1,1)
        CALL DCOPY(NVIR*(JHI-JLO+1)*JSHL,ZERO,0,TMP2,1)
        IJP  = 0
        IJ   = 0
        ICNT = 0
        DO IOCC = IOST, NOCC
          ICNT = ICNT + 1
          DO JOCC = IOST, IOCC
            IJ = IJ + 1
            IF ( IJ.GE.JLO .AND. IJ.LE.JHI ) THEN
              IJP  = IJP + 1
              IJN  = 0
              JMAX = MAXJ
              II   = 0
              DO I = MINI, MAXI
                II = II + 1
                IF (IANJ) JMAX = I
                JJ = 0
                DO J = MINJ, JMAX
                  JJ  = JJ  + 1
                  IJN = IJN + 1
                  IF ( I+LOCI .NE. J+LOCJ ) THEN
                    DO IVIR = 1, NVIR
                     TMP1(IVIR,II,IJP) = TMP1(IVIR,II,IJP) +
     *               TRAN(NOFF+IVIR,IJN,ICNT)*CMO(J+LOCJ,JOCC)
                     TMP2(IVIR,JJ,IJP) = TMP2(IVIR,JJ,IJP) +
     *               TRAN(NOFF+IVIR,IJN,ICNT)*CMO(I+LOCI,JOCC)
                    END DO
                  ELSE
                    DO IVIR = 1, NVIR
                     TMP1(IVIR,II,IJP) = TMP1(IVIR,II,IJP) +
     *               TRAN(NOFF+IVIR,IJN,ICNT)*CMO(J+LOCJ,JOCC)
                    END DO
                  END IF
                END DO
              END DO
            END IF
          END DO
        END DO
C
C  ACCUMULATE [V*|VO) INTEGRALS
C
        ILO1 = ( LOCI + MINI - 1 )*NVIR + 1
        IHI1 = ILO1 + NVIR*ISHL -1
        CALL DDI_ACC(D_VOVO,ILO1,IHI1,JLO,JHI,TMP1)
        ILO2 = ( LOCJ + MINJ - 1 )*NVIR + 1
        IHI2 = ILO2 + NVIR*JSHL -1
        CALL DDI_ACC(D_VOVO,ILO2,IHI2,JLO,JHI,TMP2)
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK TRAN34
      SUBROUTINE TRAN34(CMO,TMP1,TMP2,MOLABS)
C
C -----------------------------------------------------------------
C  THIRD AND FOURTH TRANSFORMATIONS FOR (VV|OO), (VO|OO), (OO|OO)
C  FOURTH TRANSFORMATION FOR (VO|VO) INTEGRALS
C  AND SCREEN INTEGRALS VANISHING BY SYMMETRY
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000, ZERO=0.0D+00, ONE=1.0D+00)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,SYM2EI,NDCOUL
      LOGICAL UMP2GD
      DOUBLE PRECISION CMO(NBF,*),TMP1(*),TMP2(*)
      INTEGER MOLABS(*)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      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 /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C LOCAL VARIABLES
C
      INTEGER DDI_NP,DDI_ME
C
      IF(NDVVVO) THEN
C
      CALL DDI_NPROC(DDI_NP,DDI_ME)
      CALL DDI_DISTRIB(D_VVVO,DDI_ME,ILO,IHI,JLO,JHI)
C
      IJ = 0
      DO 1 IOCC = IOST,NOCC
      DO 1 JVIR = 1,NVIR
         IJ  = IJ + 1
         IF(IJ.LT.JLO .OR. IJ.GT.JHI) GOTO 1         ! SKIP WORK
         ISM = MOLABS(IOCC)
         JSM = MOLABS(JVIR+NOCC)
C
C LIKE THE FOLLOWING SECTION, TRAN2 DID NOT SCATTER [**|VO] INTEGRALS
C INTO THE VVVO ARRAY IN STRICT AO-ORDER, RATHER IT WAS SHELL-MAPPED
C
         CALL DDI_GET(D_VVVO,1,NBTR,IJ,IJ,TMP1)
C
         IJN = 0
         DO II = 1, NSHELL
         DO JJ = 1, II
C
C ... NOW THE CORRECT AO-LIST IS RECOVERED
C
            DO I = KLOC(II), KLOC(II) - KMIN(II) + KMAX(II)
               JMAX = KLOC(JJ) - KMIN(JJ) + KMAX(JJ)
               IF (II.EQ.JJ) JMAX = I
               DO J = KLOC(JJ), JMAX
                  IJN = IJN + 1
                  TMP2((I-1)*NBF+J) = TMP1(IJN)
                  TMP2((J-1)*NBF+I) = TMP1(IJN)
               END DO
            END DO
         END DO
         END DO
C
C  THIRD QUARTER-TRANSFORMATION TO VIRTUAL INDICES
C
         CALL DGEMM('N','N',NBF,NVIR,NBF
     *,             ONE,TMP2,NBF
     *,             CMO(1,NOP1),NBF
     *,             ZERO,TMP1,NBF)
C
C  FOURTH QUARTER-TRANSFORMATION TO VIR-VIR INDICES
C  (NOTE SPECIAL MULTIPLY ROUTINE THAT USES SYMMETRY)
C
         CALL ARBRCS('T','N',NVIR,NBF
     *,              ONE,CMO(1,NOP1),NBF
     *,              TMP1,NBF
     *,              ZERO,TMP2,NBF)
C
C  PUT VVVO INTEGRALS IN DISTRIBUTED MEMORY
C
         IJN = 0
         DO I = NOP1, NMOS
         DO J = NOP1, I
            KSM = MOLABS(I)
            LSM = MOLABS(J)
            IJN = IJN + 1
            TMP1(IJN) = TMP2( (I-1-NOCC)*NBF + J-NOCC )
            IF(.NOT.SYM2EI(ISM,JSM,KSM,LSM)) TMP1(IJN) = ZERO
         END DO
         END DO
         CALL DDI_PUT(D_VVVO,1,IJN,IJ,IJ,TMP1)
    1 CONTINUE
      END IF
C
      NDCOUL = NDOOOO.OR.NDVOOO.OR.NDVVOO
      IF (NDCOUL) THEN
         CALL DDI_DISTRIB(D_VVOO,ME,ILO,IHI,JLO,JHI)
      ELSE IF (NDVOVO) THEN
         CALL DDI_DISTRIB(D_VOVO,ME,ILO,IHI,JLO,JHI)
      ELSE
         WRITE(ICHANL,*) 'TRAN34: ERROR, NO INTEGRAL TYPE'
         CALL ABRT()
      END IF
      IF(NDCORE) THEN
         NOFF = NOCC
      ELSE
         NOFF = NACT
      END IF
C
      IJ = 0
      DO IOCC = IOST, NOCC
       ISM = MOLABS(IOCC)
       DO JOCC = IOST, IOCC
         JSM = MOLABS(JOCC)
         IJ = IJ + 1
         IF (IJ.GE.JLO .AND. IJ.LE.JHI) THEN
C
C  DO THE (OO|OO), (VO|OO), AND (VV|OO) CLASSES
C
          IF (NDCOUL) THEN
            CALL DDI_GET(D_VVOO,1,NBTR,IJ,IJ,TMP1)
C
C  NOTICE TRAN2 DID NOT SCATTER THE [**|OO) INTEGRALS
C  INTO THE VVOO ARRAY IN STRICT AO-ORDER...
C
            IJN = 0
            DO II = 1, NSHELL
              DO JJ = 1, II
C
C ... NOW THE CORRECT AO-LIST IS RECOVERED
C
                DO I = KLOC(II), KLOC(II) - KMIN(II) + KMAX(II)
                  JMAX = KLOC(JJ) - KMIN(JJ) + KMAX(JJ)
                  IF (II.EQ.JJ) JMAX = I
                  DO J = KLOC(JJ), JMAX
                    IJN = IJN + 1
                    TMP2((I-1)*NBF+J) = TMP1(IJN)
                    TMP2((J-1)*NBF+I) = TMP1(IJN)
                  END DO
                END DO
              END DO
            END DO
C
C  THIRD QUARTER-TRANSFORMATION TO OCCUPIED INDICES
C
            IF (NDOOOO.OR.NDVOOO) THEN
              CALL DGEMM('N','N',NBF,NOFF,NBF
     *,                  ONE,TMP2,NBF
     *,                  CMO(1,IOST),NBF
     *,                  ZERO,TMP1,NBF)
            END IF
C
C  THIRD QUARTER-TRANSFORMATION TO VIRTUAL INDICES
C
            IF (NDVVOO) THEN
              CALL DGEMM('N','N',NBF,NVIR,NBF
     *,                  ONE,TMP2,NBF
     *,                  CMO(1,NOP1),NBF
     *,                  ZERO,TMP1( (NOFF*NBF)+1 ),NBF)
            END IF
C
C  FOURTH QUARTER-TRANSFORMATION TO OCC-OCC INDICES
C  (NOTE SPECIAL MULTIPLY ROUTINE THAT USES SYMMETRY)
C
            IF (NDOOOO) THEN
              CALL ARBRCS('T','N',NOFF,NBF
     *,                   ONE,CMO(1,IOST),NBF
     *,                   TMP1,NBF
     *,                   ZERO,TMP2,NBF)
            END IF
C
C  FOURTH QUARTER-TRANSFORMATION TO VIR-OCC INDICES
C
            IF (NDVOOO) THEN
              CALL DGEMM('T','N',NVIR,NOFF,NBF
     *,                  ONE,CMO(1,NOP1),NBF
     *,                  TMP1,NBF
     *,                  ZERO,TMP2( NOFF+1 ),NBF)
            END IF
C
C  FOURTH QUARTER-TRANSFORMATION TO VIR-VIR INDICES
C  (NOTE SPECIAL MULTIPLY ROUTINE THAT USES SYMMETRY)
C
           IF (NDVVOO) THEN
             CALL ARBRCS('T','N',NVIR,NBF
     *,                  ONE,CMO(1,NOP1),NBF
     *,                  TMP1( (NOFF*NBF)+1 ),NBF
     *,                  ZERO,TMP2( (NOFF*NBF)+1 ),NBF)
           END IF
C
           IF (NDOOOO) THEN
C
C  PUT (OO|OO) INTEGRALS IN DISTRIBUTED MEMORY
C
             IJN = 0
             DO I = 1, NOFF
               KSM = MOLABS(IOST+I-1)
               DO J = 1, I
                 LSM = MOLABS(IOST+J-1)
                 IJN = IJN + 1
                 TMP1(IJN) = TMP2( (I-1)*NBF + J )
                 IF(.NOT.SYM2EI(ISM,JSM,KSM,LSM)) TMP1(IJN) = ZERO
               END DO
             END DO
             CALL DDI_PUT(D_OOOO,1,IJN,IJ,IJ,TMP1)
           END IF
C
           IF (NDVVOO) THEN
C
C  PUT VVOO INTEGRALS IN DISTRIBUTED MEMORY
C
             IJN = 0
             DO I = 1, NVIR
               KSM = MOLABS(NOCC+I)
               DO J = 1, I
                 LSM = MOLABS(NOCC+J)
                 IJN = IJN + 1
                 TMP1(IJN) = TMP2( (NOFF+I-1)*NBF + J )
                 IF(.NOT.SYM2EI(ISM,JSM,KSM,LSM)) TMP1(IJN) = ZERO
               END DO
             END DO
             CALL DDI_PUT(D_VVOO,1,IJN,IJ,IJ,TMP1)
           END IF
C
           IF (NDVOOO) THEN
C
C  PUT VOOO INTEGRALS IN DISTRIBUTED MEMORY
C
             IJN = 0
             DO J = 1, NOFF
               KSM = MOLABS(IOST+J-1)
               DO I = 1, NVIR
                 LSM = MOLABS(NOCC+I)
                 IJN = IJN + 1
                 TMP1(IJN) = TMP2( (J-1)*NBF + I + NOFF )
                 IF(.NOT.SYM2EI(ISM,JSM,KSM,LSM)) TMP1(IJN) = ZERO
               END DO
             END DO
             CALL DDI_PUT(D_VOOO,1,NVIR,(IJ-1)*NOFF+1,IJ*NOFF,TMP1)
           END IF
         END IF  ! NDCOUL
C
         IF (NDVOVO) THEN
C
C  TRANSFORM REMAINING AO INDEX OF VOVO CLASS
C
           CALL DDI_GET(D_VOVO,1,NBF*NVIR,IJ,IJ,TMP1)
           CALL DGEMM('N','N',NVIR,NVIR,NBF
     *,               ONE,TMP1,NVIR
     *,               CMO(1,NOP1),NBF
     *,               ZERO,TMP2,NVIR)
           IJN = 0
           DO I = NOP1, NMOS
             KSM = MOLABS(I)
             DO J = NOP1, NMOS
               LSM = MOLABS(J)
               IJN = IJN + 1
               IF(.NOT.SYM2EI(ISM,JSM,KSM,LSM)) TMP2(IJN) = ZERO
             END DO
           END DO
           CALL DDI_PUT(D_VOVO,1,NVSQ,IJ,IJ,TMP2)
          END IF
        END IF  ! IJ-LOCAL
       END DO  ! JOCC
      END DO  ! IOCC
      RETURN
      END
C*MODULE MP2DDI  *DECK ARBRCS
      SUBROUTINE ARBRCS(OA,OB,NDIM,NLINK,FA,A,LDA,B,LDB,FC,C,LDC)
C
C -----------------------------------------------------------------
C  SIMPLE DGEMM-CLONE THAT EXPLOITS SYMMETRY IN THE RESULT MATRIX
C -----------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER NDIM,NLINK,LDA,LDB,LDC, I,J,K
      REAL*8  A(LDA,*),B(LDB,*),C(LDC,*),FA,FC,X,ZERO
      PARAMETER ( ZERO = 0.0D+00 )
      CHARACTER*1 OA,OB
C
      IF (OA.EQ.'N') THEN
        IF (OB.EQ.'N') THEN
          DO I = 1, NDIM
            DO J = 1, I
              X = ZERO
              DO K = 1, NLINK
                X = X + A(I,K)*B(K,J)
              END DO
              C(I,J) = FC*C(I,J) + FA*X
              C(J,I) = C(I,J)
            END DO
          END DO
        ELSE IF (OB.EQ.'T') THEN
          DO I = 1, NDIM
            DO J = 1, I
              X = ZERO
              DO K = 1, NLINK
                X = X + A(I,K)*B(J,K)
              END DO
              C(I,J) = FC*C(I,J) + FA*X
              C(J,I) = C(I,J)
            END DO
          END DO
        END IF
      ELSE IF (OA.EQ.'T') THEN
        IF (OB.EQ.'N') THEN
          DO I = 1, NDIM
            DO J = 1, I
              X = ZERO
              DO K = 1, NLINK
                X = X + A(K,I)*B(K,J)
              END DO
              C(I,J) = FC*C(I,J) + FA*X
              C(J,I) = C(I,J)
            END DO
          END DO
        ELSE IF (OB.EQ.'T') THEN
          DO I = 1, NDIM
            DO J = 1, I
              X = ZERO
              DO K = 1, NLINK
                X = X + A(K,I)*B(J,K)
              END DO
              C(I,J) = FC*C(I,J) + FA*X
              C(J,I) = C(I,J)
            END DO
          END DO
        END IF
      END IF
      RETURN
      END
C*MODULE MP2DDI  *DECK PEMP2
      SUBROUTINE PEMP2(EORB,TMP1)
C
C -----------------------------------------------------------------
C  COMPUTE MP2 ENERGY
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXRT=100)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,UMP2GD
      INTEGER A,B
      DOUBLE PRECISION EORB(*),TMP1(NVIR,*)
C
      COMMON /ENRGMP/ EMP2,EMP3,EMP4
      COMMON /ENRGYS/ ENUC,EELEC,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      CALL DDI_DISTRIB(D_VOVO,ME,IL_VOVO,IH_VOVO,JL_VOVO,JH_VOVO)
      E2 = 0.0D+00
      IJN  = 0
      DO I = NCP1, NOCC
        DO J = NCP1, I
          IF (MP2ENG) THEN
            IJN = IJN + 1
          ELSE
            IJN = (I*I-I)/2 + J
          END IF
          IF (IJN.GE.JL_VOVO .AND. IJN.LE.JH_VOVO) THEN
            CALL DDI_GET(D_VOVO, 1, NVSQ, IJN, IJN, TMP1)
            DO A = 1, NVIR
              DO B = 1, NVIR
                IF (I.NE.J) THEN
                  E2 = E2 + 2.0D+00*
     *            TMP1(A,B)*(TMP1(A,B)+TMP1(A,B)-TMP1(B,A))/
     *            (EORB(I)+EORB(J)-EORB(NOCC+A)-EORB(NOCC+B))
                ELSE
                  E2 = E2 +
     *            TMP1(A,B)*(TMP1(A,B)+TMP1(A,B)-TMP1(B,A))/
     *            (EORB(I)+EORB(J)-EORB(NOCC+A)-EORB(NOCC+B))
                END IF
              END DO
            END DO
          END IF
        END DO
      END DO
C
C  GLOBALLY-SUM THE MP2 ENERGY CONTRIBUTIONS
C
      CALL DDI_GSUMF(999,E2,1)
      EMP2 = ESCF + E2
      IF (OUTPUT) THEN
        WRITE(ICHANL,5) ESCF, E2, EMP2
        CALL FLSHBF(ICHANL)
      END IF
      RETURN
5     FORMAT(20X,' E(SCF)= ',1F20.10,/
     *,      20X,'   E(2)= ',1F20.10,/
     *,      20X,' E(MP2)= ',1F20.10)
      END
C*MODULE MP2DDI  *DECK ZAPTE
      SUBROUTINE ZAPTE(E,TMP1,TMP2,XYXY)
C
C -----------------------------------------------------------------
C  COMPUTE ZAPT MP2 ENERGY
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXRT=100)
      PARAMETER ( ZERO = 0.0D+00, HALF = 0.5D+00, TWO = 2.0D+00 )
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,UMP2GD
      INTEGER A,B,AB,BA
      DOUBLE PRECISION E(*),TMP1(*),TMP2(*),XYXY(*)
C
      COMMON /ENRGMP/ EMP2,EMP3,EMP4
      COMMON /ENRGYS/ ENUC,EELEC,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWORD,MEMPRI,MPPROP,
     *                NACORE_MP2PAR,NBCORE_MP2PAR,NOA,NOB,NO,NBF_MP2PAR,
     *                NOMIT,MOCPHF,MAXITC
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      NOCD  = NOB
      NOCD1 = NOCD + 1
      NOCS  = NOA - NOB
C
C  GET SINGLES INTEGRALS, (XY|XY)
C
      NXY = (NOCS*NOCS+NOCS)/2
      CALL DCOPY(NXY,ZERO,0,XYXY,1)
      CALL DDI_DISTRIB(D_OOOO,ME,IL_OOOO,IH_OOOO,JL_OOOO,JH_OOOO)
      IXY = 0
      DO IX = 1, NOCS
        DO IY = 1, IX
          IXY = IXY + 1
          NX  = IX + NOCD
          NY  = IY + NOCD
          IJ  = (NX*NX-NX)/2 + NY
          IF (IJ.GE.JL_OOOO.AND.IJ.LE.JH_OOOO) THEN
            CALL DDI_GET(D_OOOO,1,NOTR,IJ,IJ,TMP1)
            XYXY(IXY) = TMP1(IJ)
          END IF
        END DO
      END DO
      CALL DDI_GSUMF(990,XYXY,NXY)
C
      IF (OUTPUT) WRITE(ICHANL,2) ESCF
C
C  TERM 1
C
      CALL DDI_DISTRIB(D_VOVO,ME,IL_VOVO,IH_VOVO,JL_VOVO,JH_VOVO)
      E1 = ZERO
      DO I = NCP1, NOCD
        DO J = NCP1, I
          IJ = (I*I-I)/2 + J
          IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
            CALL DDI_GET(D_VOVO,1,NVSQ,IJ,IJ,TMP1)
            DO A = 1, NVIR
              DO B = 1, NVIR
                AB   = (B-1)*NVIR + A
                BA   = (A-1)*NVIR + B
                AIBJ = TMP1(AB)
                BIAJ = TMP1(BA)
                IF (I.NE.J) THEN
                  E1 = E1 + TWO*AIBJ*(TWO*AIBJ-BIAJ)/
     *                (E(I)+E(J)-E(NOCC+A)-E(NOCC+B))
                ELSE
                  E1 = E1 +     AIBJ*(TWO*AIBJ-BIAJ)/
     *                (E(I)+E(J)-E(NOCC+A)-E(NOCC+B))
                END IF
              END DO
            END DO
          END IF
        END DO
      END DO
      CALL DDI_GSUMF(991,E1,1)
      IF (OUTPUT) WRITE(ICHANL,1) 1,E1,'CLOSED SHELL-LIKE TERM'
C
C  TERM 2
C
      CALL DDI_DISTRIB(D_VOOO,ME,IL_VOOO,IH_VOOO,JL_VOOO,JH_VOOO)
C
      E2 = ZERO
      DO I = NCP1, NOCD
        DO J = NCP1, NOCD
          DO K = NOCD1, NOCC
            KI = (K*K-K)/2 + I
            KIJ = (KI-1)*NOCC + J
            IF (KIJ.GE.JL_VOOO.AND.KIJ.LE.JH_VOOO) THEN
              KJ = (K*K-K)/2 + J
              KJI = (KJ-1)*NOCC + I
              XYS = ZERO
              DO L = NOCD1, NOCC
                KS = K - NOCD
                LS = L - NOCD
                KL = (KS*KS-KS)/2 + LS
                IF(KS.LT.LS) KL=(LS*LS-LS)/2 + KS
                XYS = XYS + XYXY(KL)
              END DO
              XYS = XYS*HALF
              CALL DDI_GET(D_VOOO,1,NVIR,KIJ,KIJ,TMP1)
              CALL DDI_GET(D_VOOO,1,NVIR,KJI,KJI,TMP2)
              DO A = 1, NVIR
                XIAJ = TMP1(A)
                XJAI = TMP2(A)
                E2 = E2 + XIAJ*((TWO*XIAJ)-XJAI)/
     *                  (E(I)+E(J)-E(K)-E(NOCC+A)-XYS)
              END DO
            END IF
          END DO
        END DO
      END DO
      CALL DDI_GSUMF(992,E2,1)
      IF (OUTPUT) WRITE(ICHANL,1) 2,E2,'SINGLY UNOCCUPIED TERM'
C
C  GATHER (DS|DS) INTEGRALS ONTO ALL NODES
C
      CALL DDI_DISTRIB(D_OOOO,ME,IL_OOOO,IH_OOOO,JL_OOOO,JH_OOOO)
      NAD = NOCD-NACORE
      NDS = NAD*NOCS
      LEN = (NDS*NDS+NDS)/2
      CALL DCOPY(LEN,ZERO,0,TMP2,1)
      DO A = NOCD1, NOCC
        DO I = NCP1, NOCD
          IA = (A*A-A)/2 + I
          IF (IA.GE.JL_OOOO.AND.IA.LE.JH_OOOO) THEN
            CALL DDI_GET(D_OOOO,1,NOTR,IA,IA,TMP1)
            NA = A - NOCD
            NI = I - NACORE
            NIA = (NA-1)*NAD + NI
            DO B = NOCD1, NOCC
              DO J = NCP1, NOCD
                JB = (B*B-B)/2 + J
                NB = B - NOCD
                NJ = J - NACORE
                NJB = (NB-1)*NAD + NJ
                IF (NIA.GE.NJB) THEN
                  IAJB = (NIA*NIA-NIA)/2 + NJB
                  TMP2(IAJB) = TMP1(JB)
                END IF
              END DO
            END DO
          END IF
        END DO
      END DO
      CALL DDI_GSUMF(993,TMP2,LEN)
C
C  TERM 3  - IN SERIAL
C
      E3 = ZERO
      DO I = 1, NOCS
        DO J = 1, I
          XYS = ZERO
          DO K = 1, NOCS
            IF (I.GE.K) THEN
              IK = (I*I-I)/2 + K
            ELSE
              IK = (K*K-K)/2 + I
            END IF
            IF (J.GE.K) THEN
              JK = (J*J-J)/2 + K
            ELSE
              JK = (K*K-K)/2 + J
            END IF
            XYS = XYS + XYXY(IK) + XYXY(JK)
          END DO
          XYS = XYS*HALF
          DO K = 1, NAD
            DO L = 1, NAD
              IK = (I-1)*NAD + K
              JL = (J-1)*NAD + L
              IF (IK.GE.JL) THEN
                IKJL = (IK*IK-IK)/2 + JL
              ELSE
                IKJL = (JL*JL-JL)/2 + IK
              END IF
              IL = (I-1)*NAD + L
              JK = (J-1)*NAD + K
              IF (IL.GE.JK) THEN
                ILJK = (IL*IL-IL)/2 + JK
              ELSE
                ILJK = (JK*JK-JK)/2 + IL
              END IF
              XIYJ = TMP2(IKJL)
              XJYI = TMP2(ILJK)
              IF (I.NE.J) THEN
                E3 = E3 + TWO*(XIYJ-XJYI)**2/
     *          (E(K+NACORE)+E(L+NACORE)-E(I+NOCD)-E(J+NOCD)-XYS)
              ELSE
                E3 = E3 +     (XIYJ-XJYI)**2/
     *          (E(K+NACORE)+E(L+NACORE)-E(I+NOCD)-E(J+NOCD)-XYS)
              END IF
            END DO
          END DO
        END DO
      END DO
      E3 = E3*HALF*HALF
      IF (OUTPUT) WRITE(ICHANL,1) 3,E3,'TWO SINGLY OCCUPIED'
C
C  TERM 4
C
      E4 = ZERO
      DO I = NOCD1, NOCC
        DO K = NOCD1, NOCC
          XYS = ZERO
          IS = I - NOCD
          KS = K - NOCD
          DO LS = 1, NOCS
            IF (IS.GE.LS) THEN
              IL = (IS*IS-IS)/2 + LS
            ELSE
              IL = (LS*LS-LS)/2 + IS
            END IF
            IF (KS.GE.LS) THEN
              KL = (KS*KS-KS)/2 + LS
            ELSE
              KL = (LS*LS-LS)/2 + KS
            END IF
            XYS = XYS + XYXY(IL) + XYXY(KL)
          END DO
          XYS = XYS*HALF
          DO J = NCP1, NOCD
            IJ = (I*I-I)/2 + J
            IJK = (IJ-1)*NOCC + K
            IF (IJK.GE.JL_VOOO.AND.IJK.LE.JH_VOOO) THEN
              CALL DDI_GET(D_VOOO,1,NVIR,IJK,IJK,TMP1)
              DO A = 1, NVIR
                E4 = E4 + TMP1(A)**2/
     *              (E(K)+E(J)-E(I)-E(A+NOCC)-XYS)
              END DO
            END IF
          END DO
        END DO
      END DO
      CALL DDI_GSUMF(994,E4,1)
      IF (OUTPUT) WRITE(ICHANL,1) 4,E4,'SINGLY UNOCCUPIED/OCCUPIED'
C
C  TERM 5
C
      E5 = ZERO
      DO I = NOCD1, NOCC
        DO J = NOCD1, I
          DO K = NCP1, NOCD
            IK = (I*I-I)/2 + K
            IIK = (IK-1)*NOCC + I
            JK = (J*J-J)/2 + K
            JJK = (JK-1)*NOCC + J
            IF (IIK.GE.JL_VOOO.AND.IIK.LE.JH_VOOO) THEN
              CALL DDI_GET(D_VOOO,1,NVIR,IIK,IIK,TMP1)
              CALL DDI_GET(D_VOOO,1,NVIR,JJK,JJK,TMP2)
              DO A = 1, NVIR
                AXIX = TMP1(A)
                AYIY = TMP2(A)
                IF (I.NE.J) THEN
                  E5 = E5 + TWO*AXIX*AYIY/(E(K)-E(NOCC+A))
                ELSE
                  E5 = E5 +     AXIX*AYIY/(E(K)-E(NOCC+A))
                END IF
              END DO
            END IF
          END DO
        END DO
      END DO
      CALL DDI_GSUMF(995,E5,1)
      E5 = E5*HALF
      IF (OUTPUT) WRITE(ICHANL,1) 5,E5,'"FOCK MATRIX CONTRIBUTION"'
C
C  TERM 6
C
      E6 = ZERO
      DO I = NOCD1, NOCC
        XYS = ZERO
        DO J = NOCD1, NOCC
          IS = I - NOCD
          JS = J - NOCD
          IJ = (IS*IS-IS)/2 + JS
          IF(J.GT.I) IJ = (JS*JS-JS)/2 + IS
          XYS = XYS + XYXY(IJ)
        END DO
        XYS = XYS*HALF
        DO J = NCP1, NOCD
          IJ = (I*I-I)/2 + J
          IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
            CALL DDI_GET(D_VOVO,1,NVSQ,IJ,IJ,TMP1)
            DO A = 1, NVIR
              DO B = 1, NVIR
                AB   = (B-1)*NVIR + A
                BA   = (A-1)*NVIR + B
                AIBJ = TMP1(AB)
                BIAJ = TMP1(BA)
                E6 = E6 + AIBJ*(TWO*AIBJ-BIAJ)/
     *             (E(I)+E(J)-E(NOCC+A)-E(NOCC+B)-XYS)
              END DO
            END DO
          END IF
        END DO
      END DO
      CALL DDI_GSUMF(996,E6,1)
      IF (OUTPUT) WRITE(ICHANL,1) 6,E6,'SINGLY UNOCCUPIED'
C
C  TERM 7
C
      E7 = ZERO
      DO I = NOCD1, NOCC
        DO J = NOCD1, I
          IJ = (I*I-I)/2 + J
          IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
            IS = I - NOCD
            JS = J - NOCD
            XYS = ZERO
            DO KS = 1, NOCS
              IF (IS.GE.KS) THEN
                IK = (IS*IS-IS)/2 + KS
              ELSE
                IK = (KS*KS-KS)/2 + IS
              END IF
              IF (JS.GE.KS) THEN
                JK = (JS*JS-JS)/2 + KS
              ELSE
                JK = (KS*KS-KS)/2 + JS
              END IF
              XYS = XYS + XYXY(IK) + XYXY(JK)
            END DO
            XYS = XYS*HALF
            CALL DDI_GET(D_VOVO,1,NVSQ,IJ,IJ,TMP1)
            DO A = 1, NVIR
              DO B = 1, NVIR
                AB   = (B-1)*NVIR + A
                BA   = (A-1)*NVIR + B
                AIBJ = TMP1(AB)
                BIAJ = TMP1(BA)
                IF (I.NE.J) THEN
                  E7 = E7 + TWO*(AIBJ-BIAJ)**2/
     *            (E(I)+E(J)-E(NOCC+A)-E(NOCC+B)-XYS)
                ELSE
                  E7 = E7 +     (AIBJ-BIAJ)**2/
     *            (E(I)+E(J)-E(NOCC+A)-E(NOCC+B)-XYS)
                END IF
              END DO
            END DO
          END IF
        END DO
      END DO
      CALL DDI_GSUMF(997,E7,1)
      E7 = E7*HALF*HALF
      IF (OUTPUT) WRITE(ICHANL,1) 7,E7,'TWO SINGLY UNOCCUPIED'
C
C  SUM TERMS 1-7
C
      EZ = E1 + E2 + E3 + E4 + E5 + E6 + E7
      EMP2 = ESCF + EZ
      IF (OUTPUT) THEN
        WRITE(ICHANL,3) EZ, EMP2
        CALL FLSHBF(ICHANL)
      END IF
      RETURN
1     FORMAT(24X,'E',1I1,' = ',1F20.10,1X,A)
2     FORMAT(21X,'E(SCF)= ',1F20.10)
3     FORMAT(18X,'ZAPT E(2)= ',1F20.10/
     *       21X,'E(MP2)= ',1F20.10)
      END
C*MODULE MP2DDI  *DECK PAR1PDM
      SUBROUTINE PAR1PDM(CMO,EORB,PMAT,PSCF,WMAT,SCHWA,MOLABS)
C
C -----------------------------------------------------------------
C  MP2 1-PARTICLE DENSITY DRIVING ROUTINE (PAR1PDM,WP,WOV,CACT,SQTR)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXATM=2000, MXIRR=14)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,ABELPT,UMP2GD
      INTEGER MOLABS(*),A
      DOUBLE PRECISION CMO(NBF,*),EORB(*),PMAT(NBF,*),PSCF(NBF,*)
     *,      WMAT(NBF,*),SCHWA(*)
C
      COMMON /FMCOM / XX(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWORD,MEMPRI,MPPROP,
     *                NACORE_MP2PAR,NBCORE_MP2PAR,NOA,NOB,NO,NBF_MP2PAR,
     *                NOMIT,MOCPHF,MAXITC
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48)
     *,               TSYM(432),INVT(48),NT
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      IF (OUTPUT) THEN
        WRITE(ICHANL,1)
        CALL FLSHBF(ICHANL)
      END IF
C
C  CONSTRUCT TERMS OF P(2), W(2), AND LAGRANGIAN
C
      CALL VALFM(LOADFM)
      ITMP1 = 1     + LOADFM
      ITMP2 = ITMP1 + NBSQ
      LAST  = ITMP2 + NBSQ
      NEED  = LAST  - LOADFM
      CALL GETFM(NEED)
      CALL WP(PMAT
     *,       WMAT
     *,       EORB
     *,       XX(ITMP1),XX(ITMP2))
      CALL RETFM(NEED)
C
C  DONE WITH (OO|OO) INTEGRALS
C
      CALL DDI_DESTROY( D_OOOO )
C
C  COMPUTE VVVO TERMS OF THE LAGRANGIAN
C
      CALL LAGVVV(WMAT,PMAT,CMO,EORB,SCHWA)
C
C  GLOBAL SUM OF W(2)
C
      CALL DDI_GSUMF(1002,WMAT,NBSQ)
C
C  COMBINE TERMS OF LAGRANGIAN - COPY INTO XX(IZ)
C
      CALL VALFM(LOADFM)
      IZ    = 1     + LOADFM
      IRLAG = IZ    + NOV
      LAST  = IRLAG + NOV
      NEEDZ = LAST  - LOADFM
      CALL GETFM(NEEDZ)
      IA = IZ - 1
      DO I = 1, NOCC
        DO A = NOP1, NMOS
          IA = IA + 1
          IF (MOLABS(I).EQ.MOLABS(A)) THEN
            XX(IA) = -WMAT(A,I) -WMAT(I,A)
          ELSE
            XX(IA) = ZERO
          END IF
        END DO
      END DO
      IF (OUTPUT) THEN
        WRITE(ICHANL,2)
        CALL FLSHBF(ICHANL)
      END IF
C
C  SOLVE Z-MATRIX EQUATION FOR OCCUPIED-VIRTUAL BLOCK OF P(2)
C
      CALL VALFM(LOADFM)
      ITMP = 1    + LOADFM
      NSYM = ITMP + MXIRR
      NVSM = NSYM + NMOS
      LVSM = NVSM + MXIRR
      LAST = LVSM + MXIRR*NMOS
      NEEDS= LAST - LOADFM
      CALL GETFM(NEEDS)
C
C  IN CASE OF NON-ABELIAN POINT GROUPS...
C
      NTSAVE = NT
      IF (.NOT.ABELPT()) NT = 1
C
C  GROUP VIRTUAL MOS ACCORDING TO SYMMETRY
C
      CALL SYMVMO(MOLABS,XX(ITMP),XX(NSYM)
     *,           XX(NVSM),XX(LVSM),MXIRR,NOCC,NOP1,NMOS
     *,           DUM,DUM,DUM,.FALSE.)
C
C  FORM REDUCED LAGRANGIAN
C
      LENRL = NOV
      CALL SYMRL(MOLABS,XX(IZ),XX(IRLAG),LENRL,NOCC,NOP1,NMOS)
      LEN = LENRL
      IF (LENRL.EQ.0) GO TO 100
C
C  CREATE THE DM FOR STORING THE TRIAL VECTORS
C
      MAXC = MAXITC
      CALL DDI_CREATE(LEN,MAXC,D_U)
C
C  ALLOCATE WORKSPACES FOR CPHF SOLVER
C
      CALL VALFM(LOADFM)
      ITMP1  = 1      + LOADFM
      ITMP2  = ITMP1  + LEN
      ITMP3  = ITMP2  + LEN
      ITMP4  = ITMP3  + LEN
      ITMP5  = ITMP4  + MAXC
      ITMP6  = ITMP5  + MAXC
      ITMP7  = ITMP6  + MAXC
      ITMP8  = ITMP7  + MAXC*MAXC
      ITMP9  = ITMP8  + MAX0( NVSQ, MAX0(MAXC,LEN) )
      ITMP10 = ITMP9  + MAX0(NVSQ,MAXC)
      ITMP11 = ITMP10 + NVTR
      ITMP12 = ITMP11 + MAXC*MAXC
      LAST   = ITMP12 + MAXC
      NEED   = LAST   - LOADFM
      CALL GETFM(NEED)
C
C  NOW SOLVE FOR THE REDUCED Z-VECTOR
C
      CALL ZVECTR(EORB,XX(IRLAG)
     *,            XX(ITMP1),XX(ITMP2),XX(ITMP3)
     *,            XX(ITMP4),XX(ITMP5),XX(ITMP6),XX(ITMP7)
     *,            XX(ITMP8),XX(ITMP9),XX(ITMP10)
     *,            XX(ITMP11),XX(ITMP12)
     *,            MOLABS,XX(NSYM),XX(NVSM),XX(LVSM)
     *,            MAXC,LEN,MXIRR
     *,            DUM,DUM,DUM,DUM
     *,            DUM,DUM,DUM,DUM,DUM,DUM,DUM)
      CALL RETFM(NEED)
      CALL DDI_DESTROY( D_U )
  100 CONTINUE
      CALL RETFM(NEEDS)
C
C  RESTORE SOLUTION VECTOR TO FULL P(OV)
C
      CALL SYMPOV(MOLABS,XX(IZ),XX(IRLAG),LENRL,NOCC,NOP1,NMOS)
C
C  IN CASE OF NON-ABELIAN GROUPS...
C
      NT = NTSAVE
      IF (OUTPUT) THEN
        WRITE(ICHANL,3)
        CALL FLSHBF(ICHANL)
      END IF
C
C  TERMS OF THE W(2) DEPENDENT ON THE P(OV)
C
      CALL VALFM(LOADFM)
      ITMP1 = 1     + LOADFM
      ITMP2 = ITMP1 + NOSQ
      LAST  = ITMP2 + MAX0(NOSQ,NVIR)
      NEED  = LAST  - LOADFM
      CALL GETFM(NEED)
      CALL WOV(PMAT,XX(IZ),WMAT,EORB,XX(ITMP1),XX(ITMP2))
      CALL RETFM(NEED)
      CALL RETFM(NEEDZ)
C
C  DONE WITH THE (VV|OO) AND (VO|OO) INTEGRALS
C
      CALL DDI_DESTROY( D_VVOO )
      CALL DDI_DESTROY( D_VOOO )
C
C  FINISH OFF 1-PARTICLE DENSITY MATRICES
C
      CALL VALFM(LOADFM)
      ITMP1 = 1     + LOADFM
      ITMP2 = ITMP1 + NBSQ
      LAST  = ITMP2 + NBSQ
      NEED  = LAST  - LOADFM
      CALL GETFM(NEED)
C
C  P(MP2)  - THIS WEIGHTS THE CORE-HAMILTONIAN DERIVATIVE INTEGRALS
C
      CALL DSCAL(NBSQ,TWO,PMAT,1)
C
C  BACK-TRANSFORM P(2) TO AO-BASIS
C
      CALL CACT(NBF,NMOS
     *,         PMAT,NBF
     *,         CMO,NBF
     *,         XX(ITMP1),NBF,XX(ITMP2))
C
C  SYMMETRISE P(2)
C
      CALL SQTR(XX(ITMP1),PMAT,NBF)
C
C  FORM P(SCF)
C
      CALL DGEMM('N','T',  NBF,NBF,NOCC
     *,           TWO,CMO,NBF
     *,           CMO,NBF
     *,           ZERO,XX(ITMP1),NBF)
C
C  SYMMETRISE P(SCF)
C
      CALL SQTR(XX(ITMP1),PSCF,NBF)
C
C  SAVE P(SCF) ON DAF RECORD 308
C
      CALL DAWRIT(IDAF,IODA,PSCF,NBTR,308,0)
C
C  P(MP2) = P(2) + P(SCF)
C
      CALL DCOPY(NBTR,PSCF,1,XX(ITMP1),1)
      CALL DAXPY(NBTR,ONE,PMAT,1,XX(ITMP1),1)
C
C  SAVE P(MP2) TO DISC
C
      CALL DAWRIT(IDAF,IODA,XX(ITMP1),NBTR,16,0)
C
C  W(MP2)  - THIS WEIGHTS THE OVERLAP DERIVATIVE INTEGRALS
C
      CALL DSCAL(NBSQ,TWO,WMAT,1)
C
C  ADD W(SCF) TERM TO FORM W(MP2) IN THE MO BASIS
C
      DO I = 1, NOCC
        WMAT(I,I) = WMAT(I,I) -TWO*EORB(I)
      END DO
C
C  BACK-TRANSFORM W(MP2) TO AO-BASIS
C
      CALL CACT(NBF,NMOS
     *,         WMAT,NBF
     *,         CMO,NBF
     *,         WMAT,NBF,XX(ITMP1))
C
C  SYMMETRISE W(MP2)
C
      CALL SQTR(WMAT,XX(ITMP1),NBF)
C
C  SAVE W(MP2) TO DISC
C
      CALL DAWRIT(IDAF,IODA,XX(ITMP1),NBTR,309,0)
C
C  FREE WORKSPACE
C
      CALL RETFM(NEED)
C
C  RESET DLB COUNTER - THIS SEEMS TO BE NEEDED FOR
C  RUNNING THE 1-PARTICLE GRADIENT IN PARALLEL
C
      IF (IBTYP.EQ.1) CALL DDI_DLBRESET()
      RETURN
1     FORMAT(/,6X,'COMPUTING CONTRIBUTIONS TO THE 1-PARTICLE DENSITY',
     *            ' MATRICES')
2     FORMAT(/,6X,'SOLVING FOR Z-VECTOR')
3     FORMAT(/,6X,'COMPUTING LAST CONTRIBUTIONS TO THE 1-PARTICLE',
     *            ' DENSITY')
      END
C*MODULE MP2DDI  *DECK WP
      SUBROUTINE WP(PMAT,WMAT,EORB,BUF1,BUF2)
C
C -----------------------------------------------------------------
C  CONSTRUCT TERMS OF W(2) AND P(2)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00, ONE=1.0D+00, TWO=2.0D+00)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,UMP2GD
      INTEGER A,B,AB,BA
      DOUBLE PRECISION PMAT(NBF,NBF),WMAT(NBF,NBF),EORB(NBF)
     *,      BUF1(NBF*NBF),BUF2(NBF*NBF)
C
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      CALL DCOPY(NBSQ,ZERO,0,WMAT,1)
      CALL DCOPY(NBSQ,ZERO,0,PMAT,1)
      CALL DDI_DISTRIB(D_VOVO,ME,IL_VOVO,IH_VOVO,JL_VOVO,JH_VOVO)
C
C  TERMS INVOLVING VOVO-TYPE INTEGRALS ONLY:
C  VIRTUAL BLOCK OF P(2) AND TERM OF VIRTUAL BLOCK OF W(2)
C
      DO I = NCP1, NOCC
       DO J = NCP1, I
        IJ = (I*I-I)/2 + J
        IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
         CALL DDI_GET(D_VOVO,1,NVSQ,IJ,IJ,BUF2)
         BA = 0
         DO A = 1, NVIR
          AB = A - NVIR
          DO B = 1, NVIR
           BA = BA + 1
           AB = AB + NVIR
           BUF1(BA) = (TWO*BUF2(AB)-BUF2(BA))/
     *              (EORB(I)+EORB(J)-EORB(NOCC+A)-EORB(NOCC+B))
          END DO
         END DO
         CALL DGEMM('N','N',NVIR,NVIR,NVIR
     *,             -ONE,BUF2,NVIR
     *,             BUF1,NVIR
     *,             ONE,WMAT(NOP1,NOP1),NBF)
         IF (I.NE.J) THEN
          CALL DGEMM('T','T',NVIR,NVIR,NVIR
     *,              -ONE,BUF2,NVIR
     *,              BUF1,NVIR
     *,              ONE,WMAT(NOP1,NOP1),NBF)
         END IF
         BA = 0
         DO A = 1, NVIR
          AB = A - NVIR
          DO B = 1, NVIR
           BA = BA + 1
           AB = AB + NVIR
           BUF2(BA) = BUF2(BA)/
     *              (EORB(I)+EORB(J)-EORB(NOCC+A)-EORB(NOCC+B))
          END DO
         END DO
         CALL DGEMM('T','T',NVIR,NVIR,NVIR
     *,             ONE,BUF1,NVIR
     *,             BUF2,NVIR
     *,             ONE,PMAT(NOP1,NOP1),NBF)
         IF (I.NE.J) THEN
          CALL DGEMM('N','N',NVIR,NVIR,NVIR
     *,              ONE,BUF1,NVIR
     *,              BUF2,NVIR
     *,              ONE,PMAT(NOP1,NOP1),NBF)
         END IF
        END IF
       END DO
      END DO
C
C  OCCUPIED BLOCK OF P(2) AND TERM OF OCCUPIED BLOCK OF W(2)
C
      NCPOFF = NACORE*NOCC + NCP1
      NCAOFF = NACORE*NOCC + 1
      NACOFF = NCP1
      ITASK = 0
      DO A = 1, NVIR
       DO B = 1, A
         ITASK = ITASK + 1
         IF (MOD(ITASK,NPROC).EQ.ME) THEN
C
C  GET BLOCK OF VOVO INTEGRALS FOR ALL OCC-INDICES
C
         AB = (A-1)*NVIR + B
         CALL DDI_GET(D_VOVO,AB,AB,1,NOTR,BUF1)
         IC = 0
         DO I = 1, NOCC
           DO J = 1, I
             IC = IC + 1
             JI = (J-1)*NOCC + I
             IJ = (I-1)*NOCC + J
             BUF2(JI) = BUF1(IC)
             BUF2(IJ) = BUF1(IC)
           END DO
         END DO
         IF (A.NE.B) THEN
           BA = (B-1)*NVIR + A
           CALL DDI_GET(D_VOVO,BA,BA,1,NOTR,BUF1)
           IC = 0
           DO I = 1, NOCC
             DO J = 1, I
               IC = IC + 1
               IJ = (I-1)*NOCC + J
               BUF2(IJ) = BUF1(IC)
             END DO
           END DO
         END IF
         DO I = NCP1, NOCC
          DO J = NCP1, NOCC
           IJ = (I-1)*NOCC + J
           JI = (J-1)*NOCC + I
           BUF1(IJ) = (TWO*BUF2(JI)-BUF2(IJ))/
     *       (EORB(I)+EORB(J)-EORB(NOCC+A)-EORB(NOCC+B))
          END DO
         END DO
         CALL DGEMM('N','N',NACT,NACT,NACT
     *,             -ONE,BUF2(NCPOFF),NOCC
     *,             BUF1(NCPOFF),NOCC
     *,             ONE,WMAT(NCP1,NCP1),NBF)
         IF (A.NE.B) THEN
          CALL DGEMM('T','T',NACT,NACT,NACT
     *,              -ONE,BUF2(NCPOFF),NOCC
     *,              BUF1(NCPOFF),NOCC
     *,              ONE,WMAT(NCP1,NCP1),NBF)
         END IF
         CALL DGEMM('N','N',NACORE,NACT,NACT
     *,             -ONE,BUF2(NCAOFF),NOCC
     *,             BUF1(NCPOFF),NOCC
     *,             ONE,PMAT(1,NCP1),NBF)
         IF (A.NE.B) THEN
           CALL DGEMM('T','T',NACORE,NACT,NACT
     *,               -ONE,BUF2(NACOFF),NOCC
     *,               BUF1(NCPOFF),NOCC
     *,               ONE,PMAT(1,NCP1),NBF)
         END IF
         DO I = NCP1, NOCC
          DO J = NCP1, NOCC
           IJ = (I-1)*NOCC + J
           BUF2(IJ) = BUF2(IJ)/
     *       (EORB(I)+EORB(J)-EORB(NOCC+A)-EORB(NOCC+B))
          END DO
         END DO
         CALL DGEMM('T','T',NACT,NACT,NACT
     *,             -ONE,BUF1(NCPOFF),NOCC
     *,             BUF2(NCPOFF),NOCC
     *,             ONE,PMAT(NCP1,NCP1),NBF)
         IF (A.NE.B) THEN
          CALL DGEMM('N','N',NACT,NACT,NACT
     *,              -ONE,BUF1(NCPOFF),NOCC
     *,              BUF2(NCPOFF),NOCC
     *,              ONE,PMAT(NCP1,NCP1),NBF)
         END IF
        END IF
       END DO
      END DO
C
C  CORE-VALENCE BLOCKS OF P(2) AND W(2)
C
      DO I = 1, NACORE
       DO J = NCP1, NOCC
        WMAT(I,J) = PMAT(I,J)*0.5D+00
        WMAT(J,I) = WMAT(I,J)
        PMAT(I,J) = PMAT(I,J)/(EORB(I)-EORB(J))
        PMAT(J,I) = PMAT(I,J)
       END DO
      END DO
C
C  NOW DO A GLOBAL-SUM OF P(2)
C
      CALL DDI_GSUMF(1001,PMAT,NBSQ)
C
C  TERMS INVOLVING VOOO-TYPE INTEGRALS:
C  OCCUPIED-VIRTUAL BLOCK OF W(2) AND LAGRANGIAN
C  (STORED IN THE VIRTUAL-OCCUPIED BLOCK OF W(2)).
C
      IJ = 0
      DO K = 1, NOCC
       DO J = 1, K
        IJ = IJ + 1
        IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
         CALL DDI_GET(D_VOVO,1,NVSQ,IJ,IJ,BUF2)
         BA = 0
         DO A = 1, NVIR
          AB = A - NVIR
          DO B = 1, NVIR
           BA = BA + 1
           AB = AB + NVIR
           BUF1(BA) = (TWO*BUF2(AB)-BUF2(BA))/
     *              (EORB(J)+EORB(K)-EORB(NOCC+A)-EORB(NOCC+B))
          END DO
         END DO
         IA = 1
         DO I = 1, NOCC
          IF (I.GE.K) THEN
           JK = ((I*I-I)/2+K-1)*NOCC + J
          ELSE
           JK = ((K*K-K)/2+I-1)*NOCC + J
          END IF
          CALL DDI_GET(D_VOOO,1,NVIR,JK,JK,BUF2(IA))
          IA = IA + NVIR
         END DO
C
C  OCC-VIRT TERM OF W(2)
C
         IF (J.LE.NACORE.OR.K.LE.NACORE) THEN
C  (SKIP CORE INDICES)
         ELSE
         CALL DGEMM('T','N',NOCC,NVIR,NVIR
     *,             -ONE,BUF2,NVIR
     *,             BUF1,NVIR
     *,             ONE,WMAT(1,NOP1),NBF)
         END IF
C
C  P(2)*VOOO TERM OF LAGRANGIAN
C
         IA = 0
         DO I = 1, NOCC
          DO A = NOP1, NMOS
           IA = IA + 1
           XIAJB = BUF2(IA)
           WMAT(A,J) = WMAT(A,J) + XIAJB*PMAT(I,K)*TWO
           WMAT(A,I) = WMAT(A,I) - XIAJB*PMAT(J,K)*HALF
           WMAT(A,K) = WMAT(A,K) - XIAJB*PMAT(J,I)*HALF
          END DO
         END DO
C
         IF (J.NE.K) THEN
          IA = 1
          DO I = 1, NOCC
           IF (I.GE.J) THEN
            JK = ((I*I-I)/2+J-1)*NOCC + K
           ELSE
            JK = ((J*J-J)/2+I-1)*NOCC + K
           END IF
           CALL DDI_GET(D_VOOO,1,NVIR,JK,JK,BUF2(IA))
           IA = IA + NVIR
          END DO
C
C  OCC-VIRT TERM OF W(2)
C
         IF (J.LE.NACORE.OR.K.LE.NACORE) THEN
C  (SKIP CORE INDICES)
         ELSE
          CALL DGEMM('T','T',NOCC,NVIR,NVIR
     *,              -ONE,BUF2,NVIR
     *,              BUF1,NVIR
     *,              ONE,WMAT(1,NOP1),NBF)
         END IF
C
C  P(2)*VOOO TERM OF LAGRANGIAN
C
          IA = 0
          DO I = 1, NOCC
           DO A = NOP1, NMOS
            IA = IA + 1
            XIAJB = BUF2(IA)
            WMAT(A,K) = WMAT(A,K) + XIAJB*PMAT(I,J)*TWO
            WMAT(A,I) = WMAT(A,I) - XIAJB*PMAT(K,J)*HALF
            WMAT(A,J) = WMAT(A,J) - XIAJB*PMAT(K,I)*HALF
           END DO
          END DO
         END IF
        END IF
       END DO
      END DO
C
C  TERMS INVOLVING VVOO- & OOOO-TYPE INTEGRALS:
C  OCCUPIED BLOCK OF W(2).
C
      IJ = 0
      DO I = 1, NOCC
       DO J = 1, I
        IJ = IJ + 1
        IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
         CALL DDI_GET(D_OOOO,1,NOTR,IJ,IJ,BUF1)
         DO K = 1, NOCC
          DO L = 1, NOCC
           KL = (K*K-K)/2 + L
           IF (K.LT.L) KL = (L*L-L)/2 + K
           XIAJB = BUF1(KL)
           WMAT(I,J) = WMAT(I,J) - XIAJB*PMAT(K,L)*TWO
           WMAT(I,K) = WMAT(I,K) + XIAJB*PMAT(J,L)*HALF
           WMAT(I,L) = WMAT(I,L) + XIAJB*PMAT(J,K)*HALF
          END DO
         END DO
         IF (I.NE.J) THEN
          DO K = 1, NOCC
           DO L = 1, NOCC
            KL = (K*K-K)/2 + L
            IF (K.LT.L) KL = (L*L-L)/2 + K
            XIAJB = BUF1(KL)
            WMAT(J,I) = WMAT(J,I) - XIAJB*PMAT(K,L)*TWO
            WMAT(J,K) = WMAT(J,K) + XIAJB*PMAT(I,L)*HALF
            WMAT(J,L) = WMAT(J,L) + XIAJB*PMAT(I,K)*HALF
           END DO
          END DO
         END IF
         CALL DDI_GET(D_VVOO,1,NVTR,IJ,IJ,BUF1)
         CALL DDI_GET(D_VOVO,1,NVSQ,IJ,IJ,BUF2)
         DO A = 1, NVIR
          DO B = 1, NVIR
           AB = (A*A-A)/2 + B
           IF (A.LT.B) AB = (B*B-B)/2 + A
           XIAJB = BUF1(AB)
           WMAT(I,J) = WMAT(I,J) - XIAJB*PMAT(A+NOCC,B+NOCC)*TWO
           AB = (B-1)*NVIR + A
           XIAJB = BUF2(AB)
           WMAT(I,J) = WMAT(I,J) + XIAJB*PMAT(A+NOCC,B+NOCC)*HALF
           WMAT(J,I) = WMAT(J,I) + XIAJB*PMAT(A+NOCC,B+NOCC)*HALF
          END DO
         END DO
         IF (I.NE.J) THEN
          DO A = 1, NVIR
           DO B = 1, NVIR
            AB = (A*A-A)/2 + B
            IF (A.LT.B) AB = (B*B-B)/2 + A
            XIAJB = BUF1(AB)
            WMAT(J,I) = WMAT(J,I) - XIAJB*PMAT(A+NOCC,B+NOCC)*TWO
            AB = (A-1)*NVIR + B
            XIAJB = BUF2(AB)
            WMAT(J,I) = WMAT(J,I) + XIAJB*PMAT(A+NOCC,B+NOCC)*HALF
            WMAT(I,J) = WMAT(I,J) + XIAJB*PMAT(A+NOCC,B+NOCC)*HALF
           END DO
          END DO
         END IF
        END IF
       END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK WOV
      SUBROUTINE WOV(PMAT,Z,WMAT,EORB,T,BUF)
C
C -----------------------------------------------------------------
C  COMPLETE REMAINING TERMS OF W(2) THAT DEPEND ON THE
C  OCCUPIED-VIRTUAL BLOCK OF P(2)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (HALF=0.5D+00, FOUR=4.0D+00)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,UMP2GD
      INTEGER A,B,AV
      DOUBLE PRECISION PMAT(NBF,*),WMAT(NBF,*),Z(*),EORB(*),
     *                 T(NOCC,*),BUF(*)
C
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      IA = 0
      DO I = 1, NOCC
        DO A = NOP1, NMOS
          IA = IA + 1
          PMAT(A,I) = Z(IA)
          PMAT(I,A) = Z(IA)
        END DO
      END DO
C
C  TERMS OF W(2) INVOLVING EIGENVALUES TIMES P(2) ELEMENTS
C
      DO I = 1, NOCC
        DO J = 1, NOCC
          WMAT(I,J) = WMAT(I,J) -HALF*PMAT(I,J)*(EORB(I)+EORB(J))
        END DO
      END DO
      DO A = NOP1, NMOS
        DO B = NOP1, NMOS
          WMAT(A,B) = WMAT(A,B) -HALF*PMAT(A,B)*(EORB(A)+EORB(B))
        END DO
      END DO
      DO A = NOP1, NMOS
        DO I = 1, NOCC
          WMAT(I,A) = WMAT(I,A) -PMAT(I,A)*EORB(I)
          WMAT(A,I) = WMAT(I,A)
        END DO
      END DO
C
C  CONTRIBUTION TO THE OCCUPIED BLOCK OF W(2) FROM THE
C  VOOO-CLASS INTEGRALS
C
      CALL DDI_DISTRIB(D_VOOO,ME,IL_VOOO,IH_VOOO,JL_VOOO,JH_VOOO)
      CALL DCOPY(NOSQ,0.0D+00,0,T,1)
      IJK = 0
      DO I = 1, NOCC
        DO J = 1, I
          DO K = 1, NOCC
            IJK = IJK + 1
            IF (IJK.GE.JL_VOOO.AND.IJK.LE.JH_VOOO) THEN
              CALL DDI_GET(D_VOOO,1,NVIR,IJK,IJK,BUF)
              DO A = 1, NVIR
                AV = A + NOCC
                T(I,J) = T(I,J) + BUF(A)*PMAT(AV,K)*FOUR
                T(I,K) = T(I,K) - BUF(A)*PMAT(AV,J)
                T(J,K) = T(J,K) - BUF(A)*PMAT(AV,I)
              END DO
              IF (I.NE.J) THEN
                DO A = 1, NVIR
                  AV = A + NOCC
                  T(J,I) = T(J,I) + BUF(A)*PMAT(AV,K)*FOUR
                  T(K,I) = T(K,I) - BUF(A)*PMAT(AV,J)
                  T(K,J) = T(K,J) - BUF(A)*PMAT(AV,I)
                END DO
              END IF
            END IF
          END DO
        END DO
      END DO
      CALL DDI_GSUMF(1004,T,NOSQ)
      DO I = 1, NOCC
        DO J = 1, NOCC
          WMAT(I,J) = WMAT(I,J) - T(I,J)
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK CACT
      SUBROUTINE CACT(N1,N2,A,NA,C,NC,B,NB,TMP)
C
C -----------------------------------------------------------------
C  GENERIC 2-INDEX BACK-TRANSFORMATION
C  COMPUTES B=C*A*C(T)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      INTEGER NA,NB,NC,N1,N2
      DOUBLE PRECISION A(NA,*),C(NC,*),B(NB,*),TMP(*)
C
      CALL DGEMM('N','N',  N1,N2,N2
     *,          ONE,C,NC
     *,          A,NA
     *,          ZERO,TMP,N1)
      CALL DGEMM('N','T',  N1,N1,N2
     *,          ONE,TMP,N1
     *,          C,NC
     *,          ZERO,B,NB)
      RETURN
      END
C*MODULE MP2DDI  *DECK SQTR
      SUBROUTINE SQTR(A,B,N)
C
C -----------------------------------------------------------------
C  SYMMETRISE A SQUARE MATRIX AND PACK IT INTO A TRIANGLE
C -----------------------------------------------------------------
C
      INTEGER N,I,J,IJ
      DOUBLE PRECISION A(N,*),B(*)
C
      IJ = 0
      DO I = 1, N
        DO J = 1, I
          IJ = IJ + 1
          B(IJ) = 0.5D+00*(A(I,J)+A(J,I))
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK LAGVVV
      SUBROUTINE LAGVVV(WMAT,PMAT,CMO,EORB,SCHWA)
C
C -----------------------------------------------------------------
C  DRIVER FOR COMPUTING TERMS OF THE Z-VECTOR `LAGRANGIAN'
C  INVOLVING (VV|VO) INTEGRALS
C  (LAGVVV,BTAMPS,VVVO,SYMIKJL,TRANO,TRANO_P,SUMAO,GETAMPS,VOVO)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXGSH=30, MXG2=MXGSH*MXGSH)
      PARAMETER (MXSH=5000,MXATM=2000)
      LOGICAL OUTPUT,MP2ENG,ABELPT,NOCORE,UMP2GD,ZAPTGD
      DOUBLE PRECISION WMAT(*),PMAT(NBF,*),CMO(NBF,*),EORB(*),SCHWA(*)
      COMMON /FMCOM / XX(1)
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48)
     *,               TSYM(432),INVT(48),NT
      COMMON /ZAPTGR/ NOCD,NOCD1,NOCS,NOCSTR,IXYEXC,ICHIX,ITIA,IZVEC
     *,               ZAPTGD
C
      IF (OUTPUT) THEN
        WRITE(ICHANL,1)
        CALL FLSHBF(ICHANL)
      END IF
      CALL VALFM(LOADFM)
      IPAO  = 1     + LOADFM
      LAST  = IPAO  + NBSQ
      NEEDP = LAST  - LOADFM
      CALL GETFM(NEEDP)
C
C  BACK TRANSFORM AMPLITUDES (OR INTEGRALS FOR ZAPT)
C
      CALL VALFM(LOADFM)
      ITMP1 = 1     + LOADFM
      ITMP2 = ITMP1 + NBSQ
      LAST  = ITMP2 + NBSQ
      NEED  = LAST  - LOADFM
      CALL GETFM(NEED)
C
C  CORE MO INDICES NEEDED FOR THIS TERM
C
      NOCORE = .FALSE.
      IF (ZAPTGD) THEN
        CALL BTINTSZ(EORB,CMO,XX(IXYEXC),XX(ITMP1),XX(ITMP2))
      ELSE
        CALL BTAMPS(EORB,CMO,XX(ITMP1),XX(ITMP2),NOCORE)
      END IF
C
C  BACK TRANSFORM P(2)
C
      CALL CACT(NBF,NVIR
     *,         PMAT(NOP1,NOP1),NBF
     *,         CMO(1,NOP1),NBF
     *,         XX(IPAO),NBF,XX(ITMP1))
      CALL RETFM(NEED)
C
C  COMPUTE VVVO TERMS 3/4 IN THE AO BASIS
C
      CALL VALFM(LOADFM)
      IGOUT = 1     + LOADFM
      ITRAN = IGOUT + MXSHL**4
      IAMPS = ITRAN + MXSHL*MXSHL*NBF*NOCC*2
      ILAGN = IAMPS + NOSQ*MXSHL*MXSHL
      IDDIJ = ILAGN + NOCC*NBF
      LAST  = IDDIJ + 49*MXG2
      NEED  = LAST  - LOADFM
      CALL GETFM(NEED)
C
C  IN CASE OF NON-ABELIAN POINT GROUPS ...
C
      NTSAVE = NT
      IF (.NOT.ABELPT()) NT = 1
      CALL MKVVVO(WMAT,XX(IPAO),CMO,SCHWA,XX(IDDIJ)
     *,           XX(IGOUT),XX(ITRAN),XX(IAMPS),XX(ILAGN))
      NT = NTSAVE
      CALL RETFM(NEED)
      CALL RETFM(NEEDP)
C
C  RESTORE VOVO INTEGRALS
C
      CALL VALFM(LOADFM)
      ITMP1 = 1     + LOADFM
      ITMP2 = ITMP1 + NBSQ
      ICM1  = ITMP2 + NBSQ
      LAST  = ICM1  + NBSQ
      NEED  = LAST  - LOADFM
      CALL GETFM(NEED)
      IF (ZAPTGD) THEN
        CALL ZMKVOVO(XX(ITMP1),XX(ITMP2),XX(ICM1),EORB,CMO,XX(IXYEXC))
      ELSE
        CALL MKVOVO(XX(ITMP1),XX(ITMP2),XX(ICM1),EORB,CMO)
      END IF
      CALL RETFM(NEED)
      RETURN
1     FORMAT(/,6X,'COMPUTING THREE-VIRTUAL CONTRIBUTIONS TO THE',
     *            ' LAGRANGIAN')
      END
C*MODULE MP2DDI  *DECK BTAMPS
      SUBROUTINE BTAMPS(EORB,CMO,BUF,DUM,NOCORE)
C
C -----------------------------------------------------------------
C  BACK-TRANSFORM VIRTUAL INDICES OF THE MP2 AMPLITUDES
C  TO THE AO BASIS OVERWRITING THE VOVO INTEGRALS
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      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
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00)
      LOGICAL GOPARR,DSKWRK,MASWRK,NOCORE,OUTPUT,MP2ENG,UMP2GD
      DOUBLE PRECISION EORB(*),CMO(NBF,*),BUF(*),DUM(*)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      IF (OUTPUT) THEN
        WRITE(ICHANL,1)
        CALL FLSHBF(ICHANL)
      END IF
      NOFF = 1
      IF (NOCORE) NOFF = NCP1
C
C  LOOP OVER LOCAL VOVO INTEGRALS
C
      CALL DDI_DISTRIB(D_VOVO,ME,IL_VOVO,IH_VOVO,JL_VOVO,JH_VOVO)
      DO I = NOFF, NOCC
        DO J = NOFF, I
          IJ = (I*I-I)/2 + J
          IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
            CALL DDI_GET(D_VOVO,1,NVSQ,IJ,IJ,BUF)
C
C  FORM A BLOCK OF MP2 AMPLITUDES SPANNING ALL VIRTUAL
C  MO INDICES
C
            DO K = 1, NVIR
              DO L = 1, K
                KL = (L-1)*NVIR + K
                LK = (K-1)*NVIR + L
                X = BUF(KL)
                Y = BUF(LK)
                DENOM = ONE/
     *          (EORB(I)+EORB(J)-EORB(K+NOCC)-EORB(L+NOCC))
                BUF(KL) = (TWO*X - Y)*DENOM
                BUF(LK) = (TWO*Y - X)*DENOM
              END DO
            END DO
C
C  BACK-TRANSFORM THE VIRTUAL INDICES
C
            CALL CACT(NBF,NVIR
     *,               BUF,NVIR,CMO(1,NOP1),NBF
     *,               BUF,NBF,DUM)
C
C  MAP AO-INDICES INTO SHELL-BLOCKS TO REDUCE NUMBER OF GETS
C
            ICOUNT = 0
            DO ISHELL = 1, NSHELL
              IBEG = KLOC(ISHELL)
              IEND = IBEG + KMAX(ISHELL) - KMIN(ISHELL)
              DO JSHELL = 1, NSHELL
                JBEG = KLOC(JSHELL)
                JEND = JBEG + KMAX(JSHELL) - KMIN(JSHELL)
                DO IAO = IBEG, IEND
                  DO JAO = JBEG, JEND
                    IJAO = (IAO-1)*NBF + JAO
                    ICOUNT = ICOUNT + 1
                    DUM(ICOUNT) = BUF(IJAO)
                  END DO
                END DO
              END DO
            END DO
            CALL DDI_PUT(D_VOVO,1,NBSQ,IJ,IJ,DUM)
          END IF
        END DO
      END DO
C
C  SYNCHRONIZE NODES AFTER THIS OPERATION
C
      CALL DDI_SYNC(9002)
      RETURN
1     FORMAT(6X,'FORMING BACK-TRANSFORMED AMPLITUDES')
      END
C*MODULE MP2DDI  *DECK MKVVVO
      SUBROUTINE MKVVVO(WMAT,PAO,CMO,SCHWA,DDIJ,GOUT,TRAN,T2AO,LAG)
C
C -----------------------------------------------------------------
C  DIRECT VVVO TERMS
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000, MXAO=8192)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      LOGICAL POPLE,PACK2E,IANDJ,KANDL,SAME,GOPARR,DSKWRK,MASWRK
     *,       OUT,OUTPUT,MP2ENG,DLB,DOTASK,UMP2GD,ZAPTGD
      DOUBLE PRECISION WMAT(NBF,*),PAO(*),CMO(NBF,*),SCHWA(*),DDIJ(*)
     *,      GOUT(*),TRAN(*),T2AO(*),LAG(*)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /MISC  / IANDJ,KANDL,SAME
      COMMON /GOUT  / GPOPLE(768),NORG
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      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 /SHLG70/ ISHELL,JSHELL,KSHELL,LSHELL,INEW,JNEW,KNEW,LNEW
      COMMON /SHLNOS/ QQ4,LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJ,KL,IJKL
      COMMON /SHLT  / TOL,CUTOFF,ICOUNT,OUT
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /ZAPTGR/ NOCD,NOCD1,NOCS,NOCSTR,IXYEXC,ICHIX,ITIA,IZVEC
     *,               ZAPTGD
C
      IF (OUTPUT) THEN
        WRITE(ICHANL,1)
        CALL FLSHBF(ICHANL)
      END IF
C
C  INITIALIZE PARAMETERS
C
      LTRAN  = NOCC*NBF*MXSHL*MXSHL*2
      MXSHL4 = MXSHL**4
      IANDJ  = .FALSE.
      KANDL  = .FALSE.
      SAME   = .FALSE.
      Q4     = ONE
      QQ4    = Q4
      NSCHWZ = 0
      NORG   = 0
      LOCTSK = 0
      CALL DCOPY(NBF*NOCC,ZERO,0,LAG,1)
C
C  DYNAMIC LOAD BALANCING
C
      DLB = IBTYP.EQ.1
      IF (DLB) THEN
        CALL DDI_DLBRESET()
        CALL DDI_DLBNEXT( MYTASK )
      END IF
C
C  II-SHELL,KK-SHELL
C
      DO II = 1, NSHELL
       DO KK = 1, II
C
C  SYMMETRY (IK|
C
        CALL SYMIJ(II,KK,Q2)
        IF ( Q2 .GT. ZERO ) THEN
C
C  LOAD BALANCER
C
        IF (DLB) THEN
          DOTASK = LOCTSK.EQ.MYTASK
        ELSE
          DOTASK = MOD(LOCTSK,NPROC).EQ.ME
        END IF
        IF (DOTASK) THEN
C
C  GET HALF-TRANSFORMED AMPLITUDES
C
         IF (ZAPTGD) THEN
           CALL GETAMPSZ(T2AO,TRAN,II,KK)
         ELSE
           CALL GETAMPS(T2AO,TRAN,II,KK)
         END IF
         CALL DCOPY(LTRAN,ZERO,0,TRAN,1)
C
C  JJ-SHELL,LL-SHELL
C
         DO JJ = 1, NSHELL
           DO LL = 1, NSHELL
C
C  SYMMETRY (IJ|KL)
C
            CALL SYMIKJL(II,JJ,KK,LL,Q4,NSHELL)
            IF ( Q4 .GT. ZERO ) THEN
             QQ4 = Q4
C
C  SCHWARZ INEQUALITY TEST
C
             IIJJ = IA(MAX0(II,JJ)) + MIN0(II,JJ)
             KKLL = IA(MAX0(KK,LL)) + MIN0(KK,LL)
             TEST = Q4*SCHWA(IIJJ)*SCHWA(KKLL)
             IF (TEST.LT.CUTOFF) THEN
               NSCHWZ = NSCHWZ + 1
             ELSE
C
C  COMPUTE (IJ|KL) AND TRANSFORM 1 INDEX
C
C     USE POPLE CODE FOR ANY PURE SP INTEGRAL BLOCKS,
C     USE HONDO RYS POLYNOMIAL CODE FOR OTHER BLOCKS
C
              POPLE=.TRUE.
              IF(INTTYP.GE.2)    POPLE=.FALSE.
              IF(KTYPE(II).GT.2) POPLE=.FALSE.
              IF(KTYPE(JJ).GT.2) POPLE=.FALSE.
              IF(KTYPE(KK).GT.2) POPLE=.FALSE.
              IF(KTYPE(LL).GT.2) POPLE=.FALSE.
C
              ISHELL = II
              JSHELL = JJ
              KSHELL = KK
              LSHELL = LL
              IF (POPLE) THEN
               CALL DCOPY(256,ZERO,0,GPOPLE,1)
               CALL GENR70(1,.FALSE.)
               CALL DCOPY(256,GPOPLE,1,GOUT,1)
               CALL TRANO_P(GOUT,CMO,TRAN,CMO,TRAN)
              ELSE
               CALL DCOPY(MXSHL4,ZERO,0,GOUT,1)
               CALL PARSHEL(1,II,JJ,II,JJ)
               CALL IJPRIM(DDIJ)
               IF (NIJ.EQ.0) GO TO 170
               CALL PARSHEL(2,II,JJ,KK,LL)
               IF(IJKL.EQ.1) THEN
                 CALL S0000(GOUT,DDIJ)
               ELSE
                 CALL GENRAL(GOUT,DDIJ)
               END IF
               CALL TRANO(GOUT,CMO,TRAN,CMO,TRAN)
              END IF
             END IF   ! SCHWARZ
            END IF    ! SYM
           END DO     !  LL-SHELL
 170      CONTINUE
         END DO       !  JJ-SHELL
         IF (ZAPTGD) THEN
           CALL ZSUMAO(T2AO,TRAN,LAG,PAO,II,KK)
         ELSE
           CALL SUMAO(T2AO,TRAN,LAG,PAO,II,KK)
         END IF
         IF (DLB) CALL DDI_DLBNEXT( MYTASK )
         END IF       !  LOAD BALANCER
         LOCTSK = LOCTSK + 1
        END IF        !  SYM (IK|
       END DO         !  KK-SHELL
      END DO          !  II-SHELL
C
C  TRANSFORM AO INDICES OF THE LAGRANGIAN TO VIRTUAL MO INDICES
C  SUMMING INTO THE VIRTUAL-OCCUPIED BLOCK OF W(2)
C  (LAGRANGIAN FOR ZAPT GRADIENTS STORED IN DIFFERENT BLOCK OF WMAT)
C
      IF (ZAPTGD) THEN
        CALL DGEMM('T','N',NOCC,NVIR,NBF
     *,            ONE,LAG,NBF
     *,            CMO(1,NOP1),NBF
     *,            ONE,WMAT(1,NOP1),NBF)
      ELSE
        CALL DGEMM('T','N',NVIR,NOCC,NBF
     *,            ONE,CMO(1,NOP1),NBF
     *,            LAG,NBF
     *,            ONE,WMAT(NOP1,1),NBF)
      END IF
      CALL DDI_GSUMI(1099,NSCHWZ,1)
      IF (DLB) CALL DDI_DLBRESET
      IF (OUTPUT) THEN
        WRITE(ICHANL,3) NSCHWZ
        CALL FLSHBF(ICHANL)
      END IF
      RETURN
1     FORMAT(6X,'COMPUTING (VV|VO) INTEGRAL CLASS ')
3     FORMAT(6X,'SCHWARZ INEQUALITY TEST SKIPPED ',I10,
     * ' INTEGRAL BLOCKS')
      END
C*MODULE MP2DDI  *DECK GETAMPS
      SUBROUTINE GETAMPS(T2AO,BUFF,II,KK)
C
C -----------------------------------------------------------------
C  GET A BLOCK OF HALF-TRANSFORMED AMPLITUDES
C  WITH AT MOST TWO DDI_GETS
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      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
      LOGICAL OUTPUT,MP2ENG,UMP2GD
      DOUBLE PRECISION T2AO(NOCC,NOCC,*),BUFF(*)
C
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      LENI = KMAX(II) - KMIN(II) + 1
      LENK = KMAX(KK) - KMIN(KK) + 1
      LENIK = LENI*LENK
C
C  FIND BEGIN,END SHELL BLOCK-IK
C
      IKB = NBF*( KLOC(II) - 1 ) + LENI*( KLOC(KK) - 1 ) + 1
      IKE = IKB + LENIK - 1
      CALL DDI_GET(D_VOVO, IKB, IKE, 1, NOTR, BUFF)
C
C  TRANSPOSE AMPLITUDES FOR EFFICIENT TRANSFORMATION
C
      NL = 0
      DO N = 1, LENI
        DO L = 1, LENK
          NL = NL + 1
          NLIJ = NL
          DO I = 1, NOCC
            DO J = 1, I
              T2AO(I,J,NL) = BUFF(NLIJ)
              NLIJ = NLIJ + LENIK
            END DO
          END DO
        END DO
      END DO
      IF (II.NE.KK) THEN
C
C  FIND BEGIN,END SHELL BLOCK-KI
C
        KIB = NBF*( KLOC(KK) - 1 ) + LENK*( KLOC(II) - 1 ) + 1
        KIE = KIB + LENIK - 1
        CALL DDI_GET(D_VOVO, KIB, KIE, 1, NOTR, BUFF)
      END IF
C
C  TRANSPOSE AMPLITUDES FOR EFFICIENT TRANSFORMATION
C
      NL = 0
      DO N = 1, LENI
        DO L = 1, LENK
          NL = NL + 1
          NLIJ = (L-1)*LENI + N
          DO I = 1, NOCC
            DO J = 1, I
              T2AO(J,I,NL) = BUFF(NLIJ)
              NLIJ = NLIJ + LENIK
            END DO
          END DO
        END DO
      END DO
      RETURN
      END
C
C*MODULE MP2DDI  *DECK SYMIKJL
C -----------------------------------------------------------------
C  CONSTITUENCY NUMBERS ADJUSTED FOR PERMUTATIONAL SYMMETRIES
C  EMPLOYED IN THE VVVO TERMS AND 2-PARTICLE GRADIENT
C -----------------------------------------------------------------
C
      SUBROUTINE SYMIKJL(II,JJ,KK,LL,Q4,NSHELL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXSH=5000,MXATM=2000, MXAO=8192)
      INTEGER II,JJ,KK,LL, II_NEW,JJ_NEW,KK_NEW,LL_NEW
     *,       OP, NS2, INDX, INDX_NEW, N
      DOUBLE PRECISION Q4
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48)
     *,               TSYM(432),INVT(48),NT
C
      Q4 = 0.0D+00
      NS2 = NSHELL*NSHELL
C
C  ORIGINAL 4-INDEX IN THE NON-CANONICAL LIST II.GE.KK
C
      INDX = (IA(II) + KK -1)*NS2 + (JJ-1)*NSHELL + LL
C
C  LOOP THRU OPERATIONS IN THE GROUP AND MAP TO NEW PAIRS
C
      N = 1
      DO OP = 2, NT
C
C  MAP CENTERS
C
       II_NEW = MAPSHL(II,OP)
       JJ_NEW = MAPSHL(JJ,OP)
       KK_NEW = MAPSHL(KK,OP)
       LL_NEW = MAPSHL(LL,OP)
C
C  MAPPED 4-INDEX IN THE NON-CANONICAL LIST II.GE.KK
C
       IF (II_NEW.GE.KK_NEW) THEN
         INDX_NEW = (IA(II_NEW) + KK_NEW - 1)*NS2
     *              + (JJ_NEW - 1)*NSHELL + LL_NEW
       ELSE
         INDX_NEW = (IA(KK_NEW) + II_NEW - 1)*NS2
     *              + (LL_NEW - 1)*NSHELL + JJ_NEW
       END IF
C
C  COMPARE INDICES
C
       IF (INDX_NEW.GT.INDX) RETURN
       IF (INDX_NEW.EQ.INDX) N = N + 1
      END DO
      Q4 = NT
      Q4 = Q4/N
      IF (ABS(Q4-NINT(Q4)).GT. 0.1D-12) CALL ABRT
      END
C*MODULE MP2DDI  *DECK TRANO
      SUBROUTINE TRANO(GOUT,CMO,TRAN,CMOB,TRANB)
C
C -----------------------------------------------------------------
C  FIRST QUARTER TRANSFORMATION TO OCCUPIED MO INDICES - HONDO VERSION
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      LOGICAL OUTPUT,MP2ENG,UMP2GD
      DOUBLE PRECISION GOUT(*),CMO(NBF,NBF),TRAN(NBF,NOCC,MXSHL,MXSHL,2)
      DOUBLE PRECISION CMOB(NBF,NBF),TRANB(NBF,NOCCBLD,MXSHL,MXSHL,2)
      COMMON /SHLG70/ ISHELL,JSHELL,KSHELL,LSHELL,INEW,JNEW,KNEW,LNEW
      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 /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
C
      MINI = KMIN(ISHELL)
      MAXI = KMAX(ISHELL)
      MINJ = KMIN(JSHELL)
      MAXJ = KMAX(JSHELL)
      LOCJ = KLOC(JSHELL) - MINJ
      MINK = KMIN(KSHELL)
      MAXK = KMAX(KSHELL)
      MINL = KMIN(LSHELL)
      MAXL = KMAX(LSHELL)
      LOCL = KLOC(LSHELL) - MINL
      LEN1 = MXSHL**3
      LEN2 = MXSHL**2
      LEN3 = MXSHL
      IX  = 0
      DO I = MINI, MAXI
       IX  = IX + 1
       DO J = MINJ, MAXJ
        I2 = LOCJ + J
        IJP = LEN1*(I-MINI) + LEN2*(J-MINJ) + 1
        KX  = 0
        DO K = MINK, MAXK
         KX  = KX + 1
         DO L = MINL, MAXL
          I4 = LOCL + L
          KLP = LEN3*(K-MINK) + L-MINL
          VAL = GOUT( IJP + KLP )
          DO IOCC = 1, NOCC
            TRAN(I2,IOCC,IX,KX,1) = TRAN(I2,IOCC,IX,KX,1)
     *                            + VAL*CMO(I4,IOCC)
            TRAN(I4,IOCC,KX,IX,2) = TRAN(I4,IOCC,KX,IX,2)
     *                            + VAL*CMO(I2,IOCC)
          END DO
          IF(UMP2GD) THEN
            DO IOCC = 1, NOCCB
              TRANB(I2,IOCC,IX,KX,1) = TRANB(I2,IOCC,IX,KX,1)
     *                              + VAL*CMOB(I4,IOCC)
              TRANB(I4,IOCC,KX,IX,2) = TRANB(I4,IOCC,KX,IX,2)
     *                              + VAL*CMOB(I2,IOCC)
            END DO
          END IF
         END DO
        END DO
       END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK TRANO_P
      SUBROUTINE TRANO_P(GOUT,CMO,TRAN,CMOB,TRANB)
C
C -----------------------------------------------------------------
C  FIRST TRANSFORMATION - POPLE VERSION
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      DOUBLE PRECISION GOUT(*),CMO(NBF,NBF),TRAN(NBF,NOCC,MXSHL,MXSHL,2)
      DOUBLE PRECISION CMOB(NBF,NBF),TRANB(NBF,NOCCBLD,MXSHL,MXSHL,2)
      LOGICAL OUTPUT,MP2ENG,UMP2GD
      COMMON /SHLG70/ ISHELL,JSHELL,KSHELL,LSHELL,INEW,JNEW,KNEW,LNEW
      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 /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
      COMMON/FLIPS /IB1,JB1,KB1,LB1,IB2,JB2,KB2,LB2,IB3,JB3,KB3,LB3
      INTEGER IB(4,4)
      DATA IB/0,0,0,0,64,16,4,1,128,32,8,2,192,48,12,3/
C
      MINI = KMIN(ISHELL)
      MAXI = KMAX(ISHELL)
      MINJ = KMIN(JSHELL)
      MAXJ = KMAX(JSHELL)
      LOCJ = KLOC(JSHELL) - MINJ
      MINK = KMIN(KSHELL)
      MAXK = KMAX(KSHELL)
      MINL = KMIN(LSHELL)
      MAXL = KMAX(LSHELL)
      LOCL = KLOC(LSHELL) - MINL
      IX = 0
      DO I = MINI, MAXI
       IX = IX + 1
       DO J = MINJ, MAXJ
        I2 = LOCJ + J
        N1 = IB(IB1,I) + IB(JB1,J) + 1
        KX = 0
        DO K = MINK, MAXK
         KX = KX + 1
         DO L = MINL, MAXL
          I4 = LOCL + L
          NN = N1 + IB(KB1,K) + IB(LB1,L)
          VAL = GOUT(NN)
          DO IOCC = 1, NOCC
            TRAN(I2,IOCC,IX,KX,1) = TRAN(I2,IOCC,IX,KX,1)
     *                            + VAL*CMO(I4,IOCC)
            TRAN(I4,IOCC,KX,IX,2) = TRAN(I4,IOCC,KX,IX,2)
     *                            + VAL*CMO(I2,IOCC)
          END DO
          IF(UMP2GD) THEN
            DO IOCC = 1, NOCCB
              TRANB(I2,IOCC,IX,KX,1) = TRANB(I2,IOCC,IX,KX,1)
     *                              + VAL*CMOB(I4,IOCC)
              TRANB(I4,IOCC,KX,IX,2) = TRANB(I4,IOCC,KX,IX,2)
     *                              + VAL*CMOB(I2,IOCC)
            END DO
          END IF
         END DO
        END DO
       END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK SUMAO
      SUBROUTINE SUMAO(T2AO,TRAN,LAG,PAO,II,KK)
C
C -----------------------------------------------------------------
C  CONTRACT QUARTER-TRANSFORMED INTEGRALS WITH
C  HALF-TRANSFORMED AMPLITUDES AND BACK-TRANSFORMED P(2)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      PARAMETER (HALF=0.5D+00, ONE=1.0D+00, TWO=2.0D+00)
      LOGICAL OUTPUT,MP2ENG,UMP2GD
      DOUBLE PRECISION T2AO(NOCC,NOCC,*),TRAN(NBF,NOCC,MXSHL,MXSHL,2)
     *,      LAG(NBF,NOCC),PAO(NBF,NBF)
      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 /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
      IBEG = KLOC(II)
      IEND = IBEG + KMAX(II) - KMIN(II)
      KBEG = KLOC(KK)
      KEND = KBEG + KMAX(KK) - KMIN(KK)
      IX = 0
      KL = 0
      DO I = IBEG, IEND
        IX = IX + 1
        KX = 0
        DO K = KBEG, KEND
          KX = KX + 1
          KL = KL + 1
          IF (I.GE.K) THEN
            CALL DGEMM('N','N',NBF,NACT,NACT
     *,                ONE,TRAN(1,NCP1,IX,KX,1),NBF
     *,                T2AO(NCP1,NCP1,KL),NOCC
     *,                ONE,LAG(1,NCP1),NBF)
            DO LO = 1, NOCC
              DO J = 1, NBF
                LAG(K,LO) =LAG(K,LO) +TRAN(J,LO,IX,KX,1)*PAO(I,J)*TWO
                LAG(I,LO) =LAG(I,LO) -TRAN(J,LO,IX,KX,1)*PAO(K,J)*HALF
                LAG(J,LO) =LAG(J,LO) -TRAN(J,LO,IX,KX,1)*PAO(I,K)*HALF
              END DO
            END DO
            IF (I.NE.K) THEN
              CALL DGEMM('N','T',NBF,NACT,NACT
     *,                  ONE,TRAN(1,NCP1,KX,IX,2),NBF
     *,                  T2AO(NCP1,NCP1,KL),NOCC
     *,                  ONE,LAG(1,NCP1),NBF)
              DO LO = 1, NOCC
                DO J = 1, NBF
                  LAG(I,LO)=LAG(I,LO)+TRAN(J,LO,KX,IX,2)*PAO(K,J)*TWO
                  LAG(K,LO)=LAG(K,LO)-TRAN(J,LO,KX,IX,2)*PAO(I,J)*HALF
                  LAG(J,LO)=LAG(J,LO)-TRAN(J,LO,KX,IX,2)*PAO(K,I)*HALF
                END DO
              END DO
            END IF
          END IF
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK MKVOVO
      SUBROUTINE MKVOVO(TMP1,TMP2,CM1,EORB,CMO)
C
C -----------------------------------------------------------------
C  REVERSE THE PROCESS BY WHICH BACK-TRANSFORMED AMPLITUDES WERE
C  CONSTRUCTED FROM VOVO INTEGRALS IN BTAMPS
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      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
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      PARAMETER (    THIRD=0.3333333333333333D+00)
      PARAMETER (TWOTHIRDS=0.6666666666666667D+00)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,UMP2GD
      INTEGER A,B,AV,BV,AB,BA
      DOUBLE PRECISION TMP1(*),TMP2(*),CMO(NBF,*),CM1(NBF,*),EORB(*)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      IF (OUTPUT) THEN
        WRITE(ICHANL,1)
        CALL FLSHBF(ICHANL)
      END IF
C
C  FORM INVERSE MO COEFFICIENT MATRIX:
C
C  1) GET OVERLAP INTEGRALS
C
      CALL DAREAD(IDAF,IODA,TMP1,NBTR,12,0)
      CALL CPYTSQ(TMP1,TMP2,NBF,1)
C
C  2) COMPUTE C(-1) = C(T)*S
C
      CALL DGEMM('T','N',NVIR,NBF,NBF
     *,          ONE,CMO(1,NOP1),NBF
     *,          TMP2,NBF
     *,          ZERO,CM1,NVIR)
C
      CALL DDI_DISTRIB(D_VOVO,ME,IL_VOVO,IH_VOVO,JL_VOVO,JH_VOVO)
      IJ = 0
      DO I = 1, NOCC
        DO J = 1, I
          IJ = IJ + 1
          IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
            CALL DDI_GET(D_VOVO,1,NBSQ,IJ,IJ,TMP1)
C
C  MAP SHELL-BLOCKS BACK TO REGULAR AO-ORDER
C
            ICOUNT = 0
            DO ISHELL = 1, NSHELL
              IBEG = KLOC(ISHELL)
              IEND = IBEG + KMAX(ISHELL) - KMIN(ISHELL)
              DO JSHELL = 1, NSHELL
                JBEG = KLOC(JSHELL)
                JEND = JBEG + KMAX(JSHELL) - KMIN(JSHELL)
                DO IAO = IBEG, IEND
                  DO JAO = JBEG, JEND
                    IJAO = (IAO-1)*NBF + JAO
                    ICOUNT = ICOUNT + 1
                    TMP2(IJAO) = TMP1(ICOUNT)
                  END DO
                END DO
              END DO
            END DO
C
C  TRANSFORM AMPLITUDES TO MO BASIS
C
            CALL CACT(NVIR,NBF
     *,               TMP2,NBF,CM1,NVIR
     *,               TMP2,NVIR,TMP1)
C
C  CONVERT AMPLITUDES BACK TO REGULAR VOVO-CLASS INTEGRALS
C
            EIJ = EORB(I) + EORB(J)
            DO A = 1, NVIR
              AV = A + NOCC
              DO B = 1, A
                BV = B + NOCC
                AB = (B-1)*NVIR + A
                BA = (A-1)*NVIR + B
                DENOM = EIJ-EORB(AV)-EORB(BV)
                TMP1AB = TMP2(AB)*DENOM
                TMP1BA = TMP2(BA)*DENOM
                TMP1(AB) = TWOTHIRDS*TMP1AB + THIRD*TMP1BA
                TMP1(BA) = TWOTHIRDS*TMP1BA + THIRD*TMP1AB
              END DO
            END DO
            CALL DDI_PUT(D_VOVO,1,NVSQ,IJ,IJ,TMP1)
          END IF
        END DO
      END DO
      RETURN
1     FORMAT(6X,'RESTORING (VO|VO) INTEGRAL CLASS')
      END
C*MODULE MP2DDI  *DECK ZVECTR
      SUBROUTINE ZVECTR(EORB,RHS,U,UNXT,PRHS,B,CC,UU,UAU,BUF,BUF1,BUF2
     *,                 ALPHA,WK1,MOLABS,NSYM,NVSM,LVSM,MAXC,LEN,MXIRR
     *,                 BUF3,BUF4,BUF5,BUF6,EPS,H,CMO
     *,                 NDSM,LDSM,LOFF1,LOFF2)
C
C -----------------------------------------------------------------
C  SOLVE THE Z-VECTOR EQUATION FOR MP2/ZAPT
C      A*Z = L
C  BY ITERATIVE SOLUTION OF SIMULTANEOUS LINEAR EQUATIONS
C  (ZVECTR,HTPROD,LU,SMXPY,SXMPY,LUS,SYMVMO,SYMRL,SYMPOV)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00
     *,          SMAL=1.0D-13, TICH=1.0D-24)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,UMP2GD,ZAPTGD
      INTEGER MOLABS(*),NSYM(*),NVSM(*),LVSM(*),NDSM(*),LDSM(*)
      DOUBLE PRECISION EORB(*),RHS(*),U(*),UNXT(*),PRHS(*)
     *,      B(*),CC(*),UU(*),UAU(MAXC,*)
     *,      ALPHA(MAXC,*),WK1(*),BUF(*),BUF1(*),BUF2(*)
     *,      BUF3(*),BUF4(*),BUF5(*),BUF6(*),EPS(*),H(*),CMO(NBF,*)
C
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ZAPTGR/ NOCD,NOCD1,NOCS,NOCSTR,IXYEXC,ICHIX,ITIA,IZVEC
     *,               ZAPTGD
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      CALL DDI_DISTRIB(D_U,ME,IL_U,IH_U,JL_U,JH_U)
      UCONV = 10.0D+00**(-10)
      CALL DCOPY(LEN,ZERO,0,U,1)
      CALL DCOPY(LEN,ZERO,0,UNXT,1)
      CALL DCOPY(LEN,ZERO,0,PRHS,1)
      CALL DCOPY(MAXC,ZERO,0,B,1)
      CALL DCOPY(MAXC,ZERO,0,CC,1)
      CALL DCOPY(MAXC,ZERO,0,UU,1)
      CALL DCOPY(MAXC*MAXC,ZERO,0,UAU,1)
      IF (OUTPUT) THEN
        WRITE(ICHANL,20)
        CALL FLSHBF(ICHANL)
      END IF
C
C  FOR ZAPT, PREPARE ZETA AND EPSILON TERMS
C
      IF (ZAPTGD) CALL ZETAEPS(BUF1,BUF2,BUF3,BUF4,BUF5,BUF6,EPS,H,CMO)
C
C  GET ZEROTH-ORDER ESTIMATE
C
      IF (ZAPTGD) THEN
        CALL ZSYMEIG(MOLABS,EORB,EPS,BUF4,BUF5,RHS,U
     *,              NOCD,NOCD1,NOCC,NOP1,NMOS)
      ELSE
        CALL SYMEIG(MOLABS,EORB,RHS,U,NOCC,NOP1,NMOS)
      END IF
      DO I = 1, LEN
        IF (ABS(U(I)).LE.TICH) U(I) = ZERO
      END DO
      B(1) = DDOT(LEN,U,1,U,1)
      IF (1.GE.JL_U.AND.1.LE.JH_U)
     *  CALL DDI_PUT(D_U, 1, LEN, 1, 1, U)
C
C  START OF ITERATIVE PROCESS. 50 ITERATIONS ARE ALLOWED
C
      DO ITR = 1, MAXC
C
C  FORM PRODUCT OF HESSIAN*TRIAL-VECTOR
C
        CALL DCOPY(LEN,ZERO,0,UNXT,1)
        IF (ZAPTGD) THEN
          LDIM = MAX0(NVIR,NOCD)
          CALL ZHTPROD(U,UNXT,BUF,BUF1,BUF2,BUF3,BUF4,BUF5,BUF6,EPS
     *,                NSYM,NVSM,LVSM,MXIRR,NDSM,LDSM,LOFF1,LOFF2,LDIM)
        ELSE
          CALL HTPROD(U,UNXT,BUF,BUF1,BUF2,NSYM
     *,               NVSM,LVSM,MXIRR)
        END IF
        CALL DDI_GSUMF(101+ITR,UNXT,LEN)
        IF (ZAPTGD) THEN
          CALL ZSYMEIG(MOLABS,EORB,EPS,BUF4,BUF5,UNXT,UNXT
     *,                NOCD,NOCD1,NOCC,NOP1,NMOS)
        ELSE
          CALL SYMEIG(MOLABS,EORB,UNXT,UNXT,NOCC,NOP1,NMOS)
        END IF
C
C  FORM UAU LOWER TRIANGLE
C
        UU(ITR) = DDOT(LEN,U,1,U,1)
        DO I = 2, ITR - 1
          IF (I.GE.JL_U.AND.I.LE.JH_U) THEN
            ITMP=I
            CALL DDI_GET(D_U, 1, LEN, ITMP, ITMP, BUF)
            UAU(ITR,I-1) = DDOT(LEN,U,1,BUF,1)
          END IF
        END DO
        IF (ME.EQ.NPROC-1.AND.ITR.GT.1)
     *     UAU(ITR,ITR - 1) = UU(ITR)
        IF (ME.EQ.NPROC-1)
     *     UAU(ITR,ITR) = DDOT(LEN,U,1,UNXT,1)
        CALL DCOPY(ITR,UAU(ITR,1),MAXC,BUF,1)
        ITRTMP = ITR
        CALL DDI_GSUMF(202+ITRTMP,BUF,ITRTMP)
        CALL DCOPY(ITR,BUF,1,UAU(ITR,1),MAXC)
C
C  FORM UAU UPPER TRIANGLE
C
        DO I = 1, ITR - 1
          IF (I.GE.JL_U.AND.I.LE.JH_U) THEN
            ITMP=I
            CALL DDI_GET(D_U, 1, LEN, ITMP, ITMP, BUF)
            UAU(I,ITR) = DDOT(LEN,BUF,1,UNXT,1)
          END IF
        END DO
        IF(ITR.GT.1) THEN
           CALL DCOPY(ITR-1,UAU(1,ITR),1,BUF,1)
           CALL DDI_GSUMF(303+ITR,BUF,ITR-1)
           CALL DCOPY(ITR-1,BUF,1,UAU(1,ITR),1)
        END IF
C
C  NAG-LIKE ROUTINES FOR SMALL SET OF SIMULTANEOUS EQUATIONS
C
        DO I = 1, ITR
          DO J = 1, ITR
            ALPHA(J,I) = UAU(J,I)
          END DO
        END DO
        DO I = 1, ITR
          ALPHA(I,I) = ALPHA(I,I) + UU(I)
        END DO
        CALL  LU(ALPHA,MAXC,ITR,WK1)
        CALL LUS(ALPHA,MAXC,ITR,WK1,CC,B)
C
C  FORM NEW SOLUTION VECTOR
C
        CALL DCOPY(LEN,RHS,1,PRHS,1)
        CALL DCOPY(LEN,ZERO,0,RHS,1)
        DO I = 1, ITR
          CCJN = CC(I)
          IF (ABS(CCJN).GT.TICH) THEN
            IF (I.GE.JL_U.AND.I.LE.JH_U) THEN
              ITMP=I
              CALL DDI_GET(D_U, 1, LEN, ITMP, ITMP, BUF)
              CALL DAXPY(LEN,CCJN,BUF,1,RHS,1)
            END IF
          END IF
        END DO
        CALL DDI_GSUMF(404+ITR,RHS,LEN)
C
C  CHECK FOR CONVERGENCE OF SOLUTION VECTORS
C
        IF (ITR.NE.1) THEN
          CALL DAXPY(LEN,-ONE,RHS,1,PRHS,1)
          GNORM = DDOT(LEN,PRHS,1,PRHS,1)/(NOCC*NVIR)
          GNORM = SQRT(GNORM)
          GMAX = MAX(ZERO,GNORM)
          IF (OUTPUT) THEN
            WRITE(ICHANL,30) ITR,GMAX
            CALL FLSHBF(ICHANL)
          END IF
          IF (GMAX.LE.UCONV) THEN
            IF (OUTPUT) THEN
              WRITE(ICHANL,50)
              CALL FLSHBF(ICHANL)
            END IF
            GO TO 3
          END IF
        END IF
C
C  UPDATE NEXT EXPANSION VECTOR
C
        CALL DCOPY(LEN,ZERO,0,PRHS,1)
        DO I = 1, ITR
          IF (I.GE.JL_U.AND.I.LE.JH_U) THEN
            FAC = -UAU(I,ITR)/UU(I)
            ITMP=I
            CALL DDI_GET(D_U, 1, LEN, ITMP, ITMP, BUF)
            CALL DAXPY(LEN,FAC,BUF,1,PRHS,1)
          END IF
        END DO
        CALL DDI_GSUMF(505+ITR,PRHS,LEN)
        CALL DAXPY(LEN,ONE,PRHS,1,UNXT,1)
        DO I = 1, LEN
          IF (ABS(UNXT(I)).LE.TICH) UNXT(I) = ZERO
        END DO
C
C  CHECK FOR CONVERGENCE OF NEXT EXPANSION VECTOR
C
        GNORM = DDOT(LEN,UNXT,1,UNXT,1)/(NOCC*NVIR)
        GNORM = SQRT(GNORM)
        GMAX = MAX(ZERO,GNORM)
        IF (OUTPUT) THEN
          WRITE(ICHANL,40) GMAX
          CALL FLSHBF(ICHANL)
        END IF
        IF (GMAX.LE.SMAL) THEN
          IF (OUTPUT) THEN
            WRITE(ICHANL,70)
            CALL FLSHBF(ICHANL)
          END IF
          GO TO 3
        END IF
C
C  SAVE NEW EXPANSION VECTOR IN GLOBAL ARRAY
C
        NXTR = ITR + 1
        IF (NXTR.GE.JL_U.AND.NXTR.LE.JH_U)
     *     CALL DDI_PUT(D_U, 1, LEN, NXTR, NXTR, UNXT)
        CALL DCOPY(LEN,UNXT,1,U,1)
C
C  END OF LOOP
C
      END DO
      IF (OUTPUT) THEN
        WRITE(ICHANL,80) MAXC
        CALL FLSHBF(ICHANL)
      END IF
      CALL ABRT
 3    CONTINUE
      RETURN
20    FORMAT(/,6X,'ITERATION',9X,'TESTER',2X
     *,      'EXPANSION VECTOR NORM',/,6X,47('=')/)
30    FORMAT(I10,5X,F15.10)
40    FORMAT(30X,F20.15)
50    FORMAT(/,6X,'CONVERGED - WAVEFUNCTIONS STATIONARY',/)
70    FORMAT(/,6X,'CONVERGED - NEW EXPANSION VECTOR NEGLIGIBLE',/)
80    FORMAT(/,6X,'!NO FULL CONVERGENCE AFTER',I4,' ITERATIONS!',
     *       /,/,1X,'PLEASE RECONSIDER:'/
     *       6X,'IF THE SCF HAS CONVERGED TO THE RIGHT ORBITAL',
     *          ' OCCUPANCY OR NOT'/
     *       6X,'IF THIS CHEMICAL SYSTEM IS A SINGLE',
     *          ' REFERENCE WAVEFUNCTION OR NOT'/
     *       1X,'IF YOU BELIEVE THIS WAVEFUNCTION IS',
     *          ' CORRECT AND CONVERGING,'/
     *       1X,'CONSIDER INCREASING MAXITC IN $MP2.')
      END
C*MODULE MP2DDI  *DECK HTPROD
      SUBROUTINE HTPROD(V1,V2,BUF,BUF1,BUF2
     *,                 NOSYM,NVCLASS,LVCLASS,MXIRR)
C
C -----------------------------------------------------------------
C  PARALLEL ORBITAL-HESSIAN*TRIAL-VECTOR PRODUCT
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (ONE=1.0D+00, FOUR=4.0D+00)
      LOGICAL GOPARR,DSKWRK,MASWRK,OUTPUT,MP2ENG,UMP2GD
      INTEGER A,B,AB,NOSYM(*),NVCLASS(*),LVCLASS(MXIRR,*)
      DOUBLE PRECISION V1(*),V2(*),BUF(NVIR,*),BUF1(NVIR,*),BUF2(*)
C
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      CALL DDI_DISTRIB(D_VOVO,ME,IL_VOVO,IH_VOVO,JL_VOVO,JH_VOVO)
      IJ  = 0
      DO I = 1, NOCC
        ISYM = NOSYM(I)                  !  IRREP IDENTIFIER
        NVI = NVCLASS(ISYM)              !  NO. VIRT. IN CLASS
        IOFF = 1
        DO IOCC = 1, I-1                     !
          IOCLASS = NOSYM(IOCC)               ! OFF-SET OF
          IOFF = IOFF + NVCLASS(IOCLASS)      !  VIRT. BLOCK
        END DO                                !
        DO J = 1, I
          JSYM = NOSYM(J)
          NVJ = NVCLASS(JSYM)
          JOFF = 1
          DO JOCC = 1, J-1
            JOCLASS = NOSYM(JOCC)
            JOFF = JOFF + NVCLASS(JOCLASS)
          END DO
C
C  GET VOVO AND VVOO INTEGRALS
C
          IJ = IJ + 1
          IF (IJ.GE.JL_VOVO.AND.IJ.LE.JH_VOVO) THEN
            CALL DDI_GET(D_VOVO,1,NVSQ,IJ,IJ,BUF1)
            CALL DDI_GET(D_VVOO,1,NVTR,IJ,IJ,BUF2)
C
C  GENERATE BLOCK OF REDUCED ORBITAL-HESSIAN
C
            DO IVCLASS = 1, NVI              !  LOOP OVER
              A = LVCLASS(ISYM,IVCLASS)       !  VIRTUAL
              DO JVCLASS = 1, NVJ            !  INDICES OF
                B = LVCLASS(JSYM,JVCLASS)     !  EACH IRREP
                IF (A.GE.B) THEN
                  AB = (A*A-A)/2 + B
                ELSE
                  AB = (B*B-B)/2 + A
                END IF
                X = BUF1(A,B)
                Y = BUF1(B,A)
                Z = BUF2(AB)
                BUF(JVCLASS,IVCLASS) = FOUR*X-Y-Z
              END DO
            END DO
C
C  THE HESSIAN-VECTOR PRODUCT
C
            CALL DGEMM('T','N', NVI,1,NVJ
     *,                ONE,BUF,NVIR
     *,                V1(JOFF),NVIR
     *,                ONE,V2(IOFF),NVIR)
            IF (I.NE.J)
     *      CALL DGEMM('N','N', NVJ,1,NVI
     *,                ONE,BUF,NVIR
     *,                V1(IOFF),NVIR
     *,                ONE,V2(JOFF),NVIR)
          END IF
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK LU
      SUBROUTINE LU(A,LDA,N,IPVT)
C
C -----------------------------------------------------------------
C  LU DECOMPOSITION OF A
C
C  BASED ON THE NAG ROUTINE F04ATF, THE ARGUMENTS ARE THE SAME BUT IT
C  IS A (HOPEFULLY) LESS MACHINE DEPENDENT VERSION BASED ON THE VECTOR
C  ALGORITHM OF DONGARRA USING LU DECOMPOSITION SEE ACM TRANSACTIONS
C  OF MATHEMATICAL SOFTWARE VOL 10 SEPT 1984
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER ( ZERO = 0.0D+00 )
      DIMENSION A(LDA,*),IPVT(*)
C
      DO J = 1, N
        CALL SMXPY(N-J+1,A(J,J),J-1,LDA,A(1,J),A(J,1))
C
C  FIND PIVOT
C
        T = ZERO
        DO I = J, N
          IF(ABS(A(I,J)).GT.T)THEN
            T = ABS(A(I,J))
            K = I
          ENDIF
        END DO
        IPVT(J) = K
        IF (T.EQ.ZERO) THEN
          WRITE(6,*) 'LU: SINGULAR MATRIX!!'
          CALL ABRT
        END IF
C
C  SWOP ROWS
C
        DO I = 1, N
          T = A(J,I)
          A(J,I) = A(K,I)
          A(K,I) = T
        END DO
        A(J,J) = 1.0D+00/A(J,J)
        CALL SXMPY(N-J,LDA,A(J,J+1),J-1,LDA,A(J,1),LDA,A(1,J+1))
        T = -A(J,J)
        DO I = J + 1, N
          A(J,I) = T*A(J,I)
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK SMXPY
      SUBROUTINE SMXPY(N1,Y,N2,LDA,X,A)
C
C -----------------------------------------------------------------
C  Y = Y + AX
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(*),X(*),A(LDA,*)
C
      J = MOD(N2,2)
      IF (J.GE.1) THEN
        DO I = 1, N1
          Y(I)= Y(I) + X(J)*A(I,J)
        END DO
      END IF
      J = MOD(N2,4)
      IF (J.GE.2) THEN
        DO I = 1, N1
          Y(I)=(Y(I) + X(J-1)*A(I,J-1)) + X(J)*A(I,J)
        END DO
      END IF
      JMIN = J + 4
      DO J = JMIN, N2, 4
        DO I = 1, N1
          Y(I)=(((Y(I) + X(J-3)*A(I,J-3)) + X(J-2)*A(I,J-2))
     *                 + X(J-1)*A(I,J-1)) + X(J)*A(I,J)
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK SXMPY
      SUBROUTINE SXMPY(N1,LDY,Y,N2,LDX,X,LDA,A)
C
C -----------------------------------------------------------------
C  Y = Y + AX
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(LDY,*),X(LDX,*),A(LDA,*)
C
      J = MOD(N2,2)
      IF (J.GE.1) THEN
        DO I = 1, N1
          Y(1,I)= Y(1,I) + X(1,J)*A(J,I)
        END DO
      END IF
      J = MOD(N2,4)
      IF (J.GE.2) THEN
        DO I = 1, N1
          Y(1,I)=(Y(1,I) + X(1,J-1)*A(J-1,I)) + X(1,J)*A(J,I)
        END DO
      END IF
      JMIN = J + 4
      DO J = JMIN, N2, 4
        DO I = 1, N1
          Y(1,I)=(((Y(1,I) + X(1,J-3)*A(J-3,I)) + X(1,J-2)*A(J-2,I))
     *                     + X(1,J-1)*A(J-1,I)) + X(1,J)*A(J,I)
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK LUS
      SUBROUTINE LUS(A,LDA,N,IPVT,X,B)
C
C -----------------------------------------------------------------
C  SIMULTANEOUS EQUATION AX=B GIVEN PRIOR LU DECOMPOSITION OF A
C  TAKEN FROM DONGARRA ACM TRANS MATH SOFTWARE VOL 10
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER ( ZERO = 0.0D+00 )
      DIMENSION A(LDA,*),X(*),B(*),IPVT(*)
C
      DO K = 1, N
        X(K) = B(K)
      END DO
      DO K = 1, N
        L = IPVT(K)
        XK = X(L)
        X(L) = X(K)
        X(K) = XK
      END DO
      DO K = 1, N
        XK = X(K)*A(K,K)
        IF (XK.NE.ZERO) THEN
          DO I = K + 1, N
            X(I) = X(I) - A(I,K)*XK
          END DO
        ENDIF
        X(K) = XK
      END DO
      DO K = N, 1, -1
        XK=X(K)
        IF (XK.NE.ZERO) THEN
          DO I = 1, K - 1
            X(I) = X(I) + A(I,K)*XK
          END DO
        ENDIF
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK SYMVMO
      SUBROUTINE SYMVMO(MOLABS,MLIST,NOSYM,NVCLASS,LVCLASS,MXIRR
     *,                 NOCCX,NOP1X,NMOSX,NDCLASS,LDCLASS,NOCD,LZAPT)
C
C -----------------------------------------------------------------
C  GROUP THE VIRTUAL MOS ACCORDING TO THEIR SYMMETRY FOR USE IN
C  CONSTRUCTING BLOCKS OF THE REDUCED ORBITAL HESSIAN.
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL MATCH,LZAPT
      INTEGER MXIRR
     *,       NOSYM(*)
     *,       NVCLASS(*)
     *,       LVCLASS(MXIRR,*)
     *,       MOLABS(*)
     *,       MLIST(*)
     *,       NDCLASS(*)
     *,       LDCLASS(MXIRR,*)
C
C  RE-ENUMERATE MO IRREPS
C
      ISYM = 1
      NOSYM(1) = ISYM
      MLIST(1) = MOLABS(1)
      DO IORB = 2, NMOSX
        MATCH = .FALSE.
        DO JSYM = 1, ISYM
          IF(MOLABS(IORB).EQ.MLIST(JSYM)) THEN
            NOSYM(IORB) = JSYM
            MATCH = .TRUE.
          END IF
        END DO
        IF (.NOT.MATCH) THEN
          ISYM = ISYM + 1
          MLIST(ISYM) = MOLABS(IORB)
          NOSYM(IORB) = ISYM
        END IF
      END DO
C
C  LIST VIRTUAL MO OF EACH IRREP
C
      DO JSYM = 1, ISYM
        IC = 0
        DO IORB = NOP1X, NMOSX
          IF (NOSYM(IORB).EQ.JSYM) THEN
            IC = IC + 1
            LVCLASS(JSYM,IC) = IORB - NOCCX
          END IF
        END DO
        NVCLASS(JSYM) = IC
      END DO
C
C  FOR ZAPT GRADIENTS, LIST DOCC MO OF EACH IRREP
C
      IF (LZAPT) THEN
        DO JSYM = 1, ISYM
          IC = 0
          DO IORB = 1, NOCD
            IF (NOSYM(IORB).EQ.JSYM) THEN
              IC = IC + 1
              LDCLASS(JSYM,IC) = IORB
            END IF
          END DO
          NDCLASS(JSYM) = IC
        END DO
      END IF
      RETURN
      END
C*MODULE MP2DDI  *DECK SYMRL
      SUBROUTINE SYMRL(MOLABS,LAG,REDLAG,LENRL,NOCCX,NOP1X,NMOSX)
C
C -----------------------------------------------------------------
C  FORM REDUCED LAGRANGIAN
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION LAG(*),REDLAG(*)
      INTEGER MOLABS(*),A
C
      IA = 0
      LENRL = 0
      DO I = 1, NOCCX
        DO A = NOP1X, NMOSX
          IA = IA + 1
          IF (MOLABS(I).EQ.MOLABS(A)) THEN
            LENRL = LENRL + 1
            REDLAG(LENRL) = LAG(IA)
          END IF
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK SYMEIG
      SUBROUTINE SYMEIG(MOLABS,EORB,A,B,NOCCX,NOP1X,NMOSX)
C
C -----------------------------------------------------------------
C  EIGENVALUE-TERM OF THE (ORBITAL-HESSIAN)*(TRIAL-VECTOR) PRODUCT
C  SEPARATE ROUTINE FOR INDEXING THE MOS WITHIN AN IRREP
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER C, MOLABS(*)
      DOUBLE PRECISION EORB(*), A(*), B(*)
C
      IC = 0
      DO I = 1, NOCCX
        DO C = NOP1X, NMOSX
          IF (MOLABS(I).EQ.MOLABS(C)) THEN
            IC = IC + 1
            B(IC) = A(IC)/(EORB(C) - EORB(I))
          END IF
        END DO
      END DO
      RETURN
      END
C*MODULE MP2DDI  *DECK SYMPOV
      SUBROUTINE SYMPOV(MOLABS,SOL,REDSOL,LENRL,NOCCX,NOP1X,NMOSX)
C
C -----------------------------------------------------------------
C  COPY REDUCED SOLUTION VECTOR BACK TO FULL P(OV) BLOCK
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL OUTPUT,MP2ENG,UMP2GD
      INTEGER MOLABS(*), A
      DOUBLE PRECISION SOL(*),REDSOL(*)
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
      IA = 0
      IC = 0
      DO I = 1, NOCCX
        DO A = NOP1X, NMOSX
          IA = IA + 1
          IF (MOLABS(I).EQ.MOLABS(A)) THEN
            IC = IC + 1
            SOL(IA) = REDSOL(IC)
          ELSE
            SOL(IA) = 0.0D+00
          END IF
        END DO
      END DO
      IF (IC.NE.LENRL) THEN
        WRITE(ICHANL,1)
        CALL ABRT
      END IF
      RETURN
1     FORMAT(/,'SYMPOV: WRONG LENGTH FOR REDUCED LAGRANGIAN',/)
      END
C*MODULE MP2DDI  *DECK PJKDMP2
      SUBROUTINE PJKDMP2
C
C -----------------------------------------------------------------
C  PARALLEL DISTRIBUTED DATA BACK-TRANSFORMATION FORMING THE
C  NON-SEPARABLE TERM OF THE 2-PARTICLE DENSITY AND ITS CONTRACTION
C  WITH THE DERIVATIVE ELECTRON REPULSION INTEGRALS
C  (PJKDMP2,BTRAN2,PAR2PDM)
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXGTOT=20000, MXSH=5000, MXATM=2000, MXAO=8192)
      LOGICAL POPLE,MP2,HONDO,PACK2E,OUT,DBG_OTHER
     *,       GOPARR,DSKWRK,MASWRK
     *,       OUTPUT,MP2ENG,ABELPT,DLB,DOTASK,NOCORE,UMP2GD,ZAPTGD
      INTEGER IPERM(4), INVPERM(4)
C
      COMMON /DERMEM/ IWFN,IXCH,INIJG,IGINT,IFINT,ISINT,IIJKLG,IDAB,
     *                ICHRG,IXY,IXZ,IYZ,IX,IY,IZ,ISJ,ISK,ISL,IGIJKL,
     *                IGNKL,IGNM,IDIJ,IDKL,IB00,IB01,IB10,IC00,ID00,
     *                IF00,IAAI,IAAJ,IBBK,IBBL,IFI,IFJ,IFK,IFL,ISII,
     *                ISJJ,ISKK,ISLL,ISIJ,ISIK,ISIL,ISJK,ISJL,ISKL,
     *                IDIJSI,IDIJSJ,IDKLSK,IDKLSL,IABV,ICV,IRW
      COMMON /DLT   / LAT,LBT,LCT,LDT
      COMMON /DSHLNO/ LIT,LJT,LKT,LLT,LOCI,LOCJ,LOCK,LOCL,
     *                MINI,MINJ,MINK,MINL,MAXI,MAXJ,MAXK,MAXL,
     *                NIJ,IJD,KLD,IJ,KL
      COMMON /DSHLT / RTOL,DTOL,VTOL1,VTOL2,VTOLS,OUT,DBG_OTHER
      COMMON /FMCOM / X(1)
      COMMON /GRAD  / DE(3,MXATM)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INDD80/ IMAX,JMAX,KKKMAX,LMAX
      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,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PTR/ IWMAT,IPMAT,IVECS,IPSCF,IVALS,ILABS,ISCHW,INEED
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /UMPPTR/ IWMATB,IPMATB,IVECSB,IPSCFB,IVALSB,ILABSB
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
      COMMON /ZAPTGR/ NOCD,NOCD1,NOCS,NOCSTR,IXYEXC,ICHIX,ITIA,IZVEC
     *,               ZAPTGD
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
      PARAMETER (RLN10=2.30258D+00, ZERO=0.0D+00)
      PARAMETER (TEN=10.0D+00, ONE=1.0D+00, HALF=0.5D+00)
      PARAMETER (TENM9=1.0D-09, TENM11=1.0D-11)
      PARAMETER (TENM20=1.0D-20, TENM12=1.0D-12)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48)
     *,               TSYM(432),INVT(48),NT
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA CHECK   /8HCHECK   /
C
      IF (OUTPUT) THEN
        WRITE(ICHANL,1)
        CALL FLSHBF(ICHANL)
      END IF
      IF ( EXETYP .EQ. CHECK ) RETURN
C
C  IN CASE OF NON-ABELIAN POINT GROUPS...
C
      NTSAVE = NT
      IF (.NOT.ABELPT()) NT = 1
C
C  INITIALIZE PARAMETERS
C
      MP2     = .TRUE.
      HONDO   = .TRUE.
      POPLE   = .TRUE.
      IF (IGRDTYP.EQ.2)         POPLE = .FALSE.
      IF (POPLE.AND.MXSHL.LT.5) HONDO = .FALSE.
C
C      CUTOFF IS THE SCHWARZ SCREENING CUT OFF
C      DABCUT IS THE TWO PARTICLE DENSITY CUT OFF
C
      CUTOFF=TENM9
      IF(.NOT.POPLE) CUTOFF=CUTOFF/TEN
      CUTOFF2=CUTOFF/2.0D+00
C
      ZBIG = 0.0D+00
      DO ISH=1,NSHELL
         I1=KSTART(ISH)
         I2=I1+KNG(ISH)-1
         DO IG=I1,I2
            IF(EX(IG).GT.ZBIG) ZBIG = EX(IG)
         ENDDO
      ENDDO
      DABCUT  = TENM11
      IF(ZBIG.GT.1.0D+06) DABCUT = DABCUT/TEN
      IF(ZBIG.GT.1.0D+07) DABCUT = DABCUT/TEN
C
      IISKIP1 = 0
      IISKIP2 = 0
      IDID    = 0
C
      Q4     = ONE
      VTOL1  = TENM12             !\
      VTOL2  = TENM12             ! > USED BY POPLE CODE
      VTOLS  = TENM20             !/
      DTOL   = TEN**(-ITOL)
      DTOL   = DTOL*DTOL
      RTOL   = RLN10*ITOL
      LENGTH = 1
      NC     = 1
      LDF    = 1
      LOCTSK = 0
C
C  DYNAMIC LOAD BALANCING
C
      DLB = IBTYP.EQ.1
      IF (DLB) THEN
        CALL DDI_DLBRESET()
        CALL DDI_DLBNEXT( MYTASK )
      END IF
C
C  SET UP MEMORY POINTERS FOR DERIVATIVE INTEGRALS
C
      CALL VALFM(LOADFM)
      CALL JKDMEM(1,LOADFM,IADDR,LENGTH,
     *            MINXYZ,MAXXYZ,MINVEC,POPLE,MP2)
      NEED = IADDR - LOADFM
      CALL GETFM(NEED)
C
C  PRE-COMPUTE FACTORS FOR INTEGRAL EVALUATION
C
      IF(HONDO) CALL OEDHND(X(INIJG),X(ICHRG))
C
C  FIRST HALF-BACK-TRANSFORMATION OF AMPLITUDES
C
      CALL VALFM(LOADFM)
      ITMP1 = 1     + LOADFM
      ITMP2 = ITMP1 + NBSQ
      LAST  = ITMP2 + NBSQ
      IF (ZAPTGD) THEN
        ITRG  = NOTR - (NOCD*NOCD+NOCD)/2
        ITMP3 = LAST
        ITMP4 = ITMP3 + MAX0(NVIR*NOCS,ITRG)
        ITMP5 = ITMP4 + MAX0(NVIR*NOCS,ITRG)
        LAST  = ITMP5 + NOCS*NOCS
      END IF
      NEED1 = LAST  - LOADFM
      CALL GETFM(NEED1)
C
C  ACTIVE MO INDICES NEEDED FOR NON-SEP 2PD TERM
C
      NOCORE = .TRUE.
      IF(UMP2GD) THEN
        CALL BTAMPSAA(X(IVALS),X(IVECS),X(ITMP1),X(ITMP2),NOCORE)
        CALL BTAMPSBB(X(IVALSB),X(IVECSB),X(ITMP1),X(ITMP2),NOCORE)
        CALL BTAMPSAB(X(IVALS),X(IVALSB),X(IVECS),X(IVECSB)
     *,               X(ITMP1),X(ITMP2),NOCORE)
      ELSE IF (ZAPTGD) THEN
        CALL BTAMPSZ(X(IVALS),X(IVECS),X(IXYEXC),X(ITMP1),X(ITMP2)
     *,              X(ITMP3),X(ITMP4),X(ITMP5))
      ELSE
        CALL BTAMPS(X(IVALS),X(IVECS),X(ITMP1),X(ITMP2),NOCORE)
      END IF
      CALL RETFM(NEED1)
C
C  FINALLY GET TO DESTROY OOOO AND VOOO ARRAYS FOR ZAPT
C
      IF(ZAPTGD) THEN
        CALL DDI_DESTROY( D_OOOO   )
        CALL DDI_DESTROY( D_VOOO   )
      END IF
C
C  ALLOCATE WORKSPACE FOR 2ND BACK-TRANSFORMATION
C
      CALL VALFM(LOADFM)
      IF(UMP2GD) THEN
        IBT_AA   = 1        + LOADFM
        IBT_BB   = IBT_AA   + MXSHL*MXSHL*NOSQ
        IBT_AB   = IBT_BB   + MXSHL*MXSHL*NOSB
        IBT_BA   = IBT_AB   + MXSHL*MXSHL*NOCC*NOCCB
        I2PDM_NS = IBT_BA   + MXSHL*MXSHL*NOCC*NOCCB
        IDUM     = I2PDM_NS + MXSHL*MXSHL*MXSHL*NBF
        IDUM2    = IDUM     + MXSHL*MXSHL*MAX0(NOTR,NOTB)
        IDAB     = IDUM2    + MXSHL*MXSHL*MAX0(NOTR,NOTB)
        I1PG     = IDAB     + MXSHL**4
        ITMP     = I1PG     + NAT*3
        LAST     = ITMP     + NAT*3
        NEED2    = LAST     - LOADFM
      ELSE
        IBT_AMPS = 1        + LOADFM
        I2PDM_NS = IBT_AMPS + MXSHL*MXSHL*NOSQ
        IDUM     = I2PDM_NS + MXSHL*MXSHL*MXSHL*NBF
        IDAB     = IDUM     + MXSHL*MXSHL*NOTR
        I1PG     = IDAB     + MXSHL**4
        ITMP     = I1PG     + NAT*3
        LAST     = ITMP     + NAT*3
        NEED2    = LAST     - LOADFM
      END IF
      CALL GETFM(NEED2)
C
C  MAKE BACK-TRANSFORMED Z-VECTOR, CHI, P', ETC. FOR ZAPT2 SEP 2PD
C
      IF(ZAPTGD) THEN
        CALL VALFM(LOADFM)
        ICHIMUNU  = LOADFM    + 1
        IZMN      = ICHIMUNU  + NBTR
        ITMUNU4   = IZMN      + NBTR
        IPMUNUS   = ITMUNU4   + NBTR
        LAST      = IPMUNUS   + NBTR
        NEED3     = LAST      - LOADFM
        CALL GETFM(NEED3)
        CALL VALFM(LOADFM)
        IDUMSQ    = LOADFM  + 1
        IDUMSQ2   = IDUMSQ  + NBSQ
        LAST      = IDUMSQ2 + NBSQ
        NEED4     = LAST   - LOADFM
        CALL GETFM(NEED4)
        CALL ZPRIM(X(IVECS),X(IPMUNUS),X(ICHIX),X(ICHIMUNU),X(IZMN)
     *,            X(ITMUNU4),X(ITIA),X(IZVEC),X(IDUMSQ),X(IDUMSQ2))
        CALL RETFM(NEED4)
      END IF
C
C  SAVE 1-PARTICLE GRADIENT IN TEMPORARY BUFFER
C  AND ZERO DE
C
      CALL DCOPY(NAT*3,DE,1,X(I1PG),1)
      CALL DCOPY(NAT*3,ZERO,0,DE,1)
C
C  NON-CANONICAL SHELL LIST FOLLOWS
C
C
C  I-SHELL
C
      DO II = 1, NSHELL
       NMINI = KLOC(II)
       NMAXI = KLOC(II) + KMAX(II) - KMIN(II)
       ISHL  = KMAX(II) - KMIN(II) + 1
C
C  K-SHELL
C
       DO KK = 1, II
         NMINK = KLOC(KK)
         NMAXK = KLOC(KK) + KMAX(KK) - KMIN(KK)
         KSHL  = KMAX(KK) - KMIN(KK) + 1
C
C  POINT GROUP SYMMETRY
C
         CALL SYMIJ(II,KK,Q2)
         IF ( Q2 .GT. ZERO ) THEN
C
C  LOAD BALANCER
C
        IF (DLB) THEN
          DOTASK = LOCTSK.EQ.MYTASK
        ELSE
          DOTASK = MOD(LOCTSK,NPROC).EQ.ME
        END IF
        IF (DOTASK) THEN
C
C  GET HALF-BACK-TRANSFORMED AMPLITUDES, A(NU,I|LAMDA,J)
C
          IF(UMP2GD) THEN
            CALL GETAMPSA(X(IBT_AA),X(IDUM),X(IDUM2),II,KK)
            CALL GETAMPSB(X(IBT_BB),X(IDUM),X(IDUM2),II,KK)
            CALL GETAMPSM(X(IBT_AB),X(IBT_BA),X(IDUM),II,KK)
          ELSE
            CALL GETAMPS(X(IBT_AMPS),X(IDUM),II,KK)
          END IF
C
C  J-SHELL
C
          DO JJ = 1, NSHELL
           NMINJ = KLOC(JJ)
           JSHL  = KMAX(JJ) - KMIN(JJ) + 1
C
C  SECOND HALF-BACK-TRANSFORMATION OF AMPLITUDES
C   FOR I-, J- AND K-SHELL INDICES
C   ALLOWING THE 4TH INDEX TO SPAN ALL AO LABELS
C
           IF(UMP2GD) THEN
             IBTAA = IBT_AA
             IBTBB = IBT_BB
             IBTAB = IBT_AB
             IBTBA = IBT_BA
             INSD = I2PDM_NS
             DO NU = NMINI, NMAXI
              DO LAMDA = NMINK, NMAXK
               CALL UBTRAN2(X(IVECS),X(IVECSB),X(IBTAA),X(IBTBB)
     *,                    X(IBTAB),X(IBTBA),X(INSD),NMINJ,JSHL,X(IDUM))
               IBTAA = IBTAA + NOSQ
               IBTBB = IBTBB + NOSB
               IBTAB = IBTAB + NOCC*NOCCB
               IBTBA = IBTBA + NOCCB*NOCC
               INSD  = INSD + NBF*JSHL
              END DO
             END DO
           ELSE
             IBTA = IBT_AMPS
             INSD = I2PDM_NS
             DO NU = NMINI, NMAXI
              DO LAMDA = NMINK, NMAXK
               CALL BTRAN2(X(IVECS), X(IBTA)
     *,                    X(INSD),NMINJ,JSHL,X(IDUM))
               IBTA = IBTA + NOSQ
               INSD = INSD + NBF*JSHL
              END DO
             END DO
           END IF
C
C  USE OFF-SET TO SIMPLIFY INDEXING OF THE NON-SEPARABLE TERMS
C  IN THE INNERMOST LOOP
C
           INSD = I2PDM_NS
C
C  L-SHELL
C
           DO LL = 1, NSHELL
            LSHL  = KMAX(LL) - KMIN(LL) + 1
            ISH = II
            JSH = JJ
            KSH = KK
            LSH = LL
C
C  SINGLE-CENTRE NUCLEAR GRADIENTS ARE NULL
C
            IF (.NOT.(
     *           KATOM(JSH).EQ.KATOM(ISH).AND.
     *           KATOM(KSH).EQ.KATOM(ISH).AND.
     *           KATOM(LSH).EQ.KATOM(ISH)
     *         )) THEN
C
C  POINT GROUP SYMMETRY USE IN NON-CANONICAL LIST
C
            CALL SYMIKJL(ISH,JSH,KSH,LSH,Q4,NSHELL)
            IF ( Q4 .GT. ZERO ) THEN
             IIJJ=IA(MAX0(ISH,JSH))+MIN0(ISH,JSH)
             KKLL=IA(MAX0(KSH,LSH))+MIN0(KSH,LSH)
C
C  SCHWARZ INEQUALITY TEST
C
             GMAX = Q4*X(ISCHW+IIJJ-1)
     *                *X(ISCHW+KKLL-1)
C
C                COARSE SCREENING, ON JUST THE INTEGRAL VALUE
C
             IF (GMAX.LT.CUTOFF) THEN
                IISKIP1 = IISKIP1 + 1
                GO TO 100
             ENDIF
C
C  USE POPLE CODE FOR ANY PURE SP INTEGRAL BLOCKS,
C  USE HONDO RYS POLYNOMIAL CODE FOR OTHER BLOCKS
C
             POPLE = .TRUE.
             IF(IGRDTYP.EQ.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
C  ENSURE SHELL LABELS ARE IN CANONICAL ORDER
C
             INEW = ISH
             JNEW = JSH
             KNEW = KSH
             LNEW = LSH
             IPERM(1) = 1
             IPERM(2) = 2
             IPERM(3) = 3
             IPERM(4) = 4
             IF (INEW.LT.JNEW) THEN
               ITMP = INEW
               INEW = JNEW
               JNEW = ITMP
               ITMP = IPERM(1)
               IPERM(1) = IPERM(2)
               IPERM(2) = ITMP
             END IF
             IF (KNEW.LT.LNEW) THEN
               ITMP = KNEW
               KNEW = LNEW
               LNEW = ITMP
               ITMP = IPERM(3)
               IPERM(3) = IPERM(4)
               IPERM(4) = ITMP
             END IF
             IF (IIJJ.LT.KKLL) THEN
               ITMP = INEW
               INEW = KNEW
               KNEW = ITMP
               ITMP = IPERM(1)
               IPERM(1) = IPERM(3)
               IPERM(3) = ITMP
               ITMP = JNEW
               JNEW = LNEW
               LNEW = ITMP
               ITMP = IPERM(2)
               IPERM(2) = IPERM(4)
               IPERM(4) = ITMP
               ITMP = IIJJ
               IIJJ = KKLL
               KKLL = ITMP
             END IF
C
C      ----- POPLE SET UP -----
C
           IF (POPLE) THEN
C
C  NON-CANONICAL 4-LABEL SYMMETRY WEIGHT
C
             SFAC = 0.125D+00
             IF (KSH.NE.ISH) SFAC = 0.25D+00
C
C  ENSURE SHELL ANGULAR MOMENTA ARE IN CANONICAL ORDER
C
             IMAX=KTYPE(INEW)-1
             JMAX=KTYPE(JNEW)-1
             KKKMAX=KTYPE(KNEW)-1
             LMAX=KTYPE(LNEW)-1
             IF (IMAX.LT.JMAX) THEN
               ITMP = INEW
               INEW = JNEW
               JNEW = ITMP
               ITMP = IPERM(1)
               IPERM(1) = IPERM(2)
               IPERM(2) = ITMP
             END IF
             IF (KKKMAX.LT.LMAX) THEN
               ITMP = KNEW
               KNEW = LNEW
               LNEW = ITMP
               ITMP = IPERM(3)
               IPERM(3) = IPERM(4)
               IPERM(4) = ITMP
             END IF
             IF ((IMAX+JMAX).LT.(KKKMAX+LMAX)) THEN
               ITMP = INEW
               INEW = KNEW
               KNEW = ITMP
               ITMP = IPERM(1)
               IPERM(1) = IPERM(3)
               IPERM(3) = ITMP
               ITMP = JNEW
               JNEW = LNEW
               LNEW = ITMP
               ITMP = IPERM(2)
               IPERM(2) = IPERM(4)
               IPERM(4) = ITMP
               ITMP = IIJJ
               IIJJ = KKLL
               KKLL = ITMP
             END IF
C
C   GENERATE THE INVERSE PERMUTATION OF IPERM
C   TO MAP THE NON-SEPARABLE INDICES ONTO THE
C   PERMUTED SHELL ORDERING
C
             DO I = 1, 4
               DO J = 1, 4
                 IF (IPERM(J).EQ.I) INVPERM(I) = J
               END DO
             END DO
             IMAX=3*(KTYPE(INEW)-1)+1
             JMAX=3*(KTYPE(JNEW)-1)+1
             KKKMAX=3*(KTYPE(KNEW)-1)+1
             LMAX=3*(KTYPE(LNEW)-1)+1
             JTYPE=(IMAX+JMAX+KKKMAX+KKKMAX+LMAX-2)/3
             IAT = KATOM(INEW)
             JAT = KATOM(JNEW)
             KAT = KATOM(KNEW)
             LAT = KATOM(LNEW)
           ELSE
C
C    ----- HONDO SET UP -----
C
C  SHELL 4-LABEL WEIGHT IN THE NON-CANONICAL LIST
C
             SFAC = ONE
             IF(IIJJ.NE.KKLL) SFAC = HALF
             IF(ISH.NE.JSH) SFAC = SFAC*HALF
             IF(KSH.NE.LSH) SFAC = SFAC*HALF
             IF(KSH.NE.ISH) SFAC = SFAC*2.0D+00
C
C   GENERATE INVERSE PERMUTATION
C
             DO I = 1, 4
               DO J = 1, 4
                 IF (IPERM(J).EQ.I) INVPERM(I) = J
               END DO
             END DO
C
C  SET POINTERS TO THE IJ AND KL CHARGE DISTRIBUTIONS
C
             CALL OEDRD(X(INIJG),NIJ,NIJ0,IIJJ)
             CALL OEDRD(X(INIJG),NKL,NKL0,KKLL)
C
C  SELECT CENTERS FOR DERIVATIVES
C
             CALL JKDATM(INEW,JNEW,KNEW,LNEW)
C
C  SET INDICES FOR SHELL BLOCK
C
             CALL JKDSHL(INEW,JNEW,KNEW,LNEW)
             CALL JKDNDX(X(IIJKLG))
           END IF
C
C  COMBINE TERMS OF THE 2-PARTICLE DENSITY MATRIX
C
           IF(UMP2GD) THEN
             CALL UPAR2PDM(INEW,JNEW,KNEW,LNEW,INVPERM,Q4,SFAC
     *,                    X(IPSCF),X(IPSCFB),X(IPMAT),X(IPMATB)
     *,                    X(INSD),X(IDAB)
     *,                    ISHL,JSHL,KSHL,DABMAX,POPLE)
           ELSE IF(ZAPTGD) THEN
             CALL ZPAR2PDM(INEW,JNEW,KNEW,LNEW,INVPERM,Q4,SFAC
     *,                    X(IPSCF),X(IPMAT),X(INSD),X(IDAB),X(IPMUNUS)
     *,                    X(ICHIMUNU),X(IZMN),X(ITMUNU4)
     *,                    ISHL,JSHL,KSHL,DABMAX,POPLE)
           ELSE
             CALL PAR2PDM(INEW,JNEW,KNEW,LNEW,INVPERM,Q4,SFAC
     *,                   X(IPSCF),X(IPMAT),X(INSD),X(IDAB)
     *,                   ISHL,JSHL,KSHL,DABMAX,POPLE)
           END IF
C
C                FINE SCREENING, ON INTEGRAL VALUE TIMES DENSITY FACTOR
C
           IF(DABMAX*GMAX.LT.CUTOFF2) THEN
              IISKIP2 = IISKIP2+1
              GO TO 100
           END IF
C
C  CONTRACT DENSITY WITH THE DERIVATIVE INTEGRALS
C  AND ADD DIRECTLY TO GRADIENT VECTOR
C
           IDID = IDID+1
           IF (POPLE) THEN
            CALL JKDG80(DABMAX,INEW,JNEW,KNEW,LNEW,
     *                  JTYPE,IAT,JAT,KAT,LAT)
           ELSE
            CALL JKDSPD(NIJ0,NKL,NKL0,X(ICHRG),
     *      X(IGINT),X(IFINT),X(ISINT),X(IIJKLG),X(IGIJKL),
     1      X(IGNKL),X(IGNM),X(IXY),X(IXZ),X(IYZ),X(IX),X(IY),X(IZ),
     2      X(ISJ),X(ISK),X(ISL),X(IB00),X(IB01),X(IB10),X(IC00),
     3      X(ID00),X(IF00),X(IDIJ),X(IDKL),X(IDIJSI),X(IDIJSJ),
     4      X(IDKLSK),X(IDKLSL),X(IABV),X(ICV),X(IRW),X(IAAI),X(IAAJ),
     5      X(IBBK),X(IBBL),X(IFI),X(IFJ),X(IFK),X(IFL),X(ISII),X(ISJJ),
     6      X(ISKK),X(ISLL),X(ISIJ),X(ISIK),X(ISIL),X(ISJK),X(ISJL),
     7      X(ISKL),X(IDAB),MAXXYZ,FC,NC,DF,LDF,NBF,DDA,Q4,MINVEC,
     8      DABCUT,DABMAX)
           END IF
C
C  LOOP AND CONDITION ENDINGS
C
  100         CONTINUE   !  END OF THE SCREENINGS
             END IF      !  SYM IKJL
            END IF       !  SKIP 1-CENTRE
C
C  OFF-SET NON-SEPARABLE DENSITY INDEX TO NEXT SHELL
C
            INSD = INSD + LSHL
           END DO        !  LL-SHELL
          END DO         !  JJ-SHELL
          IF (DLB) CALL DDI_DLBNEXT( MYTASK )
         END IF          !  LOAD BALANCER
         LOCTSK = LOCTSK + 1
        END IF           !  IK-SYM
       END DO            !  KK-SHELL
      END DO             !  II-SHELL
C
C  TIDY UP
C
      CALL DDI_GSUMI(1909,IISKIP1,1)
      CALL DDI_GSUMI(1908,IISKIP2,1)
      CALL DDI_GSUMI(1907,IDID   ,1)
      IF (OUTPUT) THEN
        WRITE(ICHANL,3) IISKIP1,IISKIP2,IDID
        CALL FLSHBF(ICHANL)
      END IF
C
C  IN CASE OF NON-ABELIAN GROUPS...
C
      NT = NTSAVE
C
C  GLOBALLY SUM 2-PARTICLE GRADIENT
C  AND ADD 1-PARTICLE GRADIENT
C
      CALL DDI_GSUMF(1109,DE,NAT*3)
      CALL DAXPY(NAT*3,ONE,X(I1PG),1,DE,1)
      CALL SYMEG(DE)
      CALL DFINAL(1)
C
C  FREE WORKSPACE FOR BACK-TRANSFORMATION
C
      IF (ZAPTGD) CALL RETFM(NEED3)
      CALL RETFM(NEED2)
      CALL RETFM(NEED)
C
C  FINISHED WITH VOVO CLASS
C
      IF(UMP2GD) THEN
        CALL DDI_DESTROY( D_VOVOBB )
        CALL DDI_DESTROY( D_VOVOAB )
        CALL DDI_DESTROY( D_VOVO   )
      ELSE
        CALL DDI_DESTROY( D_VOVO )
      END IF
      IF (DLB) CALL DDI_DLBRESET
C
C  FREE W,P,D,V,E,L,S WORKSPACES FROM MP2DDI
C
      CALL RETFM(INEED)
      IF(MASWRK) WRITE(IW,4)
      CALL TIMIT(1)
      RETURN
C
1     FORMAT(/,6X,'COMPUTING 2-PARTICLE GRADIENT')
    3 FORMAT(1X,'THE COARSE/FINE SCHWARZ SCREENINGS SKIPPED ',I10,'/',
     *          I10,' BLOCKS.'/
     *     1X,'THE NUMBER OF GRADIENT INTEGRAL BLOCKS COMPUTED WAS',I10)
    4 FORMAT(1X,'..... DONE WITH MP2 GRADIENT .....')
      END
C*MODULE MP2DDI  *DECK BTRAN2
      SUBROUTINE BTRAN2(CMO,OAOA,GNS,MINJ,JSHL,DUM)
C
C -----------------------------------------------------------------
C  SECOND HALF BACK-TRANSFORMATION OF AMPLITUDES
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      LOGICAL OUTPUT,MP2ENG,UMP2GD
      DOUBLE PRECISION CMO(NBF,*), OAOA(NOCC,*), GNS(NBF,*), DUM(*)
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
C  BACK-TRANSFORM OCCUPIED INDICES TO SHELL AO INDICES
C
      CALL DGEMM('N','T', NACT,JSHL,NACT
     *,          ONE,OAOA(NCP1,NCP1),NOCC
     *,          CMO(MINJ,NCP1),NBF
     *,          ZERO,DUM,NACT)
C
C  BACK-TRANSFORM OCCUPIED INDICES TO ALL AO INDICES
C
      CALL DGEMM('N','N', NBF,JSHL,NACT
     *,          ONE,CMO(1,NCP1),NBF
     *,          DUM,NACT
     *,          ZERO,GNS,NBF)
      RETURN
      END
C*MODULE MP2DDI  *DECK PAR2PDM
      SUBROUTINE PAR2PDM(INEW,JNEW,KNEW,LNEW,INVPERM,Q4,SFAC,
     2                   PHF,PMP2,GNS,DAB,ISHL,JSHL,KSHL,DABMAX,POPLE)
C
C -----------------------------------------------------------------
C  COMBINE TERMS OF 2-PARTICLE DENSITY MATRIX FOR A SHELL OF
C  DERIVATIVE INTEGRALS - COMPUTING SCF AND SEPARABLE TERMS
C -----------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION INVPERM(4),PHF(*),PMP2(*),DAB(*)
      LOGICAL POPLE
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXAO=8192)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CCG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /SHLLMN/ IGXYZ(4,35),JGXYZ(4,35),KGXYZ(4,35),LGXYZ(4,35)
      COMMON /SHLNRM/ PNRM(84)
      LOGICAL OUTPUT,MP2ENG,UMP2GD
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC,
     *                NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1,
     *                NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
C
CJMS  LABELLED COMMON GSPG80 DEFINED FOR COMPUTATIONAL EFFICIENCY.
CJMS  FOR SP BASES ONLY, IT CONTAINS THE E ARRAY WHICH IS THE DAB
CJMS  ARRAY WITH INDICES IN REVERSE ORDER: E(I,J,K,L)= DAB(L,K,J,I)
CJMS  AND IS USED IN SUB JKDG80 (MODULE GRD2B). IT ORIGINATES IN:
CJMS
CJMS     1. SUBS DABCLU, DABDFT, DABGVB, DABMC AND DABMP2 (MODULE
CJMS        GRD2A) AND SUB DABPAU (MODULE EFPAUL) WHICH ARE ALL
CJMS        CALLED BY SUB JKDER (MODULE GRD2A)
CJMS
CJMS     2. SUB DABCLU (MODULE GRD2A) WHICH IS CALLED BY SUB EFDEN OF
CJMS        MODULE EFGRD2
CJMS
CJMS     3. SUB PAR2PDM (MODULE MP2DDI) WHICH IS CALLED BY SUB PJKDMP2
CJMS        OF MODULE MP2DDI
C
      COMMON /GSPG80/ E(4,4,4,4)
C
C  NON-SEPARABLE TERMS ARE IN GNS
C  GNS HAS 4 DIMENSIONS TO SIMPLIFY INDEXING LATER
C  LEADING DIMENSION MUST BE SET TO NBF
C
      DIMENSION GNS(NBF,JSHL,KSHL,ISHL)
C
      DIMENSION IINDX(4)
C
      PARAMETER (ZER=0.0D+00, PT5=0.5D+00, F04=4.0D+00)
C
      DABMAX= ZER
      MINI= KMIN(INEW)
      MINJ= KMIN(JNEW)
      MINK= KMIN(KNEW)
      MINL= KMIN(LNEW)
      MAXI= KMAX(INEW)
      MAXJ= KMAX(JNEW)
      MAXK= KMAX(KNEW)
      MAXL= KMAX(LNEW)
      LOCI= KLOC(INEW)-MINI
      LOCJ= KLOC(JNEW)-MINJ
      LOCK= KLOC(KNEW)-MINK
      LOCL= KLOC(LNEW)-MINL
C
      IF(POPLE) THEN
         DO I=1,4
            IGXYZ(1,I)=64*(I-1)+1
            JGXYZ(1,I)=16*(I-1)
            KGXYZ(1,I)= 4*(I-1)
            LGXYZ(1,I)=   (I-1)
         END DO
C
         DO L=MINL,MAXL
            IINDX(4) = L-(MINL-1)
            NNU = LOCL+L
            DO K=MINK,MAXK
               IINDX(3) = K-(MINK-1)
               NMU = LOCK+K
               MUNU= IA(MAX0(NMU,NNU))+MIN0(NMU,NNU)
               DO J=MINJ,MAXJ
                  IINDX(2) = J-(MINJ-1)
                  NSI = LOCJ+J
                  DO I=MINI,MAXI
                     IINDX(1) = I-(MINI-1)
                     NLA = LOCI+I
                     LASI= IA(MAX0(NLA,NSI))+MIN0(NLA,NSI)
                     MUSI= IA(MAX0(NMU,NSI))+MIN0(NMU,NSI)
                     LANU= IA(MAX0(NLA,NNU))+MIN0(NLA,NNU)
                     MULA= IA(MAX0(NMU,NLA))+MIN0(NMU,NLA)
                     NUSI= IA(MAX0(NNU,NSI))+MIN0(NNU,NSI)
C
CJMS  LET'S SAVE A FEW MULTIPLICATIONS
C
C  SCF DENSITY
C
CC                   DSCF=PHF (MUNU)*PHF(LASI)*F04-
CC   *                    PHF (MUSI)*PHF(LANU)-
CC   *                    PHF (MULA)*PHF(NUSI)
C
C  MP2 SEPARABLE TERM
C
CC                   DSEP=PMP2(MUNU)*PHF(LASI)*F04+
CC   *                    PMP2(LASI)*PHF(MUNU)*F04-
CC   *                    PMP2(MUSI)*PHF(LANU)-
CC   *                    PMP2(MULA)*PHF(NUSI)-
CC   *                    PMP2(NUSI)*PHF(MULA)-
CC   *                    PMP2(LANU)*PHF(MUSI)
C
                     DF1=(PHF (MUNU)+PMP2(MUNU))*PHF (LASI)+
     2                    PHF (MUNU)*PMP2(LASI)
                     DQ1=(PHF (MUSI)+PMP2(MUSI))*PHF (LANU)+
     2                    PHF (MUSI)*PMP2(LANU)+
     3                   (PHF (MULA)+PMP2(MULA))*PHF (NUSI)+
     4                    PHF (MULA)*PMP2(NUSI)
C
C  MP2 NON-SEPARABLE TERM
C
                     IP = IINDX(INVPERM(1))
                     JP = IINDX(INVPERM(2))
                     KP = IINDX(INVPERM(3))
                     LP = IINDX(INVPERM(4))
CC                   DNON = 16.0D+00*GNS(LP,JP,KP,IP)
C
C  TOTAL MP2 DENSITY
C
CC                   DF1= DSCF + DSEP + DNON
                     DF1=-DQ1+F04*(DF1+F04*GNS(LP,JP,KP,IP))
C
C  NON-CANONICAL SHELL 4-LABEL WEIGHT
C
                     DF1= DF1*Q4*SFAC
C
                     IF(DABMAX.LT. ABS(DF1)) DABMAX = ABS(DF1)
                     E(I,J,K,L)= DF1
                  END DO
               END DO
            END DO
         END DO
      ELSE
C
C D AND HIGHER FUNCTIONS OR HONDO ONLY RUNS
C
         DO I=MINI,MAXI
            P1I= PNRM(I)
            IINDX(1) = I-(MINI-1)
            NLA = LOCI+I
            DO J=MINJ,MAXJ
               P2J= P1I*PNRM(J)
               IINDX(2) = J-(MINJ-1)
               NSI = LOCJ+J
               LASI= IA(MAX0(NLA,NSI))+MIN0(NLA,NSI)
               DO K=MINK,MAXK
                  P3K= P2J*PNRM(K)
                  IINDX(3) = K-(MINK-1)
                  NMU = LOCK+K
                  DO L=MINL,MAXL
                     P4L= P3K*PNRM(L)
                     IINDX(4) = L-(MINL-1)
                     NNU = LOCL+L
                     MUNU= IA(MAX0(NMU,NNU))+MIN0(NMU,NNU)
                     MUSI= IA(MAX0(NMU,NSI))+MIN0(NMU,NSI)
                     LANU= IA(MAX0(NLA,NNU))+MIN0(NLA,NNU)
                     MULA= IA(MAX0(NMU,NLA))+MIN0(NMU,NLA)
                     NUSI= IA(MAX0(NNU,NSI))+MIN0(NNU,NSI)
C
CJMS  LET'S SAVE A FEW MULTIPLICATIONS
C
C  SCF DENSITY
C
CC                   DSCF=PHF (MUNU)*PHF(LASI)*F04-
CC   *                    PHF (MUSI)*PHF(LANU)-
CC   *                    PHF (MULA)*PHF(NUSI)
C
C  MP2 SEPARABLE TERM
C
CC                   DSEP=PMP2(MUNU)*PHF(LASI)*F04+
CC   *                    PMP2(LASI)*PHF(MUNU)*F04-
CC   *                    PMP2(MUSI)*PHF(LANU)-
CC   *                    PMP2(MULA)*PHF(NUSI)-
CC   *                    PMP2(NUSI)*PHF(MULA)-
CC   *                    PMP2(LANU)*PHF(MUSI)
C
                     DF1=(PHF (MUNU)+PMP2(MUNU))*PHF (LASI)+
     2                    PHF (MUNU)*PMP2(LASI)
                     DQ1=(PHF (MUSI)+PMP2(MUSI))*PHF (LANU)+
     2                    PHF (MUSI)*PMP2(LANU)+
     3                   (PHF (MULA)+PMP2(MULA))*PHF (NUSI)+
     4                    PHF (MULA)*PMP2(NUSI)
C
C  MP2 NON-SEPARABLE TERM
C
                     IP = IINDX(INVPERM(1))
                     JP = IINDX(INVPERM(2))
                     KP = IINDX(INVPERM(3))
                     LP = IINDX(INVPERM(4))
CC                   DNON = 16.0D+00*GNS(LP,JP,KP,IP)
C
C  TOTAL MP2 DENSITY
C
CC                   DF1= DSCF + DSEP + DNON
                     DF1=-DQ1+F04*(DF1+F04*GNS(LP,JP,KP,IP))
C
C  NON-CANONICAL AO 4-LABEL WEIGHT
C
                     DF1= DF1*P4L*SFAC
                     IF(NMU .EQ.NNU ) DF1= DF1*PT5
                     IF(NLA .EQ.NSI ) DF1= DF1*PT5
                     IF(MUNU.EQ.LASI) DF1= DF1*PT5
C
                     IF(DABMAX.LT. ABS(DF1)) DABMAX = ABS(DF1)
                     IJKL=IGXYZ(1,I)+JGXYZ(1,J)+KGXYZ(1,K)+LGXYZ(1,L)
                     DAB(IJKL) = DF1
                  END DO
               END DO
            END DO
         END DO
      END IF
C
C  SYMMETRISE DENSITY MATRIX
C
      IF(INEW.EQ.JNEW) THEN
         DO L=MINL,MAXL
            DO K=MINK,MAXK
               DO J=MINJ,MAXJ
                  DO I=MINI,MAXI
                     IF(POPLE) THEN
                        DF1=(E(I,J,K,L)+E(J,I,K,L))*PT5
                        E(I,J,K,L)= DF1
                        E(J,I,K,L)= DF1
                     ELSE
                        IJKL=IGXYZ(1,I)+JGXYZ(1,J)+KGXYZ(1,K)+LGXYZ(1,L)
                        JIKL=IGXYZ(1,J)+JGXYZ(1,I)+KGXYZ(1,K)+LGXYZ(1,L)
                        DF1=(DAB(IJKL) + DAB(JIKL))*PT5
                        DAB(IJKL) = DF1
                        DAB(JIKL) = DF1
                     END IF
                  END DO
               END DO
            END DO
         END DO
      END IF
      IF(KNEW.EQ.LNEW) THEN
         DO L=MINL,MAXL
            DO K=MINK,MAXK
               DO J=MINJ,MAXJ
                  DO I=MINI,MAXI
                     IF(POPLE) THEN
                        DF1=(E(I,J,K,L)+E(I,J,L,K))*PT5
                        E(I,J,K,L)= DF1
                        E(I,J,L,K)= DF1
                     ELSE
                        IJKL=IGXYZ(1,I)+JGXYZ(1,J)+KGXYZ(1,K)+LGXYZ(1,L)
                        IJLK=IGXYZ(1,I)+JGXYZ(1,J)+KGXYZ(1,L)+LGXYZ(1,K)
                        DF1=(DAB(IJKL) + DAB(IJLK))*PT5
                        DAB(IJKL) = DF1
                        DAB(IJLK) = DF1
                     END IF
                  END DO
               END DO
            END DO
         END DO
      END IF
      IJ = IA(MAX0(INEW,JNEW))+MIN0(INEW,JNEW)
      KL = IA(MAX0(KNEW,LNEW))+MIN0(KNEW,LNEW)
      IF(IJ.EQ.KL) THEN
         DO L=MINL,MAXL
            DO K=MINK,MAXK
               DO J=MINJ,MAXJ
                  DO I=MINI,MAXI
                     IF(POPLE) THEN
                        DF1=(E(I,J,K,L)+E(K,L,I,J))*PT5
                        E(I,J,K,L)= DF1
                        E(K,L,I,J)= DF1
                     ELSE
                        IJKL=IGXYZ(1,I)+JGXYZ(1,J)+KGXYZ(1,K)+LGXYZ(1,L)
                        KLIJ=IGXYZ(1,K)+JGXYZ(1,L)+KGXYZ(1,I)+LGXYZ(1,J)
                        DF1=(DAB(IJKL) + DAB(KLIJ))*PT5
                        DAB(IJKL) = DF1
                        DAB(KLIJ) = DF1
                     END IF
                  END DO
               END DO
            END DO
         END DO
      END IF
      RETURN
      END
C*MODULE MP2DDI  *DECK PMP2CHK
      SUBROUTINE PMP2CHK
C
C --------------------------------------------------------------------
C  1-NODE/INTERACTIVE DISTRIBUTED DATA CHECK RUN
C --------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER ( MXATM=2000, MXGSH=30, MXG2=MXGSH*MXGSH,MXIRR=14)
      PARAMETER ( BIGUNIT = 1.0D+06, HALF = 0.5D+00 )
      LOGICAL PACK2E,POPLE,OUTPUT,MP2ENG,UMP2GD,ZAPTGD
      LOGICAL GOPARR,DSKWRK,MASWRK
      CHARACTER*8 CXBASIS
C
      COMMON /CXTHRM/ CXTHERM(11),CXZPE,METHCX,ICXBAS,CXBASIS
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /MP2XTR/ NBF,NACORE,NBSQ,NBTR,NSTR,MXSHL,NACT,NOCC
     *,               NVIR,NOV,NOSQ,NVSQ,NOTR,NVTR,NCP1,NOP1
     *,               NATR,ICHANL,OUTPUT,MP2ENG,IOST,NMOS,UMP2GD
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWORD,MEMPRI,MPPROP,
     *                NACORE_MP2PAR,NBCORE_MP2PAR,NOA,NOB,NO,NBF_MP2PAR,
     *                NOMIT,MOCPHF,MAXITC
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /UMP2XB/ NBCORE,NACTB,NOCCB,NVIRB,NOVB,NOSB,NVSB,NOTB,
     *                NVTB,NCP1B,NOP1B,NATB,IOSTB,NOCCBLD
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /ZAPTGR/ NOCD,NOCD1,NOCS,NOCSTR,IXYEXC,ICHIX,ITIA,IZVEC
     *,               ZAPTGD
C
      DATA ZAPT,UHF,RHF/8HZAPT    ,8HUHF     ,8HRHF     /
      DATA G3MP2/8HG3MP2   /
      DATA CHECK/8HCHECK   /
C
                          IPRT=0
      IF(EXETYP.EQ.CHECK) IPRT=1
C
      IF (MASWRK  .AND.  IPRT.EQ.1) WRITE(ICHANL,7)
C
C  GET MEMORY REQUESTED - READ $SYSTEM AGAIN
C  (THESE 2 ARE RETURNED IN CALLING ARGS, MEMINP IS IN WORDS!)
C
      CALL SYSINP( MEMINP, MEMDDI )
      GOPARR = .TRUE.
C
      IF(MEMINP.EQ.0) MEMINP=1000000
      IF(MASWRK  .AND.  IPRT.EQ.0) THEN
        MWREP = (MEMINP-1)/1000000 + 1
        GBYTES = MEMDDI
        GBYTES = 8.0D+00*(MWREP + GBYTES/NPROC)/1024.0D+00
        WRITE(ICHANL,8) MWREP,MEMDDI,NPROC,GBYTES
      END IF
C
C  CALCULATE THE LEVEL OF DERIVATIVE NEEDED
C
      CALL DERCHK(NDER)
      IF(RUNTYP.EQ.G3MP2) THEN
         IF(ICXBAS.EQ.1) NDER=1
         IF(ICXBAS.EQ.2) NDER=0
      END IF
C
C  COMPUTE THE MEMORY REQUIREMENTS AS A FUNCTION OF PROCESSORS USED.
C
C  THIS IS AN OLD ROUTINE, ACTUALLY -NODEX- BELOW MEANS A CORE/CPU!
C  CHECK RUNS WILL TRY 12 POWERS OF TWO AS POSSIBLE PROCESSOR COUNTS,
C  WHILE A REAL RUN USES THE P THAT IT HAPPENS TO BE RUNNING ON.
C
      IF(MASWRK  .AND.  IPRT.EQ.1) WRITE(ICHANL,1)
      IPROC = -1
                    MAXORDER=12
      IF(IPRT.EQ.0) MAXORDER=0
      DO 100 NORDER = 0,MAXORDER
C
C           GET CORES TO USE IN REPLICATED OR DISTRIBUTED MEMORY COUNT
C           NODED>1 GETS MEMDDI/CPU, SO TOTAL MEMDDI IS FOR NODED=1
C
        IF(IPRT.EQ.0) THEN
           NODER = NPROC
           NODED = 1
        ELSE
           NODER  = 2**NORDER
           NODED  = 2**NORDER
        END IF
C
C              ENERGY ONLY CODES USE -LESS- MEMORY
C
        IF (NDER.EQ.0 .AND. MPPROP.EQ.0) THEN
C
C  OPEN SHELL UMP2 ENERGY
C
          IF (SCFTYP.EQ.UHF) THEN
            MEM1 = 2*NBSQ + 2*NBF + 2*NMOS + NSTR
            MEM2 = NBTR + NBSQ + 3*NBF
            MBUF1= (NVIR*MXSHL*(NATR+1)+1)/NODER
            MBUF1= MAX( NBSQ, MBUF1 )
            MBUF2= (NVIRB*MXSHL*(NATB+1)+1)/NODER
            MBUF2= MAX( NBSQ, MBUF2)
            MEM3 = MXSHL*MXSHL*NBF*NACT
     *           + MXSHL*MXSHL*NBF*NACTB
     *           + 2*MBUF1
     *           + 2*MBUF2
     *           + MXSHL**4
     *           + 49*MXG2
            MEMREP = MEM1 + MAX(MEM2,MEM3)
             TEMP1 = NATR*(NBSQ/BIGUNIT)          !  DISTRIBUTED
             TEMP1 = TEMP1/NODED + MBUF1/BIGUNIT  !    DATA
             TEMP2 = NATB*(NBSQ/BIGUNIT)          !
             TEMP2 = TEMP2/NODED + MBUF2/BIGUNIT  !
             TEMP3 = NACT*NACTB*(NBSQ/BIGUNIT)    !
             TEMP3 = TEMP3/NODED                  !
            MEMDIS = INT(TEMP1 + TEMP2 + TEMP3 + HALF )
C
C  CLOSED SHELL ENERGY
C
          ELSE IF (SCFTYP.EQ.RHF) THEN
            MEM1 = NBSQ + NBF + NMOS + NSTR
            MEM2 = NBTR + NBSQ + 3*NBF
            MBUF = (NVIR*MXSHL*(NATR+1)+1)/NODER
            MBUF = MAX( NBSQ, MBUF )
            MEM3 = MXSHL*MXSHL*NBF*NACT
     *           + 2*MBUF
     *           + MXSHL**4
     *           + 49*MXG2
            MEMREP = MEM1 + MAX( MEM2, MEM3 )
              TEMP = NATR*(NBSQ/BIGUNIT)          !  DISTRIBUTED
              TEMP = TEMP/NODED + MBUF/BIGUNIT    !    DATA
            MEMDIS = INT(TEMP + HALF )            !
C
C  ZAPT ENERGY
C
          ELSE IF (OSPT.EQ.ZAPT) THEN
            MEM1 = NBSQ + NBF + NMOS + NSTR
            MEM2 = NBTR + NBSQ + 3*NBF
            MBUF = (NVIR*MXSHL*(NOTR+1)+1)/NODER
            MBUF = MAX( NBSQ, MBUF )
            MEM3 = MXSHL*MXSHL*NBF*NOCC
     *           + MBUF
     *           + MAX( MBUF, NOTR*MXSHL*MXSHL )
     *           + MXSHL**4
     *           + 49*MXG2
            MEMREP = MEM1 + MAX( MEM2, MEM3 )
            TEMP = NOTR*(NBSQ/BIGUNIT)          !
     *           + NOTR*(NVIR*NOCC/BIGUNIT)     !
     *           + NOTR*(NBTR/BIGUNIT)          !  DISTRIBUTED
     *           + NOTR*(NOTR/BIGUNIT)          !    DATA
            TEMP = TEMP/NODED + MBUF/BIGUNIT    !
            MEMDIS = INT(TEMP + HALF )            !
          END IF
        ELSE
          IF (SCFTYP.EQ.UHF) THEN
C          IF (UMP2GD) THEN
C
C  UMP2 GRADIENT
C
            MEM1 = 8*NBSQ + 2*NBF + 2*NMOS + NSTR
C
C  1) UMP2 MO ERI 4-INDEX TRANSFORMATION STEP
C
            MEM2 = NBTR + NBSQ + 3*NBF
            MBUF1= (NVIR*MXSHL*(NOTR+1)+1)/NODER
            MBUF1= MAX( NBSQ, MBUF1 )
            MBUF2= (NVIRB*MXSHL*(NOTB+1)+1)/NODER
            MBUF2= MAX( NBSQ, MBUF2)
            MEM3 = MXSHL*MXSHL*NBF*NOCC
     *           + MXSHL*MXSHL*NBF*NOCCB
     *           + MBUF1 + MAX(MBUF1,NOTR*MXSHL*MXSHL)
     *           + MBUF2 + MAX(MBUF2,NOTB*MXSHL*MXSHL)
     *           + MXSHL**4
     *           + 49*MXG2
            MAX1 = MAX(MEM2,MEM3)
C
C  DISTRIBUTED DATA
C
            TMP1 = NOTR*(NBSQ/BIGUNIT)          !  VOVOAA
     *           + NOCC*NOCCB*(NBSQ/BIGUNIT)    !  VOVOAB
     *           + NOTB*(NBSQ/BIGUNIT)          !  VOVOBB
     *           + NOTR*(NVIR*NOCC/BIGUNIT)     !  VOOOAA
     *           + NOTB*(NVIR*NOCC/BIGUNIT)     !  VOOOAB
     *           + NOTR*(NVIRB*NOCCB/BIGUNIT)   !  VOOOBA
     *           + NOTB*(NVIRB*NOCCB/BIGUNIT)   !  VOOOBB
     *           + NOTR*(NBTR/BIGUNIT)          !  VVOOAA
     *           + NOTB*(NBTR/BIGUNIT)          !  VVOOAB
     *           + NOTR*(NBTR/BIGUNIT)          !  VVOOBA
     *           + NOTB*(NBTR/BIGUNIT)          !  VVOOBB
     *           + NOTR*(NOTR/BIGUNIT)          !  OOOOAA
     *           + NOTR*(NOTB/BIGUNIT)          !  OOOOAB
     *           + NOTB*(NOTB/BIGUNIT)          !  OOOOBB
            TMP1 = TMP1/NODED                   !
C
C  2) UMP2 VVVO ERI COMPUTATION STEP
C
            MEM2 = 4*NBSQ
            MEM3 = 2*NBSQ
     *           + MXSHL*MXSHL*(MAX(NBF*NOCC*2,NOTB))
     *           + MXSHL*MXSHL*(MAX(NBF*NOCCB*2,NOTR))
     *           + NOSQ*MXSHL*MXSHL
     *           + NOSB*MXSHL*MXSHL
     *           + 2*NOCC*NOCCB*MXSHL*MXSHL
     *           + NOCC*NBF
     *           + NOCCB*NBF
     *           + MXSHL**4
     *           + 49*MXG2
            LEN  = NOV  !  CANNOT DETERMINE EFFECT OF SYMMETRY  !
            LENB = NOVB
            MAXC = MAXITC
            MEM4 = 2*NOV
     *           + 2*NOVB
     *           + 3*LEN
     *           + 3*LENB
     *           + 3*MXIRR
     *           + 2*MXIRR*NMOS
     *           + 2*NMOS
     *           + 2*MAXC
     *           + (MAXC*MAXC+MAXC)/2
     *           + MAXC*MAXC
     *           + 2*NVSQ
     *           + 2*NVIRB*MAX(NVIRB,NVIR)
     *           + NVTR
     *           + NVTB
            MEM5 = 2*NOV
     *           + 2*NOVB
     *           + MAX(NOSQ,MAX(NOSB,MAX(NVIR,NVIRB)))
     *           + NOSQ
     *           + NOSB
            MAX2 = MAX( MAX( MAX( MEM5, MEM4 ), MEM3 ), MEM2 )
C
C  DISTRIBUTED DATA
C
            TMP2 = NOTR*(NBSQ/BIGUNIT)          !  VOVOAA
     *           + NOCC*NOCCB*(NBSQ/BIGUNIT)    !  VOVOAB
     *           + NOTB*(NBSQ/BIGUNIT)          !  VOVOBB
     *           + NOTR*(NVIR*NOCC/BIGUNIT)     !  VOOOAA
     *           + NOTB*(NVIR*NOCC/BIGUNIT)     !  VOOOAB
     *           + NOTR*(NVIRB*NOCCB/BIGUNIT)   !  VOOOBA
     *           + NOTB*(NVIRB*NOCCB/BIGUNIT)   !  VOOOBB
     *           + NOTR*(NBTR/BIGUNIT)          !  VVOOAA
     *           + NOTB*(NBTR/BIGUNIT)          !  VVOOAB
     *           + NOTR*(NBTR/BIGUNIT)          !  VVOOBA
     *           + NOTB*(NBTR/BIGUNIT)          !  VVOOBB
     *           + 2*MAXC*(LEN/BIGUNIT)         !  U ,E
     *           + 2*MAXC*(LENB/BIGUNIT)        !  UB,EB
            TMP2 = TMP2/NODED                   !
C
C  3) UMP2 2PDM COMPUTATION STEP
C
            POPLE= .TRUE.
            IF ( INTTYP.GE.2 ) POPLE = .FALSE.
            LENGTH = 1
            CALL VALFM( LOADFM )
            CALL JKDMEM(1, LOADFM, IADDR, LENGTH
     *,                 MINXYZ, MAXXYZ, MINVEC, POPLE, .TRUE. )
            MJKD = IADDR - LOADFM
            MEM2 = 2*NBSQ
            MEM3 = MXSHL*MXSHL*NOSQ
     *           + MXSHL*MXSHL*NOSB
     *           + 2*MXSHL*MXSHL*NOCC*NOCCB
     *           + MXSHL*MXSHL*MXSHL*NBF
     *           + 2*MXSHL*MXSHL*MAX(NOTR,NOTB)
     *           + MXSHL**4
     *           + 2*NAT*3
            MAX3 = MJKD + MAX( MEM2, MEM3 )
C
C    OVERALL MAXIMA OF STEPS 1-3 FOR UMP2 GRADIENT
C
            MEMREP = MEM1 + MAX( MAX( MAX3, MAX2 ), MAX1 )
              TEMP = MAX(TMP1,TMP2) + (MBUF1+MBUF2)/BIGUNIT   ! DISTRIB
            MEMDIS = INT(TEMP + HALF )                        !   DATA
          ELSE IF (SCFTYP.EQ.RHF) THEN
C
C  CLOSED SHELL GRADIENT
C
            MEM1 = 4*NBSQ + NBF + NMOS + NSTR
C
C  1) MO ERI 4-INDEX TRANSFORMATION STEP
C
            MEM2 = NBTR + NBSQ + 3*NBF
            MBUF = (NVIR*MXSHL*(NOTR+1)+1)/NODER
            MBUF = MAX( NBSQ, MBUF )
            MEM3 = MXSHL*MXSHL*NBF*NOCC
     *           + MBUF
     *           + MAX( MBUF, NOTR*MXSHL*MXSHL )
     *           + MXSHL**4
     *           + 49*MXG2
            MAX1 = MAX( MEM2, MEM3 )
            TMP1 = NOTR*(NBSQ/BIGUNIT)              !
     *           + NOTR*(NVIR*NOCC/BIGUNIT)         !  DISTRIBUTED
     *           + NOTR*(NBTR/BIGUNIT)              !    DATA
     *           + NOTR*(NOTR/BIGUNIT)              !
            TMP1 = TMP1/NODED                       !
C
C  2) VVVO ERI COMPUTATION STEP
C
            MEM2 = 3*NBSQ
            MEM3 = NBSQ
     *           + 2*MXSHL*MXSHL*NBF*NOCC
     *           + NOSQ*MXSHL*MXSHL
     *           + NOCC*NBF
     *           + MXSHL**4
     *           + 49*MXG2
            LEN  = NOV !  CANNOT DETERMINE EFFECT OF SYMMETRY  !
            MAXC = MAXITC
            MEM4 = 2*NOV
     *           + 3*LEN
     *           + 2*MXIRR
     *           + MXIRR*NMOS
     *           + NMOS
     *           + 4*MAXC
     *           + 2*MAXC*MAXC
     *           + MAX( NVSQ, MAX( MAXC, LEN ) )
     *           + MAX( NVSQ, MAXC )
     *           + NVTR
            MEM5 = 2*NOV
     *           + MAX( NOSQ, NVIR )
     *           + NOSQ
            MAX2 = MAX( MAX( MAX( MEM5, MEM4 ), MEM3 ), MEM2 )
            TMP2 = NOTR*(NBSQ/BIGUNIT)              !
     *           + NOTR*(NVIR*NOCC/BIGUNIT)         !  DISTRIBUTED
     *           + NOTR*(NBTR/BIGUNIT)              !    DATA
     *           + MAXC*(LEN/BIGUNIT)               !
            TMP2 = TMP2/NODED                       !
C
C  3) 2PDM COMPUTATION STEP
C
            POPLE= .TRUE.
            IF ( INTTYP.GE.2 ) POPLE = .FALSE.
            LENGTH = 1
            CALL VALFM( LOADFM )
            CALL JKDMEM(1, LOADFM, IADDR, LENGTH
     *,                 MINXYZ, MAXXYZ, MINVEC, POPLE, .TRUE. )
            MJKD = IADDR - LOADFM
            MEM2 = 2*NBSQ
            MEM3 = MXSHL*MXSHL*NOSQ
     *           + MXSHL*MXSHL*MXSHL*NBF
     *           + MXSHL*MXSHL*NOTR
     *           + MXSHL**4
     *           + 2*NAT*3
            MAX3 = MJKD + MAX( MEM2, MEM3 )
C
C    OVERALL MAXIMA OF STEPS 1-3
C
            MEMREP = MEM1 + MAX( MAX( MAX3, MAX2 ), MAX1 )
              TEMP = MAX( TMP1, TMP2 ) + MBUF/BIGUNIT   !  DISTRIBUTED
            MEMDIS = INT(TEMP + HALF )                  !    DATA
          ELSE IF (OSPT.EQ.ZAPT) THEN
C
C  ZAPT GRADIENT
C
            LEN = NOCD*NOCS + NOCD*NVIR + NOCS*NVIR
C  !  CANNOT DETERMINE EFFECT OF SYMMETRY  !
C
            MEM1 = 4*NBSQ + NBF + NMOS + NSTR + 2*NOCS
     *           + (NACT-NOCS)*NVIR + LEN
C
C  1) MO ERI 4-INDEX TRANSFORMATION STEP (SAME AS CLOSED SHELL)
C
            MEM2 = NBTR + NBSQ + 3*NBF
            MBUF = (NVIR*MXSHL*(NOTR+1)+1)/NODER
            MBUF = MAX( NBSQ, MBUF )
            MEM3 = MXSHL*MXSHL*NBF*NOCC
     *           + MBUF
     *           + MAX( MBUF, NOTR*MXSHL*MXSHL )
     *           + MXSHL**4
     *           + 49*MXG2
            MAX1 = MAX( MEM2, MEM3 )
            TMP1 = NOTR*(NBSQ/BIGUNIT)              !
     *           + NOTR*(NVIR*NOCC/BIGUNIT)         !  DISTRIBUTED
     *           + NOTR*(NBTR/BIGUNIT)              !    DATA
     *           + NOTR*(NOTR/BIGUNIT)              !
            TMP1 = TMP1/NODED                       !
C
C  2) 1-PARTICLE MATRIX COMPUTATION STEP (FROM ZPAR1PDM)
C
            MAX2 = 2*NBSQ+4*NOCS*NOCS
     *           + MAX(NBTR,MAX(NOCS*NOCS*NVIR*(NOCD-NACORE),NMOS))
C
C  3) LAGVVV (SAME AS CLOSED SHELL)
C
            MEM2 = NBSQ*3
            MEM3 = NBSQ
     *           + 2*MXSHL*MXSHL*NBF*NOCC
     *           + NOSQ*MXSHL*MXSHL
     *           + NOCC*NBF
     *           + MXSHL**4
     *           + 49*MXG2
            MAX3 = MAX(MEM2,MEM3)
C
C  4) MEMORY FOR CPHF EQUATIONS
C
            MAXC = MAXITC
            MEM2 = LEN + NOTR*2 + NVIR*NOCC
     *           + MXIRR*(3+2*NMOS) + NMOS
     *           + 3*LEN
     *           + 4*MAXC
     *           + 2*MAXC*MAXC
     *           + MAX(MAX(NVSQ,NOSQ),MAX(MAXC,LEN))
     *           + MAX(NVSQ,MAX(MAXC,NVIR*MAX(NOCD,NOCS)))
     *           + 3*NBTR
     *           + NVTR
            MEM3 = LEN + NOTR*2 + NVIR*NOCC
     *           + NOSQ
     *           + MAX(NVTR,NOTR)
     *           + NVSQ
            MEM4 = 2*NBSQ + NBTR
            MAX4 = MAX( MEM2, MAX( MEM3, MEM4 ))
            TMP2 = NOTR*(NBSQ/BIGUNIT)              !
     *           + NOTR*(NVIR*NOCC/BIGUNIT)         !  DISTRIBUTED
     *           + NOTR*(NBTR/BIGUNIT)              !    DATA
     *           + NOTR*(NOTR/BIGUNIT)              !
     *           + MAXC*(LEN/BIGUNIT)               !
            TMP2 = TMP2/NODED                       !
C
C  5) 2PDM COMPUTATION STEP
C
            POPLE= .TRUE.
            IF ( INTTYP.GE.2 ) POPLE = .FALSE.
            LENGTH = 1
            CALL VALFM( LOADFM )
            CALL JKDMEM(1, LOADFM, IADDR, LENGTH
     *,                 MINXYZ, MAXXYZ, MINVEC, POPLE, .TRUE. )
            MJKD = IADDR - LOADFM
            ITRG = MAX(NVIR*NOCS, NOTR - (NOCD*NOCD+NOCD)/2)
            MEM2 = 2*NBSQ + 2*ITRG + NOCS*NOCS
            MEM3 = MXSHL*MXSHL*NOSQ
     *           + MXSHL*MXSHL*MXSHL*NBF
     *           + MXSHL*MXSHL*NOTR
     *           + MXSHL**4
     *           + 2*NAT*3
     *           + 4*NBTR
     *           + 2*NBSQ
            MAX5 = MJKD + MAX( MEM2, MEM3 )
C
C    OVERALL MAXIMA OF STEPS 1-5
C
            MEMREP = MEM1 + MAX(MAX(MAX(MAX(MAX5,MAX4),MAX3),MAX2),MAX1)
C
C    TMP2 DISTRIBUTED DATA IS LARGER THAN TMP1
C
              TEMP = TMP2 + MBUF/BIGUNIT                !  DISTRIBUTED
            MEMDIS = INT(TEMP + HALF )                  !    DATA
          END IF
        END IF
C
C           MEMDIS IS MEMDDI PER CORE
C           SAVE RESULT FOR RUNNING ON ONE CORE ONLY TO PRINT EACH TIME
C
        IF(MEMDIS.LT.1) MEMDIS=1
        IF(NORDER.EQ.0) MEMDIS0 = MEMDIS
C
        MWDDI = MEMDIS0
        MWREP = (MEMREP-1)/1000000 + 1
        IF(MASWRK  .AND. IPRT.EQ.1)
     *     WRITE(ICHANL,2) NODER, MWDDI, MEMREP, MWREP
C
C  TEST MEMDDI AGAINST ACTUAL REQUIREMENT.
C  (LOOP WITH 1 CORE COMPUTES THE TOTAL DISTRIBUTED MEMORY NEEDED).
C
        IF(NODER.EQ.1 .AND. MEMDDI.LT.MEMDIS) THEN
           IF(MASWRK) WRITE(ICHANL,3) MEMDDI
           CALL ABRT
        END IF
C
C  MORE CPUS WILL DECREASE MEMREP, KEEP PRINTING TABLE
C  UNLESS THE REPLICATED MEMORY HAS SETTLED DOWN.
C
        IF(IPRT.EQ.1) THEN
           IF(MEMREP.LT.MEMINP  .AND.  IPROC.EQ.-1) IPROC = NODER
           IF(NORDER.EQ.0) REPMEM = 2.0D+00*MEMREP
           IF(MEMREP.GT.INT(0.9D+00*REPMEM)) GO TO 200
           REPMEM = MEMREP
        END IF
C
  100 CONTINUE
C
C  TEST MWORDS AGAINST ACTUAL REQUIREMENT.
C
      IF(MEMREP.LT.MEMINP) GO TO 200
C
C  REPLICATED MEMORY IS NOT ENOUGH (AT LEAST ON 2**12 CORES!)
C
      WRITE(ICHANL,4) MEMINP
      CALL ABRT
C
C  IF WE GET HERE BOTH MEMDDI AND MEMINP ARE OK
C
  200 CONTINUE
      MWDDIREQ = MWDDI
      MWREPREQ = MWREP
      IF(MASWRK  .AND.  IPRT.EQ.1) WRITE(ICHANL,5) IPROC
      IF(MASWRK  .AND.  IPRT.EQ.0) THEN
        GBYTES = MWDDIREQ
        GBYTES = 8.0D+00*(MWREPREQ + GBYTES/NPROC)/1024.0D+00
        WRITE(ICHANL,9) MWREPREQ,MWDDIREQ,NPROC,GBYTES
      END IF
      RETURN
C
    1 FORMAT(/6X,'         DISTRIBUTED    --REPLICATED--'/
     *        6X,'CORES      MEMDDI       MEMORY/MWORDS')
    2 FORMAT(6X,I4,I11,I15,'/',I4,5X,I10)
    3 FORMAT(/6X,'* INSUFFICIENT DISTRIBUTED MEMORY REQUESTED *'/
     *        6X,'  YOUR $SYSTEM MEMDDI = ',I10//)
    4 FORMAT(/6X,'* INSUFFICIENT REPLICATED MEMORY REQUESTED *'/
     *        6X,'  YOUR $SYSTEM MEMORY = ',I10//)
    5 FORMAT(/1X,'CHECK SHOWS INPUT VALUES FOR DISTRIBUTED MEMDDI',
     *           ' AND REPLICATED MWORDS'/
     *        1X,'ARE SUFFICIENT FOR A CALCULATION RUNNING ON',I5,
     *           ' CPUS (AKA CORES).'//
     *        1X,'PLEASE COMPUTE YOUR RAM/CPU NEEDS AS SHOWN, FOR',
     *           ' P CORES:'/
     *        6X,'MILLIONS OF WORDS/CPU =    MWORDS + MEMDDI/P'/
     *        6X,'           MBYTES/CPU = 8*(MWORDS + MEMDDI/P)'/
     *        6X,'           GBYTES/CPU = 8*(MWORDS + MEMDDI/P)/1024'/
     *        1X,'CHOOSE A SUFFICIENTLY LARGE VALUE FOR -P- TO FIT',
     *           ' WITHIN YOUR MACHINE''S'/
     *        1X,'INSTALLED RAM/CPU.'//
     *        1X,'PLEASE NOTE: A NODE WITH 4 CORES AND 8 GB TOTAL',
     *           ' RAM HAS 2 GB/CPU.'/
     *        1X,'DISTRIBUTED MEMORY WILL BE SPREAD ACROSS ALL',
     *           ' CPUS (CORES) AT RUN TIME,'/
     *        1X,'REPLICATED MEMORY WILL BE ALLOCATED BY EACH AND',
     *           ' EVERY CPU.'/)
    7 FORMAT(1X,'EXETYP=CHECK FOR PARALLEL MP2 RUNS MUST BE DONE',
     *          ' AS FOLLOWS:'/
     *       1X,'  A) RUN ON ONLY ONE NODE, NOT NECESSARILY THE',
     *          ' TARGET PARALLEL SYSTEM.'/
     *       1X,'     THIS LETS YOU SIZE THE MEMORY ON A PLATFORM',
     *          ' WITH QUICK TURNAROUND.'/
     *       1X,'  B) USE $SYSTEM PARALL=.TRUE. SO THAT THE CHECK',
     *          ' RUN CHECKS RUNNING'/
     *       1X,'     THE PARALLEL CODE, NOT THE SERIAL CODE.',
     *          '  THIS KEYWORD IS NOT'/
     *       1X,'     NECESSARY WHEN THE REAL JOB EXECUTES ON',
     *          ' P>1, OF COURSE.'/
     *       1X,'  C) GIVE A RATHER SMALL MWORDS BUT A RATHER',
     *          ' BIG MEMDDI IN $SYSTEM.'/
     *       1X,'     THE CHECK RUN WILL NOT OFFICIALLY ALLOCATE',
     *          ' ITS MEMDDI FROM THE'/
     *       1X,'     OPERATING SYSTEM, SO YOUR CHECK RUN MACHINE',
     *          ' ONLY HAS TO HAVE'/
     *       1X,'     ENOUGH RAM TO HANDLE THE MUCH SMALLER',
     *          ' VALUE OF MWORDS.'//)
    8 FORMAT(1X,'   THIS CALCULATION IS RUNNING WITH',
     *          ' MWORDS=',I5,', MEMDDI=',I8,', AND P=',I5/
     *       1X,'MEMORY USAGE PER CPU IS 8*(MWORDS + MEMDDI/P)/1024 =',
     *          F7.1,' GBYTES.'/)
    9 FORMAT(1X,'MINIMAL REQUIREMENT FOR THIS RUN IS',
     *          ' MWORDS=',I5,', MEMDDI=',I8,'.'/
     *       1X,'FOR P=',I5,', THE MEMORY USAGE PER CPU(CORE) WOULD BE',
     *          F7.1,' GBYTES.'/)
      END
